From 0f476b1de3c3e61467cff9536618d120873c47ab Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 10 May 2019 16:26:18 +0200 Subject: [PATCH 0001/1452] Move native C code into shared library --- lib/Makefile.in | 4 +++- src/Makefile.in | 50 ++++++++++++++++++++++++++++--------------------- src/emacs.c | 2 +- src/main.c | 26 +++++++++++++++++++++++++ 4 files changed, 59 insertions(+), 23 deletions(-) create mode 100644 src/main.c diff --git a/lib/Makefile.in b/lib/Makefile.in index 06d8e56421b..ed3123885d2 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -26,6 +26,8 @@ abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ +CFLAGS = -fPIC @CFLAGS@ + all: .PHONY: all @@ -50,7 +52,7 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = -ALL_CFLAGS= \ +ALL_CFLAGS= -fPIC \ $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \ $(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \ -I. -I../src -I$(srcdir) -I$(srcdir)/../src \ diff --git a/src/Makefile.in b/src/Makefile.in index ab63b926272..423c5a3f929 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -33,7 +33,7 @@ top_srcdir = @top_srcdir@ abs_top_srcdir=@abs_top_srcdir@ VPATH = $(srcdir) CC = @CC@ -CFLAGS = @CFLAGS@ +CFLAGS = @CFLAGS@ -fPIC CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ EXEEXT = @EXEEXT@ @@ -463,7 +463,7 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) # Must be first, before dep inclusion! -all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) +all: $(pdmp) $(OTHER_FILES) .PHONY: all dmpstruct_headers=$(srcdir)/lisp.h $(srcdir)/buffer.h \ @@ -642,25 +642,33 @@ else MAKE_PDUMPER_FINGERPRINT = endif -## We have to create $(etc) here because init_cmdargs tests its -## existence when setting Vinstallation_directory (FIXME?). -## This goes on to affect various things, and the emacs binary fails -## to start if Vinstallation_directory has the wrong value. -temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ - $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) - $(AM_V_CCLD)$(CC) -o $@.tmp \ - $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ - $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -ifeq ($(HAVE_PDUMPER),yes) - $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp -endif - $(AM_V_at)mv $@.tmp $@ - $(MKDIR_P) $(etc) -ifeq ($(DUMPING),unexec) - ifneq ($(PAXCTL_notdumped),) - $(PAXCTL_notdumped) $@ - endif -endif +## FIXME: dumper support totally missing here +libemacs.so: $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ + $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) main.o + $(CC) --shared -o $@ $(ALLOBJS) -Wl,-Bstatic $(LIBEGNU_ARCHIVE) -Wl,-Bdynamic $(LIBES) + +temacs$(EXEEXT): libemacs.so main.o + $(CC) -L. main.o -o $@ $(TEMACS_LDFLAGS) $(LDFLAGS) \ + $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lemacs -Wl,-rpath -Wl,$(shell pwd) + +# ## We have to create $(etc) here because init_cmdargs tests its +# ## existence when setting Vinstallation_directory (FIXME?). +# ## This goes on to affect various things, and the emacs binary fails +# ## to start if Vinstallation_directory has the wrong value. +# temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ +# $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) +# $(AM_V_CCLD)$(CC) -o $@.tmp \ +# $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ +# $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) +# ifeq ($(HAVE_PDUMPER),yes) +# $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp +# endif +# $(AM_V_at)mv $@.tmp $@ +# $(MKDIR_P) $(etc) +# ifeq ($(DUMPING),unexec) +# ifneq ($(PAXCTL_notdumped),) +# $(PAXCTL_notdumped) $@ +# endif ## The following oldxmenu-related rules are only (possibly) used if ## HAVE_X11 && !USE_GTK, but there is no harm in always defining them. diff --git a/src/emacs.c b/src/emacs.c index c5a760d29f6..81703b4660a 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -924,7 +924,7 @@ load_pdump (int argc, char **argv) #endif /* HAVE_PDUMPER */ int -main (int argc, char **argv) +main1 (int argc, char **argv) { /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ diff --git a/src/main.c b/src/main.c new file mode 100644 index 00000000000..41e35534280 --- /dev/null +++ b/src/main.c @@ -0,0 +1,26 @@ +/* Trampoline for GNU Emacs. + Copyright (C) 2019 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 . */ + +extern int main1 (int argc, char **argv); + +int +main (int argc, char **argv) +{ + return main1(argc, argv); +} From ea622e321d500715238214db9d8b994cffe8568e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 11 May 2019 14:56:56 +0200 Subject: [PATCH 0002/1452] Add nativecomp option to configure --- configure.ac | 13 +++++++++++++ src/Makefile.in | 4 +++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 24d21c7afd9..d059b7d6724 100644 --- a/configure.ac +++ b/configure.ac @@ -463,6 +463,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],[compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) +OPTION_DEFAULT_ON([nativecomp],[don't 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)])], @@ -3670,6 +3671,17 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) +HAVE_LIBGCCJIT=no +LIBGCCJIT_LIB= +if test "${with_nativecomp}" != "no"; then + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_LIBGCCJIT=yes, , -lgccjit) + if test "${HAVE_LIBGCCJIT}" = "yes"; then + LIBGCCJIT_LIB=-lgccjit + AC_DEFINE([HAVE_LIBGCCJIT], 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + fi +fi +AC_SUBST([LIBGCCJIT_LIB]) + ### Dynamic modules support LIBMODULES= HAVE_MODULES=no @@ -5714,6 +5726,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? ${with_nativecomp} "]) if test -n "${EMACSDATA}"; then diff --git a/src/Makefile.in b/src/Makefile.in index 423c5a3f929..4a66016e976 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -326,6 +326,8 @@ GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ +LIBGCCJIT = @LIBGCCJIT_LIB@ + RUN_TEMACS = ./temacs # Whether builds should contain details. '--no-build-details' or empty. @@ -531,7 +533,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) $(GMP_LIB) + $(JSON_LIBS) $(GMP_LIB) $(LIBGCCJIT) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, From 71d61b05d465a87d4e960704fc9e2e5cfef53077 Mon Sep 17 00:00:00 2001 From: Tom Tromey Date: Wed, 10 Jan 2018 16:27:39 -0700 Subject: [PATCH 0003/1452] Create bytecode.h * src/bytecode.h: New file. * src/bytecode.c: Move bytecode definitions to bytecode.h. --- src/bytecode.c | 207 +------------------------------------------- src/bytecode.h | 230 +++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp.h | 2 + 3 files changed, 233 insertions(+), 206 deletions(-) create mode 100644 src/bytecode.h diff --git a/src/bytecode.c b/src/bytecode.c index 9e75c9012e0..e11704fd8b0 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -27,6 +27,7 @@ along with GNU Emacs. If not, see . */ #include "ptr-bounds.h" #include "syntax.h" #include "window.h" +#include "bytecode.h" /* Work around GCC bug 54561. */ #if GNUC_PREREQ (4, 3, 0) @@ -77,212 +78,6 @@ along with GNU Emacs. If not, see . */ #endif /* BYTE_CODE_METER */ -/* Byte codes: */ - -#define BYTE_CODES \ -DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ -DEFINE (Bstack_ref1, 1) \ -DEFINE (Bstack_ref2, 2) \ -DEFINE (Bstack_ref3, 3) \ -DEFINE (Bstack_ref4, 4) \ -DEFINE (Bstack_ref5, 5) \ -DEFINE (Bstack_ref6, 6) \ -DEFINE (Bstack_ref7, 7) \ -DEFINE (Bvarref, 010) \ -DEFINE (Bvarref1, 011) \ -DEFINE (Bvarref2, 012) \ -DEFINE (Bvarref3, 013) \ -DEFINE (Bvarref4, 014) \ -DEFINE (Bvarref5, 015) \ -DEFINE (Bvarref6, 016) \ -DEFINE (Bvarref7, 017) \ -DEFINE (Bvarset, 020) \ -DEFINE (Bvarset1, 021) \ -DEFINE (Bvarset2, 022) \ -DEFINE (Bvarset3, 023) \ -DEFINE (Bvarset4, 024) \ -DEFINE (Bvarset5, 025) \ -DEFINE (Bvarset6, 026) \ -DEFINE (Bvarset7, 027) \ -DEFINE (Bvarbind, 030) \ -DEFINE (Bvarbind1, 031) \ -DEFINE (Bvarbind2, 032) \ -DEFINE (Bvarbind3, 033) \ -DEFINE (Bvarbind4, 034) \ -DEFINE (Bvarbind5, 035) \ -DEFINE (Bvarbind6, 036) \ -DEFINE (Bvarbind7, 037) \ -DEFINE (Bcall, 040) \ -DEFINE (Bcall1, 041) \ -DEFINE (Bcall2, 042) \ -DEFINE (Bcall3, 043) \ -DEFINE (Bcall4, 044) \ -DEFINE (Bcall5, 045) \ -DEFINE (Bcall6, 046) \ -DEFINE (Bcall7, 047) \ -DEFINE (Bunbind, 050) \ -DEFINE (Bunbind1, 051) \ -DEFINE (Bunbind2, 052) \ -DEFINE (Bunbind3, 053) \ -DEFINE (Bunbind4, 054) \ -DEFINE (Bunbind5, 055) \ -DEFINE (Bunbind6, 056) \ -DEFINE (Bunbind7, 057) \ - \ -DEFINE (Bpophandler, 060) \ -DEFINE (Bpushconditioncase, 061) \ -DEFINE (Bpushcatch, 062) \ - \ -DEFINE (Bnth, 070) \ -DEFINE (Bsymbolp, 071) \ -DEFINE (Bconsp, 072) \ -DEFINE (Bstringp, 073) \ -DEFINE (Blistp, 074) \ -DEFINE (Beq, 075) \ -DEFINE (Bmemq, 076) \ -DEFINE (Bnot, 077) \ -DEFINE (Bcar, 0100) \ -DEFINE (Bcdr, 0101) \ -DEFINE (Bcons, 0102) \ -DEFINE (Blist1, 0103) \ -DEFINE (Blist2, 0104) \ -DEFINE (Blist3, 0105) \ -DEFINE (Blist4, 0106) \ -DEFINE (Blength, 0107) \ -DEFINE (Baref, 0110) \ -DEFINE (Baset, 0111) \ -DEFINE (Bsymbol_value, 0112) \ -DEFINE (Bsymbol_function, 0113) \ -DEFINE (Bset, 0114) \ -DEFINE (Bfset, 0115) \ -DEFINE (Bget, 0116) \ -DEFINE (Bsubstring, 0117) \ -DEFINE (Bconcat2, 0120) \ -DEFINE (Bconcat3, 0121) \ -DEFINE (Bconcat4, 0122) \ -DEFINE (Bsub1, 0123) \ -DEFINE (Badd1, 0124) \ -DEFINE (Beqlsign, 0125) \ -DEFINE (Bgtr, 0126) \ -DEFINE (Blss, 0127) \ -DEFINE (Bleq, 0130) \ -DEFINE (Bgeq, 0131) \ -DEFINE (Bdiff, 0132) \ -DEFINE (Bnegate, 0133) \ -DEFINE (Bplus, 0134) \ -DEFINE (Bmax, 0135) \ -DEFINE (Bmin, 0136) \ -DEFINE (Bmult, 0137) \ - \ -DEFINE (Bpoint, 0140) \ -/* Was Bmark in v17. */ \ -DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ -DEFINE (Bgoto_char, 0142) \ -DEFINE (Binsert, 0143) \ -DEFINE (Bpoint_max, 0144) \ -DEFINE (Bpoint_min, 0145) \ -DEFINE (Bchar_after, 0146) \ -DEFINE (Bfollowing_char, 0147) \ -DEFINE (Bpreceding_char, 0150) \ -DEFINE (Bcurrent_column, 0151) \ -DEFINE (Bindent_to, 0152) \ -DEFINE (Beolp, 0154) \ -DEFINE (Beobp, 0155) \ -DEFINE (Bbolp, 0156) \ -DEFINE (Bbobp, 0157) \ -DEFINE (Bcurrent_buffer, 0160) \ -DEFINE (Bset_buffer, 0161) \ -DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ -DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bforward_char, 0165) \ -DEFINE (Bforward_word, 0166) \ -DEFINE (Bskip_chars_forward, 0167) \ -DEFINE (Bskip_chars_backward, 0170) \ -DEFINE (Bforward_line, 0171) \ -DEFINE (Bchar_syntax, 0172) \ -DEFINE (Bbuffer_substring, 0173) \ -DEFINE (Bdelete_region, 0174) \ -DEFINE (Bnarrow_to_region, 0175) \ -DEFINE (Bwiden, 0176) \ -DEFINE (Bend_of_line, 0177) \ - \ -DEFINE (Bconstant2, 0201) \ -DEFINE (Bgoto, 0202) \ -DEFINE (Bgotoifnil, 0203) \ -DEFINE (Bgotoifnonnil, 0204) \ -DEFINE (Bgotoifnilelsepop, 0205) \ -DEFINE (Bgotoifnonnilelsepop, 0206) \ -DEFINE (Breturn, 0207) \ -DEFINE (Bdiscard, 0210) \ -DEFINE (Bdup, 0211) \ - \ -DEFINE (Bsave_excursion, 0212) \ -DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ - \ -DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ -DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ - \ -DEFINE (Bset_marker, 0223) \ -DEFINE (Bmatch_beginning, 0224) \ -DEFINE (Bmatch_end, 0225) \ -DEFINE (Bupcase, 0226) \ -DEFINE (Bdowncase, 0227) \ - \ -DEFINE (Bstringeqlsign, 0230) \ -DEFINE (Bstringlss, 0231) \ -DEFINE (Bequal, 0232) \ -DEFINE (Bnthcdr, 0233) \ -DEFINE (Belt, 0234) \ -DEFINE (Bmember, 0235) \ -DEFINE (Bassq, 0236) \ -DEFINE (Bnreverse, 0237) \ -DEFINE (Bsetcar, 0240) \ -DEFINE (Bsetcdr, 0241) \ -DEFINE (Bcar_safe, 0242) \ -DEFINE (Bcdr_safe, 0243) \ -DEFINE (Bnconc, 0244) \ -DEFINE (Bquo, 0245) \ -DEFINE (Brem, 0246) \ -DEFINE (Bnumberp, 0247) \ -DEFINE (Bintegerp, 0250) \ - \ -DEFINE (BRgoto, 0252) \ -DEFINE (BRgotoifnil, 0253) \ -DEFINE (BRgotoifnonnil, 0254) \ -DEFINE (BRgotoifnilelsepop, 0255) \ -DEFINE (BRgotoifnonnilelsepop, 0256) \ - \ -DEFINE (BlistN, 0257) \ -DEFINE (BconcatN, 0260) \ -DEFINE (BinsertN, 0261) \ - \ -/* Bstack_ref is code 0. */ \ -DEFINE (Bstack_set, 0262) \ -DEFINE (Bstack_set2, 0263) \ -DEFINE (BdiscardN, 0266) \ - \ -DEFINE (Bswitch, 0267) \ - \ -DEFINE (Bconstant, 0300) - -enum byte_code_op -{ -#define DEFINE(name, value) name = value, - BYTE_CODES -#undef DEFINE - -#if BYTE_CODE_SAFE - Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163, /* this loser is no longer generated as of v18 */ -#endif -}; /* Fetch the next byte from the bytecode stream. */ diff --git a/src/bytecode.h b/src/bytecode.h new file mode 100644 index 00000000000..07452eb1851 --- /dev/null +++ b/src/bytecode.h @@ -0,0 +1,230 @@ +/* Byte code definitions + Copyright (C) 1985-1988, 1993, 2000-2018 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 . */ + +#ifndef EMACS_BYTECODE_H +#define EMACS_BYTECODE_H + +/* Byte codes: */ + +#define BYTE_CODES \ +DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ +DEFINE (Bstack_ref1, 1) \ +DEFINE (Bstack_ref2, 2) \ +DEFINE (Bstack_ref3, 3) \ +DEFINE (Bstack_ref4, 4) \ +DEFINE (Bstack_ref5, 5) \ +DEFINE (Bstack_ref6, 6) \ +DEFINE (Bstack_ref7, 7) \ +DEFINE (Bvarref, 010) \ +DEFINE (Bvarref1, 011) \ +DEFINE (Bvarref2, 012) \ +DEFINE (Bvarref3, 013) \ +DEFINE (Bvarref4, 014) \ +DEFINE (Bvarref5, 015) \ +DEFINE (Bvarref6, 016) \ +DEFINE (Bvarref7, 017) \ +DEFINE (Bvarset, 020) \ +DEFINE (Bvarset1, 021) \ +DEFINE (Bvarset2, 022) \ +DEFINE (Bvarset3, 023) \ +DEFINE (Bvarset4, 024) \ +DEFINE (Bvarset5, 025) \ +DEFINE (Bvarset6, 026) \ +DEFINE (Bvarset7, 027) \ +DEFINE (Bvarbind, 030) \ +DEFINE (Bvarbind1, 031) \ +DEFINE (Bvarbind2, 032) \ +DEFINE (Bvarbind3, 033) \ +DEFINE (Bvarbind4, 034) \ +DEFINE (Bvarbind5, 035) \ +DEFINE (Bvarbind6, 036) \ +DEFINE (Bvarbind7, 037) \ +DEFINE (Bcall, 040) \ +DEFINE (Bcall1, 041) \ +DEFINE (Bcall2, 042) \ +DEFINE (Bcall3, 043) \ +DEFINE (Bcall4, 044) \ +DEFINE (Bcall5, 045) \ +DEFINE (Bcall6, 046) \ +DEFINE (Bcall7, 047) \ +DEFINE (Bunbind, 050) \ +DEFINE (Bunbind1, 051) \ +DEFINE (Bunbind2, 052) \ +DEFINE (Bunbind3, 053) \ +DEFINE (Bunbind4, 054) \ +DEFINE (Bunbind5, 055) \ +DEFINE (Bunbind6, 056) \ +DEFINE (Bunbind7, 057) \ + \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ +DEFINE (Bnth, 070) \ +DEFINE (Bsymbolp, 071) \ +DEFINE (Bconsp, 072) \ +DEFINE (Bstringp, 073) \ +DEFINE (Blistp, 074) \ +DEFINE (Beq, 075) \ +DEFINE (Bmemq, 076) \ +DEFINE (Bnot, 077) \ +DEFINE (Bcar, 0100) \ +DEFINE (Bcdr, 0101) \ +DEFINE (Bcons, 0102) \ +DEFINE (Blist1, 0103) \ +DEFINE (Blist2, 0104) \ +DEFINE (Blist3, 0105) \ +DEFINE (Blist4, 0106) \ +DEFINE (Blength, 0107) \ +DEFINE (Baref, 0110) \ +DEFINE (Baset, 0111) \ +DEFINE (Bsymbol_value, 0112) \ +DEFINE (Bsymbol_function, 0113) \ +DEFINE (Bset, 0114) \ +DEFINE (Bfset, 0115) \ +DEFINE (Bget, 0116) \ +DEFINE (Bsubstring, 0117) \ +DEFINE (Bconcat2, 0120) \ +DEFINE (Bconcat3, 0121) \ +DEFINE (Bconcat4, 0122) \ +DEFINE (Bsub1, 0123) \ +DEFINE (Badd1, 0124) \ +DEFINE (Beqlsign, 0125) \ +DEFINE (Bgtr, 0126) \ +DEFINE (Blss, 0127) \ +DEFINE (Bleq, 0130) \ +DEFINE (Bgeq, 0131) \ +DEFINE (Bdiff, 0132) \ +DEFINE (Bnegate, 0133) \ +DEFINE (Bplus, 0134) \ +DEFINE (Bmax, 0135) \ +DEFINE (Bmin, 0136) \ +DEFINE (Bmult, 0137) \ + \ +DEFINE (Bpoint, 0140) \ +/* Was Bmark in v17. */ \ +DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ +DEFINE (Bgoto_char, 0142) \ +DEFINE (Binsert, 0143) \ +DEFINE (Bpoint_max, 0144) \ +DEFINE (Bpoint_min, 0145) \ +DEFINE (Bchar_after, 0146) \ +DEFINE (Bfollowing_char, 0147) \ +DEFINE (Bpreceding_char, 0150) \ +DEFINE (Bcurrent_column, 0151) \ +DEFINE (Bindent_to, 0152) \ +DEFINE (Beolp, 0154) \ +DEFINE (Beobp, 0155) \ +DEFINE (Bbolp, 0156) \ +DEFINE (Bbobp, 0157) \ +DEFINE (Bcurrent_buffer, 0160) \ +DEFINE (Bset_buffer, 0161) \ +DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ +DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bforward_char, 0165) \ +DEFINE (Bforward_word, 0166) \ +DEFINE (Bskip_chars_forward, 0167) \ +DEFINE (Bskip_chars_backward, 0170) \ +DEFINE (Bforward_line, 0171) \ +DEFINE (Bchar_syntax, 0172) \ +DEFINE (Bbuffer_substring, 0173) \ +DEFINE (Bdelete_region, 0174) \ +DEFINE (Bnarrow_to_region, 0175) \ +DEFINE (Bwiden, 0176) \ +DEFINE (Bend_of_line, 0177) \ + \ +DEFINE (Bconstant2, 0201) \ +DEFINE (Bgoto, 0202) \ +DEFINE (Bgotoifnil, 0203) \ +DEFINE (Bgotoifnonnil, 0204) \ +DEFINE (Bgotoifnilelsepop, 0205) \ +DEFINE (Bgotoifnonnilelsepop, 0206) \ +DEFINE (Breturn, 0207) \ +DEFINE (Bdiscard, 0210) \ +DEFINE (Bdup, 0211) \ + \ +DEFINE (Bsave_excursion, 0212) \ +DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Bsave_restriction, 0214) \ +DEFINE (Bcatch, 0215) \ + \ +DEFINE (Bunwind_protect, 0216) \ +DEFINE (Bcondition_case, 0217) \ +DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ + \ +DEFINE (Bset_marker, 0223) \ +DEFINE (Bmatch_beginning, 0224) \ +DEFINE (Bmatch_end, 0225) \ +DEFINE (Bupcase, 0226) \ +DEFINE (Bdowncase, 0227) \ + \ +DEFINE (Bstringeqlsign, 0230) \ +DEFINE (Bstringlss, 0231) \ +DEFINE (Bequal, 0232) \ +DEFINE (Bnthcdr, 0233) \ +DEFINE (Belt, 0234) \ +DEFINE (Bmember, 0235) \ +DEFINE (Bassq, 0236) \ +DEFINE (Bnreverse, 0237) \ +DEFINE (Bsetcar, 0240) \ +DEFINE (Bsetcdr, 0241) \ +DEFINE (Bcar_safe, 0242) \ +DEFINE (Bcdr_safe, 0243) \ +DEFINE (Bnconc, 0244) \ +DEFINE (Bquo, 0245) \ +DEFINE (Brem, 0246) \ +DEFINE (Bnumberp, 0247) \ +DEFINE (Bintegerp, 0250) \ + \ +DEFINE (BRgoto, 0252) \ +DEFINE (BRgotoifnil, 0253) \ +DEFINE (BRgotoifnonnil, 0254) \ +DEFINE (BRgotoifnilelsepop, 0255) \ +DEFINE (BRgotoifnonnilelsepop, 0256) \ + \ +DEFINE (BlistN, 0257) \ +DEFINE (BconcatN, 0260) \ +DEFINE (BinsertN, 0261) \ + \ +/* Bstack_ref is code 0. */ \ +DEFINE (Bstack_set, 0262) \ +DEFINE (Bstack_set2, 0263) \ +DEFINE (BdiscardN, 0266) \ + \ +DEFINE (Bswitch, 0267) \ + \ +DEFINE (Bconstant, 0300) + +enum byte_code_op +{ +#define DEFINE(name, value) name = value, + BYTE_CODES +#undef DEFINE + +#if BYTE_CODE_SAFE + Bscan_buffer = 0153, /* No longer generated as of v18. */ + Bset_mark = 0163, /* this loser is no longer generated as of v18 */ +#endif +}; + +#endif /* EMACS_BYTECODE_H */ diff --git a/src/lisp.h b/src/lisp.h index 8674fe11a64..04e70f592fe 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,6 +2096,8 @@ union Aligned_Lisp_Subr }; verify (GCALIGNED (union Aligned_Lisp_Subr)); +#define SUBR_MAX_ARGS 9 + INLINE bool SUBRP (Lisp_Object a) { From 64dfd59fd69d3f46e9a54ad2c88838e2bd32aac8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 21 May 2019 20:57:22 +0200 Subject: [PATCH 0004/1452] Make block_atimers unblock_atimers extern --- src/atimer.c | 33 +++++++++++++++++---------------- src/atimer.h | 2 ++ 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/atimer.c b/src/atimer.c index a7daf9dcf5b..4b0cab14530 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -65,22 +65,6 @@ enum { timerfd = -1 }; # endif #endif -/* Block/unblock SIGALRM. */ - -static void -block_atimers (sigset_t *oldset) -{ - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - pthread_sigmask (SIG_BLOCK, &blocked, oldset); -} -static void -unblock_atimers (sigset_t const *oldset) -{ - pthread_sigmask (SIG_SETMASK, oldset, 0); -} /* Function prototypes. */ @@ -165,6 +149,23 @@ start_atimer (enum atimer_type type, struct timespec timestamp, return t; } +/* Block/unblock SIGALRM. */ + +void +block_atimers (sigset_t *oldset) +{ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, oldset); +} + +void +unblock_atimers (sigset_t const *oldset) +{ + pthread_sigmask (SIG_SETMASK, oldset, 0); +} /* Cancel and free atimer TIMER. */ diff --git a/src/atimer.h b/src/atimer.h index 660d77c9392..58209168afb 100644 --- a/src/atimer.h +++ b/src/atimer.h @@ -71,6 +71,8 @@ struct atimer struct atimer *start_atimer (enum atimer_type, struct timespec, atimer_callback, void *); +void block_atimers (sigset_t *); +void unblock_atimers (sigset_t const *); void cancel_atimer (struct atimer *); void do_pending_atimers (void); void init_atimer (void); From 01442a9ac9c6e6a652b628cf18b90a7e30bff845 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 11 May 2019 21:12:21 +0200 Subject: [PATCH 0005/1452] Add native compiler comp.c --- src/Makefile.in | 2 +- src/comp.c | 1032 ++++++++++++++++++++++++++++++++++++++++ src/emacs.c | 15 + src/lisp.h | 6 + src/lread.c | 11 +- test/src/comp-tests.el | 86 ++++ 6 files changed, 1147 insertions(+), 5 deletions(-) create mode 100644 src/comp.c create mode 100644 test/src/comp-tests.el diff --git a/src/Makefile.in b/src/Makefile.in index 4a66016e976..8e3712709e5 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -416,7 +416,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 \ 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) \ diff --git a/src/comp.c b/src/comp.c new file mode 100644 index 00000000000..9713a6fd459 --- /dev/null +++ b/src/comp.c @@ -0,0 +1,1032 @@ +/* Compile byte code produced by bytecomp.el into native code. + Copyright (C) 2019 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 . */ + +#include + +#ifdef HAVE_LIBGCCJIT + +#include +#include +#include + +#include "lisp.h" +#include "buffer.h" +#include "bytecode.h" +#include "atimer.h" + +#define MAX_FUN_NAME 256 + +#define DISASS_FILE_NAME "emacs-asm.s" + +#define CHECK_STACK \ + eassert (stack >= stack_base && stack < stack_over) + +#define PUSH(obj) \ + do { \ + CHECK_STACK; \ + *stack = obj; \ + stack++; \ + } while (0) + +#define POP1 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[0] = *stack; \ + } while (0) + +#define POP2 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[1] = *stack; \ + stack--; \ + args[0] = *stack; \ + } while (0) + +#define POP3 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[2] = *stack; \ + stack--; \ + args[1] = *stack; \ + stack--; \ + args[0] = *stack; \ + } while (0) + +/* Fetch the next byte from the bytecode stream. */ + +#define FETCH (bytestr_data[pc++]) + +/* Fetch two bytes from the bytecode stream and make a 16-bit number + out of them. */ + +#define FETCH2 (op = FETCH, op + (FETCH << 8)) + +/* The compiler context */ + +typedef struct { + gcc_jit_context *ctxt; + gcc_jit_type *lisp_obj; + gcc_jit_type *int_type; + gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_block *block; /* Current basic block */ + Lisp_Object func_hash; /* f_name -> gcc_func */ +} comp_t; + +static comp_t comp; + +/* The result of one function compilation. */ + +typedef struct { + gcc_jit_result *gcc_res; + short min_args, max_args; +} comp_f_res_t; + +static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, + gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, + bool reusable); + +void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, + Lisp_Object func, bool dump_asm); + +static gcc_jit_function * +jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, + bool reusable) +{ + gcc_jit_param *param[4]; + gcc_jit_type *type[4]; + + /* If args are passed types are extracted from that otherwise assume params */ + /* are all lisp objs. */ + if (args) + for (int i = 0; i < nargs; i++) + type[i] = gcc_jit_rvalue_get_type (args[i]); + else + for (int i = 0; i < nargs; i++) + type[i] = comp.lisp_obj; + + switch (nargs) { + case 4: + param[3] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[3], + "c"); + /* Fall through */ + FALLTHROUGH; + case 3: + param[2] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[2], + "c"); + /* Fall through */ + FALLTHROUGH; + case 2: + param[1] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[1], + "b"); + /* Fall through */ + FALLTHROUGH; + case 1: + param[0] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[0], + "a"); + /* Fall through */ + FALLTHROUGH; + case 0: + break; + default: + /* Argnum not supported */ + eassert (0); + } + + gcc_jit_function *func = + gcc_jit_context_new_function(comp.ctxt, NULL, + kind, + comp.lisp_obj, + f_name, + nargs, + param, + 0); + + if (reusable) + { + Lisp_Object value; + Lisp_Object key = make_string (f_name, strlen (f_name)); + value = make_pointer_integer (XPL (func)); + + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + /* Don't want to declare the same function two times */ + eassert (i == -1); + hash_put (ht, key, value, hash); + } + + return func; +} + +static gcc_jit_lvalue * +jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +{ + Lisp_Object key = make_string (f_name, strlen (f_name)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + + if (i == -1) + { + jit_func_declare(f_name, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + true); + i = hash_lookup (ht, key, &hash); + eassert (i != -1); + } + + Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); + gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); + + gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, + NULL, + comp.lisp_obj, + "res"); + gcc_jit_block_add_assignment(comp.block, NULL, + res, + gcc_jit_context_new_call(comp.ctxt, + NULL, + func, + nargs, + args)); + return res; +} + +static comp_f_res_t +compile_f (const char *f_name, ptrdiff_t bytestr_length, + unsigned char *bytestr_data, + EMACS_INT stack_depth, Lisp_Object *vectorp, + ptrdiff_t vector_size, Lisp_Object args_template) +{ + gcc_jit_lvalue *res; + comp_f_res_t comp_res = { NULL, 0, 0 }; + ptrdiff_t pc = 0; + gcc_jit_rvalue *args[4]; + unsigned op; + + /* This is the stack we use to flat the bytecode written for push and pop + Emacs VM.*/ + gcc_jit_rvalue **stack_base, **stack, **stack_over; + stack_base = stack = + (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); + stack_over = stack_base + stack_depth; + + if (FIXNUMP (args_template)) + { + ptrdiff_t at = XFIXNUM (args_template); + bool rest = (at & 128) != 0; + int mandatory = at & 127; + ptrdiff_t nonrest = at >> 8; + + comp_res.min_args = mandatory; + + eassert (!rest); + + if (!rest && nonrest < SUBR_MAX_ARGS) + comp_res.max_args = nonrest; + } + else if (CONSP (args_template)) + /* FIXME */ + comp_res.min_args = comp_res.max_args = XFIXNUM (Flength (args_template)); + + else + eassert (SYMBOLP (args_template) && args_template == Qnil); + + + /* Current function being compiled. Return a lips obj. */ + comp.func = jit_func_declare (f_name, comp_res.max_args, NULL, + GCC_JIT_FUNCTION_EXPORTED, false); + + for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) + PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); + + comp.block = gcc_jit_function_new_block(comp.func, "foo_blk"); + + while (pc < bytestr_length) + { + op = FETCH; + printf ("pc %td\t%ud\n", pc, op); + switch (op) + { + case Bstack_ref1: + case Bstack_ref2: + case Bstack_ref3: + case Bstack_ref4: + case Bstack_ref5: + { + PUSH (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + break; + } + case Bstack_ref6: + { + PUSH (stack_base[(stack - stack_base) - FETCH - 1]); + break; + } + case Bstack_ref7: + { + PUSH (stack_base[(stack - stack_base) - FETCH2 - 1]); + break; + } + + case Bvarref7: + op = FETCH2; + goto varref; + + case Bvarref: + case Bvarref1: + case Bvarref2: + case Bvarref3: + case Bvarref4: + case Bvarref5: + op -= Bvarref; + goto varref; + + case Bvarref6: + op = FETCH; + varref: + { + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + res = jit_emit_call ("Fsymbol_value", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + } + + case Bvarset: + case Bvarset1: + case Bvarset2: + case Bvarset3: + case Bvarset4: + case Bvarset5: + op -= Bvarset; + goto varset; + + case Bvarset7: + op = FETCH2; + goto varset; + + case Bvarset6: + op = FETCH; + varset: + { + POP1; + args[1] = args[0]; + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + args[2] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + Qnil); + args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + res = jit_emit_call ("set_internal", 4, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + } + break; + + case Bvarbind: + printf("Bvarbind\n"); + break; + case Bvarbind1: + printf("Bvarbind1\n"); + break; + case Bvarbind2: + printf("Bvarbind2\n"); + break; + case Bvarbind3: + printf("Bvarbind3\n"); + break; + case Bvarbind4: + printf("Bvarbind4\n"); + break; + case Bvarbind5: + printf("Bvarbind5\n"); + break; + case Bvarbind6: + printf("Bvarbind6\n"); + break; + case Bvarbind7: + printf("Bvarbind7\n"); + break; + case Bcall: + printf("Bcall\n"); + break; + case Bcall1: + printf("Bcall1\n"); + break; + case Bcall2: + printf("Bcall2\n"); + break; + case Bcall3: + printf("Bcall3\n"); + break; + case Bcall4: + printf("Bcall4\n"); + break; + case Bcall5: + printf("Bcall5\n"); + break; + case Bcall6: + printf("Bcall6\n"); + break; + case Bcall7: + printf("Bcall7\n"); + break; + case Bunbind: + printf("Bunbind\n"); + break; + case Bunbind1: + printf("Bunbind1\n"); + break; + case Bunbind2: + printf("Bunbind2\n"); + break; + case Bunbind3: + printf("Bunbind3\n"); + break; + case Bunbind4: + printf("Bunbind4\n"); + break; + case Bunbind5: + printf("Bunbind5\n"); + break; + case Bunbind6: + printf("Bunbind6\n"); + break; + case Bunbind7: + printf("Bunbind7\n"); + break; + case Bpophandler: + printf("Bpophandler\n"); + break; + case Bpushconditioncase: + printf("Bpushconditioncase\n"); + break; + case Bpushcatch: + printf("Bpushcatch\n"); + break; + case Bnth: + printf("Bnth\n"); + break; + case Bsymbolp: + printf("Bsymbolp\n"); + break; + case Bconsp: + printf("Bconsp\n"); + break; + case Bstringp: + printf("Bstringp\n"); + break; + case Blistp: + printf("Blistp\n"); + break; + case Beq: + POP2; + res = jit_emit_call ("Feq", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + case Bmemq: + POP1; + res = jit_emit_call ("Fmemq", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + break; + case Bnot: + printf("Bnot\n"); + break; + case Bcar: + POP1; + res = jit_emit_call ("Fcar", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + case Bcdr: + POP1; + res = jit_emit_call ("Fcdr", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + case Bcons: + POP2; + res = jit_emit_call ("Fcons", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + + case BlistN: + op = FETCH; + goto make_list; + + case Blist1: + case Blist2: + case Blist3: + case Blist4: + op = op - Blist1; + make_list: + { + POP1; + args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + Qnil); + res = jit_emit_call ("Fcons", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + for (int i = 0; i < op; ++i) + { + POP2; + res = jit_emit_call ("Fcons", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + } + break; + } + + case Blength: + printf("Blength\n"); + break; + case Baref: + printf("Baref\n"); + break; + case Baset: + printf("Baset\n"); + break; + case Bsymbol_value: + printf("Bsymbol_value\n"); + break; + case Bsymbol_function: + printf("Bsymbol_function\n"); + break; + case Bset: + printf("Bset\n"); + break; + case Bfset: + printf("Bfset\n"); + break; + case Bget: + printf("Bget\n"); + break; + case Bsubstring: + printf("Bsubstring\n"); + break; + case Bconcat2: + printf("Bconcat2\n"); + break; + case Bconcat3: + printf("Bconcat3\n"); + break; + case Bconcat4: + printf("Bconcat4\n"); + break; + case Bsub1: + printf("Bsub1\n"); + break; + case Badd1: + printf("Badd1\n"); + break; + case Beqlsign: + printf("Beqlsign\n"); + break; + case Bgtr: + printf("Bgtr\n"); + break; + case Blss: + printf("Blss\n"); + break; + case Bleq: + printf("Bleq\n"); + break; + case Bgeq: + printf("Bgeq\n"); + break; + case Bdiff: + printf("Bdiff\n"); + break; + case Bnegate: + printf("Bnegate\n"); + break; + case Bplus: + printf("Bplus\n"); + break; + case Bmax: + printf("Bmax\n"); + break; + case Bmin: + printf("Bmin\n"); + break; + case Bmult: + printf("Bmult\n"); + break; + case Bpoint: + printf("Bpoint\n"); + break; + case Bsave_current_buffer: + printf("Bsave_current_buffer\n"); + break; + case Bgoto_char: + printf("Bgoto_char\n"); + break; + case Binsert: + printf("Binsert\n"); + break; + case Bpoint_max: + printf("Bpoint_max\n"); + break; + case Bpoint_min: + printf("Bpoint_min\n"); + break; + case Bchar_after: + printf("Bchar_after\n"); + break; + case Bfollowing_char: + printf("Bfollowing_char\n"); + break; + case Bpreceding_char: + printf("Bpreceding_char\n"); + break; + case Bcurrent_column: + printf("Bcurrent_column\n"); + break; + case Bindent_to: + printf("Bindent_to\n"); + break; + case Beolp: + printf("Beolp\n"); + break; + case Beobp: + printf("Beobp\n"); + break; + case Bbolp: + printf("Bbolp\n"); + break; + case Bbobp: + printf("Bbobp\n"); + break; + case Bcurrent_buffer: + printf("Bcurrent_buffer\n"); + break; + case Bset_buffer: + printf("Bset_buffer\n"); + break; + case Bsave_current_buffer_1: + printf("Bsave_current_buffer_1\n"); + break; + case Binteractive_p: + printf("Binteractive_p\n"); + break; + case Bforward_char: + printf("Bforward_char\n"); + break; + case Bforward_word: + printf("Bforward_word\n"); + break; + case Bskip_chars_forward: + printf("Bskip_chars_forward\n"); + break; + case Bskip_chars_backward: + printf("Bskip_chars_backward\n"); + break; + case Bforward_line: + printf("Bforward_line\n"); + break; + case Bchar_syntax: + printf("Bchar_syntax\n"); + break; + case Bbuffer_substring: + printf("Bbuffer_substring\n"); + break; + case Bdelete_region: + printf("Bdelete_region\n"); + break; + case Bnarrow_to_region: + printf("Bnarrow_to_region\n"); + break; + case Bwiden: + printf("Bwiden\n"); + break; + case Bend_of_line: + printf("Bend_of_line\n"); + break; + case Bconstant2: + printf("Bconstant2\n"); + goto do_constant; + break; + case Bgoto: + printf("Bgoto\n"); + break; + case Bgotoifnil: + printf("Bgotoifnil\n"); + break; + case Bgotoifnonnil: + printf("Bgotoifnonnil\n"); + break; + case Bgotoifnilelsepop: + printf("Bgotoifnilelsepop\n"); + break; + case Bgotoifnonnilelsepop: + printf("Bgotoifnonnilelsepop\n"); + break; + case Breturn: + printf("Breturn\n"); + break; + case Bdiscard: + printf("Bdiscard\n"); + break; + case Bdup: + printf("Bdup\n"); + break; + case Bsave_excursion: + printf("Bsave_excursion\n"); + break; + case Bsave_window_excursion: + printf("Bsave_window_excursion\n"); + break; + case Bsave_restriction: + printf("Bsave_restriction\n"); + break; + case Bcatch: + printf("Bcatch\n"); + break; + case Bunwind_protect: + printf("Bunwind_protect\n"); + break; + case Bcondition_case: + printf("Bcondition_case\n"); + break; + case Btemp_output_buffer_setup: + printf("Btemp_output_buffer_setup\n"); + break; + case Btemp_output_buffer_show: + printf("Btemp_output_buffer_show\n"); + break; + case Bunbind_all: + printf("Bunbind_all\n"); + break; + case Bset_marker: + printf("Bset_marker\n"); + break; + case Bmatch_beginning: + printf("Bmatch_beginning\n"); + break; + case Bmatch_end: + printf("Bmatch_end\n"); + break; + case Bupcase: + printf("Bupcase\n"); + break; + case Bdowncase: + printf("Bdowncase\n"); + break; + case Bstringeqlsign: + printf("Bstringeqlsign\n"); + break; + case Bstringlss: + printf("Bstringlss\n"); + break; + case Bequal: + printf("Bequal\n"); + break; + case Bnthcdr: + printf("Bnthcdr\n"); + break; + case Belt: + printf("Belt\n"); + break; + case Bmember: + printf("Bmember\n"); + break; + case Bassq: + printf("Bassq\n"); + break; + case Bnreverse: + printf("Bnreverse\n"); + break; + case Bsetcar: + printf("Bsetcar\n"); + break; + case Bsetcdr: + printf("Bsetcdr\n"); + break; + case Bcar_safe: + printf("Bcar_safe\n"); + break; + case Bcdr_safe: + printf("Bcdr_safe\n"); + break; + case Bnconc: + printf("Bnconc\n"); + break; + case Bquo: + printf("Bquo\n"); + break; + case Brem: + printf("Brem\n"); + break; + case Bnumberp: + printf("Bnumberp\n"); + break; + case Bintegerp: + printf("Bintegerp\n"); + break; + case BRgoto: + printf("BRgoto\n"); + break; + case BRgotoifnil: + printf("BRgotoifnil\n"); + break; + case BRgotoifnonnil: + printf("BRgotoifnonnil\n"); + break; + case BRgotoifnilelsepop: + printf("BRgotoifnilelsepop\n"); + break; + case BRgotoifnonnilelsepop: + printf("BRgotoifnonnilelsepop\n"); + break; + case BconcatN: + printf("BconcatN\n"); + break; + case BinsertN: + printf("BinsertN\n"); + break; + case Bstack_set: + printf("Bstack_set\n"); + break; + case Bstack_set2: + printf("Bstack_set2\n"); + break; + case BdiscardN: + printf("BdiscardN\n"); + break; + case Bswitch: + printf("Bswitch\n"); + /* The cases of Bswitch that we handle (which in theory is + all of them) are done in Bconstant, below. This is done + due to a design issue with Bswitch -- it should have + taken a constant pool index inline, but instead looks for + a constant on the stack. */ + goto fail; + break; + default: + case Bconstant: + printf("Bconstant "); + { + if (op < Bconstant || op > Bconstant + vector_size) + goto fail; + + op -= Bconstant; + do_constant: + + /* See the Bswitch case for commentary. */ + if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) + { + gcc_jit_rvalue *c = + gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + PUSH (c); + Fprint(vectorp[op], Qnil); + break; + } + + /* We're compiling Bswitch instead. */ + ++pc; + break; + } + } + } + + stack--; + gcc_jit_block_end_with_return(comp.block, + NULL, + *stack); + comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); + + goto exit; + + fail: + error ("Something went wrong"); + + exit: + xfree (stack_base); + return comp_res; +} + +void +emacs_native_compile (const char *lisp_f_name, const char *c_f_name, + Lisp_Object func, bool dump_asm) +{ + Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); + CHECK_STRING (bytestr); + + if (STRING_MULTIBYTE (bytestr)) + /* BYTESTR must have been produced by Emacs 20.2 or the earlier + because they produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte while raw 8-bit + characters converted to multibyte form. Thus, now we must + convert them back to the originally intended unibyte form. */ + bytestr = Fstring_as_unibyte (bytestr); + + ptrdiff_t bytestr_length = SBYTES (bytestr); + + Lisp_Object vector = AREF (func, COMPILED_CONSTANTS); + CHECK_VECTOR (vector); + Lisp_Object *vectorp = XVECTOR (vector)->contents; + + Lisp_Object maxdepth = AREF (func, COMPILED_STACK_DEPTH); + CHECK_FIXNAT (maxdepth); + + /* Gcc doesn't like being interrupted. */ + sigset_t oldset; + block_atimers (&oldset); + + comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), + XFIXNAT (maxdepth) + 1, + vectorp, ASIZE (vector), + AREF (func, COMPILED_ARGLIST)); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); + x->s.min_args = comp_res.min_args; + x->s.max_args = comp_res.max_args; + x->s.symbol_name = lisp_f_name; + defsubr(x); + + if (dump_asm) + { + gcc_jit_context_compile_to_file(comp.ctxt, + GCC_JIT_OUTPUT_KIND_ASSEMBLER, + DISASS_FILE_NAME); + } + unblock_atimers (&oldset); +} + +DEFUN ("native-compile", Fnative_compile, Snative_compile, + 1, 2, 0, + doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ + (Lisp_Object func, Lisp_Object disassemble) +{ + static char c_f_name[MAX_FUN_NAME]; + char *lisp_f_name; + + if (!SYMBOLP (func)) + error ("Not a symbol."); + + lisp_f_name = (char *) SDATA (SYMBOL_NAME (func)); + + int res = snprintf (c_f_name, MAX_FUN_NAME, "Fnative_comp_%s", lisp_f_name); + + if (res >= MAX_FUN_NAME) + error ("Function name too long"); + + /* FIXME how many other characters are not allowed in C? + This will introduce name clashs too. */ + for (int i; i < strlen(c_f_name); i++) + if (c_f_name[i] == '-') + c_f_name[i] = '_'; + + func = indirect_function (func); + if (!COMPILEDP (func)) + error ("Not a byte-compiled function"); + + emacs_native_compile (lisp_f_name, c_f_name, func, disassemble != Qnil); + + if (disassemble) + { + FILE *fd; + Lisp_Object str; + + if ((fd = fopen (DISASS_FILE_NAME, "r"))) + { + fseek (fd , 0L, SEEK_END); + long int size = ftell (fd); + fseek (fd , 0L, SEEK_SET); + char *buffer = xmalloc (size + 1); + ptrdiff_t nread = fread (buffer, 1, size, fd); + if (nread > 0) + { + size = nread; + buffer[size] = '\0'; + str = make_string (buffer, size); + fclose (fd); + } + else + str = empty_unibyte_string; + xfree (buffer); + return str; + } + else + { + error ("disassemble file could not be found"); + } + } + + return Qnil; +} + +void +init_comp (void) +{ + comp.ctxt = gcc_jit_context_acquire(); + +#if EMACS_INT_MAX <= LONG_MAX + /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ + comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); +#else + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); +#endif + + comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + + /* gcc_jit_context_set_bool_option(comp.ctxt, */ + /* GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, */ + /* 1); */ + + gcc_jit_context_set_bool_option(comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); +} + +void +release_comp (void) +{ + if (comp.ctxt) + gcc_jit_context_release(comp.ctxt); +} + +void +syms_of_comp (void) +{ + defsubr (&Snative_compile); + comp.func_hash = Qnil; + staticpro (&comp.func_hash); +} + +#endif /* HAVE_LIBJIT */ diff --git a/src/emacs.c b/src/emacs.c index 81703b4660a..db6d54dff43 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1598,6 +1598,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif +#ifdef HAVE_LIBGCCJIT + if (!initialized) + syms_of_comp (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1773,6 +1778,12 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem xputenv ("LANG=C"); #endif + /* This is here because init_buffer can already call Lisp. */ +#ifdef HAVE_LIBGCCJIT + if (initialized) + init_comp(); +#endif + /* Init buffer storage and default directory of main buffer. */ init_buffer (); @@ -2389,6 +2400,10 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } +#ifdef HAVE_LIBGCCJIT + release_comp(); +#endif + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/lisp.h b/src/lisp.h index 04e70f592fe..5a563069df5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4743,6 +4743,12 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); +/* Defined in comp.c. */ +#ifdef HAVE_LIBGCCJIT +extern void init_comp (void); +extern void release_comp (void); +extern void syms_of_comp (void); +#endif /* HAVE_LIBGCCJIT */ #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ diff --git a/src/lread.c b/src/lread.c index 290b3d3d64e..bedb3d57cb5 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4174,13 +4174,16 @@ intern_c_string_1 (const char *str, ptrdiff_t len) { Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); + Lisp_Object string; 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); + 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; } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el new file mode 100644 index 00000000000..5847d5cf85c --- /dev/null +++ b/test/src/comp-tests.el @@ -0,0 +1,86 @@ +;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; 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 . + +;;; Commentary: + +;; Unit tests for src/comp.c. + +;;; Code: + +(require 'ert) + +(setq garbage-collection-messages t) + +(defvar comp-tests-var1 3) + +(ert-deftest comp-tests-varref () + "Testing cons car cdr." + (defun comp-tests-varref-f () + comp-tests-var1) + + (byte-compile #'comp-tests-varref-f) + (native-compile #'comp-tests-varref-f) + + (should (= (comp-tests-varref-f) 3))) + +(ert-deftest comp-tests-list () + "Testing cons car cdr." + (defun comp-tests-list-f () + (list 1 2 3)) + + (byte-compile #'comp-tests-list-f) + (native-compile #'comp-tests-list-f) + + (should (equal (comp-tests-list-f) '(1 2 3)))) + +(ert-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (defun comp-tests-cons-car-f () + (car (cons 1 2))) + (byte-compile #'comp-tests-cons-car-f) + (native-compile #'comp-tests-cons-car-f) + + (defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + (byte-compile #'comp-tests-cons-cdr-f) + (native-compile #'comp-tests-cons-cdr-f) + + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(ert-deftest comp-tests-varset () + "Testing varset." + (defun comp-tests-varset-f () + (setq comp-tests-var1 55)) + (byte-compile #'comp-tests-varset-f) + (native-compile #'comp-tests-varset-f) + (comp-tests-varset-f) + + (should (= comp-tests-var1 55))) + +(ert-deftest comp-tests-gc () + "Try to do some longer computation to let the gc kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) + + (should (= (comp-tests-cons-cdr-f 3) 3))) + +;;; comp-tests.el ends here From 5238cd1e6a9b3c310743fdb4497f8f16d965367e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 21 May 2019 21:24:34 +0200 Subject: [PATCH 0006/1452] add varbind support --- src/comp.c | 48 ++++++++++++++++++++++++++---------------------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9713a6fd459..5bc2c8fa4e8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -353,30 +353,34 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Bvarbind: - printf("Bvarbind\n"); - break; - case Bvarbind1: - printf("Bvarbind1\n"); - break; - case Bvarbind2: - printf("Bvarbind2\n"); - break; - case Bvarbind3: - printf("Bvarbind3\n"); - break; - case Bvarbind4: - printf("Bvarbind4\n"); - break; - case Bvarbind5: - printf("Bvarbind5\n"); - break; case Bvarbind6: - printf("Bvarbind6\n"); - break; + op = FETCH; + goto varbind; + case Bvarbind7: - printf("Bvarbind7\n"); - break; + op = FETCH2; + goto varbind; + + case Bvarbind: + case Bvarbind1: + case Bvarbind2: + case Bvarbind3: + case Bvarbind4: + case Bvarbind5: + op -= Bvarbind; + varbind: + { + POP1; + args[1] = args[0]; + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + + res = jit_emit_call ("specbind", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + } + case Bcall: printf("Bcall\n"); break; From 54e18532e7e731ec556e4039d677592215a78ac3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 21 May 2019 22:29:46 +0200 Subject: [PATCH 0007/1452] add funcall --- src/comp.c | 212 ++++++++++++++++++++++++++++++++++------- test/src/comp-tests.el | 11 +++ 2 files changed, 189 insertions(+), 34 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5bc2c8fa4e8..2835a4ad69b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -29,8 +29,14 @@ along with GNU Emacs. If not, see . */ #include "bytecode.h" #include "atimer.h" +#define COMP_DEBUG 0 + #define MAX_FUN_NAME 256 +/* Max number of args we are able to handle while emitting function calls. */ + +#define MAX_ARGS 16 + #define DISASS_FILE_NAME "emacs-asm.s" #define CHECK_STACK \ @@ -83,15 +89,22 @@ along with GNU Emacs. If not, see . */ typedef struct { gcc_jit_context *ctxt; - gcc_jit_type *lisp_obj; + gcc_jit_type *lisp_obj_type; gcc_jit_type *int_type; + gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_function *Ffuncall; /* Current function being compiled */ + gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_block *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; static comp_t comp; +Lisp_Object scratch_call_area[MAX_ARGS]; + +FILE *logfile; + /* The result of one function compilation. */ typedef struct { @@ -99,6 +112,9 @@ typedef struct { short min_args, max_args; } comp_f_res_t; +INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, + gcc_jit_rvalue *args[]); + static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, @@ -107,10 +123,26 @@ static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, bool dump_asm); +/* Pop form the main evaluation stack and place the elements in args in reversed + order. */ + +INLINE static void +pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) +{ + gcc_jit_rvalue **stack = *stack_ref; + + while (n--) + { + stack--; + args[n] = *stack; + } + + *stack_ref = stack; +} + static gcc_jit_function * jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, - bool reusable) + enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; gcc_jit_type *type[4]; @@ -122,7 +154,7 @@ jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, type[i] = gcc_jit_rvalue_get_type (args[i]); else for (int i = 0; i < nargs; i++) - type[i] = comp.lisp_obj; + type[i] = comp.lisp_obj_type; switch (nargs) { case 4: @@ -163,7 +195,7 @@ jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, gcc_jit_function *func = gcc_jit_context_new_function(comp.ctxt, NULL, kind, - comp.lisp_obj, + comp.lisp_obj_type, f_name, nargs, param, @@ -207,7 +239,7 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, NULL, - comp.lisp_obj, + comp.lisp_obj_type, "res"); gcc_jit_block_add_assignment(comp.block, NULL, res, @@ -219,6 +251,64 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return res; } +static gcc_jit_lvalue * +jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) +{ + + /* Here we set all the pointers into the scratch call area. */ + /* TODO: distinguish primitive for faster call convention. */ + + /* + Lisp_Object *p; + p = scratch_call_area; + + p[0] = 0x...; + . + . + . + p[n] = 0x...; + */ + + gcc_jit_lvalue *p = + gcc_jit_function_new_local(comp.func, + NULL, + gcc_jit_type_get_pointer (comp.lisp_obj_type), + "p"); + + gcc_jit_block_add_assignment(comp.block, NULL, + p, + comp.scratch); + + for (int i = 0; i < nargs; i++) { + gcc_jit_rvalue *idx = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + gcc_jit_context_get_type(comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT), + i); + gcc_jit_block_add_assignment (comp.block, NULL, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue(p), + idx), + args[i + 1]); + } + + args[1] = comp.scratch; + + gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, + NULL, + comp.lisp_obj, + "res"); + gcc_jit_block_add_assignment(comp.block, NULL, + res, + gcc_jit_context_new_call(comp.ctxt, + NULL, + comp.Ffuncall, + 2, + args)); + return res; +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -381,30 +471,34 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bcall: - printf("Bcall\n"); - break; - case Bcall1: - printf("Bcall1\n"); - break; - case Bcall2: - printf("Bcall2\n"); - break; - case Bcall3: - printf("Bcall3\n"); - break; - case Bcall4: - printf("Bcall4\n"); - break; - case Bcall5: - printf("Bcall5\n"); - break; case Bcall6: - printf("Bcall6\n"); - break; + op = FETCH; + goto docall; + case Bcall7: - printf("Bcall7\n"); - break; + op = FETCH2; + goto docall; + + case Bcall: + case Bcall1: + case Bcall2: + case Bcall3: + case Bcall4: + case Bcall5: + op -= Bcall; + docall: + { + ptrdiff_t nargs = op + 1; + + args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + nargs); + pop (nargs, &stack, &args[1]); + + res = jit_emit_Ffuncall (nargs, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + } case Bunbind: printf("Bunbind\n"); break; @@ -916,6 +1010,7 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); + eassert (x->s.function.a0); x->s.min_args = comp_res.min_args; x->s.max_args = comp_res.max_args; x->s.symbol_name = lisp_f_name; @@ -1007,15 +1102,61 @@ init_comp (void) #endif comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + + enum gcc_jit_types ptrdiff_t_gcc; + if (sizeof (ptrdiff_t) == sizeof (int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_INT; + else if (sizeof (ptrdiff_t) == sizeof (long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; + else if (sizeof (ptrdiff_t) == sizeof (long long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; + else + eassert ("ptrdiff_t size not handled."); + + comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + + gcc_jit_param *funcall_param[2] = { + gcc_jit_context_new_param(comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param(comp.ctxt, + NULL, + gcc_jit_type_get_pointer (comp.lisp_obj), + "args") }; + + comp.Ffuncall = + gcc_jit_context_new_function(comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.lisp_obj, + "Ffuncall", + 2, + funcall_param, + 0); + + comp.scratch = + gcc_jit_lvalue_get_address( + gcc_jit_context_new_global (comp.ctxt, NULL, + GCC_JIT_GLOBAL_IMPORTED, + comp.lisp_obj, + "scratch_call_area"), + NULL); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - /* gcc_jit_context_set_bool_option(comp.ctxt, */ - /* GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, */ - /* 1); */ + if (COMP_DEBUG) { + logfile = fopen ("libjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + } - gcc_jit_context_set_bool_option(comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); } void @@ -1023,6 +1164,9 @@ release_comp (void) { if (comp.ctxt) gcc_jit_context_release(comp.ctxt); + + if (COMP_DEBUG) + fclose (logfile); } void diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 5847d5cf85c..313f6906cda 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -76,6 +76,17 @@ (should (= comp-tests-var1 55))) +(ert-deftest comp-tests-ffuncall () + "Testing varset." + (defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + (defun comp-tests-ffuncall-caller-f () + (comp-tests-ffuncall-callee-f 1 2 3)) + (byte-compile #'comp-tests-ffuncall-caller-f) + (native-compile #'comp-tests-ffuncall-caller-f) + + (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 25127da57f5de6ca42c90206f1bb7de0efb41ea0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 10:28:21 +0200 Subject: [PATCH 0008/1452] rename type --- src/comp.c | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2835a4ad69b..315f74d9674 100644 --- a/src/comp.c +++ b/src/comp.c @@ -297,7 +297,7 @@ jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, NULL, - comp.lisp_obj, + comp.lisp_obj_type, "res"); gcc_jit_block_add_assignment(comp.block, NULL, res, @@ -403,7 +403,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, varref: { args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); res = jit_emit_call ("Fsymbol_value", 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); @@ -430,10 +430,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = args[0]; args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); args[2] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, Qnil); args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -460,12 +460,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - POP1; - args[1] = args[0]; args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); - + pop (1, &stack, &args[1]); res = jit_emit_call ("specbind", 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -590,7 +588,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, Qnil); res = jit_emit_call ("Fcons", 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); @@ -943,7 +941,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { gcc_jit_rvalue *c = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); PUSH (c); Fprint(vectorp[op], Qnil); @@ -1095,10 +1093,10 @@ init_comp (void) #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); #else /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); #endif comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); @@ -1122,13 +1120,13 @@ init_comp (void) "nargs"), gcc_jit_context_new_param(comp.ctxt, NULL, - gcc_jit_type_get_pointer (comp.lisp_obj), + gcc_jit_type_get_pointer (comp.lisp_obj_type), "args") }; comp.Ffuncall = gcc_jit_context_new_function(comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED, - comp.lisp_obj, + comp.lisp_obj_type, "Ffuncall", 2, funcall_param, @@ -1138,7 +1136,7 @@ init_comp (void) gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj, + comp.lisp_obj_type, "scratch_call_area"), NULL); From 1f2529df7d4663597d6ac72ac001def4cd049c1b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 10:45:14 +0200 Subject: [PATCH 0009/1452] add Bunbind --- src/comp.c | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index 315f74d9674..e7a8b9b0e9f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -497,29 +497,30 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } - case Bunbind: - printf("Bunbind\n"); - break; - case Bunbind1: - printf("Bunbind1\n"); - break; - case Bunbind2: - printf("Bunbind2\n"); - break; - case Bunbind3: - printf("Bunbind3\n"); - break; - case Bunbind4: - printf("Bunbind4\n"); - break; - case Bunbind5: - printf("Bunbind5\n"); - break; + case Bunbind6: - printf("Bunbind6\n"); - break; + op = FETCH; + goto dounbind; + case Bunbind7: - printf("Bunbind7\n"); + op = FETCH2; + goto dounbind; + + case Bunbind: + case Bunbind1: + case Bunbind2: + case Bunbind3: + case Bunbind4: + case Bunbind5: + op -= Bunbind; + dounbind: + { + args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + op); + + res = jit_emit_call ("unbind_n", 1, args); + } break; case Bpophandler: printf("Bpophandler\n"); From b21539f6083bb7be6ce3b7d7701b270bc0bf384b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 12:24:44 +0200 Subject: [PATCH 0010/1452] generalize lisp call ret type --- src/comp.c | 40 ++++++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index e7a8b9b0e9f..53cb54cba86 100644 --- a/src/comp.c +++ b/src/comp.c @@ -115,7 +115,9 @@ typedef struct { INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]); -static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, +static gcc_jit_function *jit_func_declare (const char *f_name, + gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable); @@ -141,7 +143,8 @@ pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) } static gcc_jit_function * -jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, +jit_func_declare (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; @@ -219,7 +222,8 @@ jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, } static gcc_jit_lvalue * -jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, + gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); EMACS_UINT hash = 0; @@ -228,7 +232,7 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) if (i == -1) { - jit_func_declare(f_name, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + jit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); @@ -239,7 +243,7 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, NULL, - comp.lisp_obj_type, + ret_type, "res"); gcc_jit_block_add_assignment(comp.block, NULL, res, @@ -351,8 +355,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. Return a lips obj. */ - comp.func = jit_func_declare (f_name, comp_res.max_args, NULL, - GCC_JIT_FUNCTION_EXPORTED, false); + comp.func = jit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); @@ -405,7 +409,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - res = jit_emit_call ("Fsymbol_value", 1, args); + res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -438,7 +442,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = jit_emit_call ("set_internal", 4, args); + res = jit_emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; @@ -464,7 +468,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); pop (1, &stack, &args[1]); - res = jit_emit_call ("specbind", 2, args); + res = jit_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -519,7 +523,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - res = jit_emit_call ("unbind_n", 1, args); + res = jit_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -548,12 +552,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Beq: POP2; - res = jit_emit_call ("Feq", 2, args); + res = jit_emit_call ("Feq", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Bmemq: POP1; - res = jit_emit_call ("Fmemq", 1, args); + res = jit_emit_call ("Fmemq", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; break; @@ -562,17 +566,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bcar: POP1; - res = jit_emit_call ("Fcar", 1, args); + res = jit_emit_call ("Fcar", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Bcdr: POP1; - res = jit_emit_call ("Fcdr", 1, args); + res = jit_emit_call ("Fcdr", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Bcons: POP2; - res = jit_emit_call ("Fcons", 2, args); + res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -591,12 +595,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, Qnil); - res = jit_emit_call ("Fcons", 2, args); + res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); for (int i = 0; i < op; ++i) { POP2; - res = jit_emit_call ("Fcons", 2, args); + res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; From f4d2f75a0782c53bfb09b70bc75de3c974ae5002 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 13:07:11 +0200 Subject: [PATCH 0011/1452] add void ptr --- src/comp.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/comp.c b/src/comp.c index 53cb54cba86..657fb2630ed 100644 --- a/src/comp.c +++ b/src/comp.c @@ -91,6 +91,7 @@ typedef struct { gcc_jit_context *ctxt; gcc_jit_type *lisp_obj_type; gcc_jit_type *int_type; + gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_function *Ffuncall; /* Current function being compiled */ @@ -1105,6 +1106,8 @@ init_comp (void) #endif comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + comp.void_ptr_type = + gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) From 5a9d4d67043e86831df9c8b3dcb398c45b01bb06 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 14:01:45 +0200 Subject: [PATCH 0012/1452] add Blength --- src/comp.c | 4 +++- test/src/comp-tests.el | 9 +++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 657fb2630ed..198343c057c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -608,7 +608,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } case Blength: - printf("Blength\n"); + POP1; + res = jit_emit_call ("Flength", comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Baref: printf("Baref\n"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 313f6906cda..32d5b50e13d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -76,6 +76,15 @@ (should (= comp-tests-var1 55))) +(ert-deftest comp-tests-length () + "Testing length." + (defun comp-tests-length-f () + (length '(1 2 3))) + (byte-compile #'comp-tests-length-f) + (native-compile #'comp-tests-length-f) + + (should (= (comp-tests-length-f) 3))) + (ert-deftest comp-tests-ffuncall () "Testing varset." (defun comp-tests-ffuncall-callee-f (x y z) From 2b48e5f979610de9c92df24d7cc6c47b6d8d83da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 14:10:09 +0200 Subject: [PATCH 0013/1452] Baref --- src/comp.c | 6 +++++- test/src/comp-tests.el | 9 +++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 198343c057c..bafb980dc69 100644 --- a/src/comp.c +++ b/src/comp.c @@ -612,9 +612,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, res = jit_emit_call ("Flength", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Baref: - printf("Baref\n"); + POP2; + res = jit_emit_call ("Faref", comp.lisp_obj_type, 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Baset: printf("Baset\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 32d5b50e13d..be131f7de76 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -85,6 +85,15 @@ (should (= (comp-tests-length-f) 3))) +(ert-deftest comp-tests-aref () + "Testing aref." + (defun comp-tests-aref-f () + (aref [1 2 3] 2)) + (byte-compile #'comp-tests-aref-f) + (native-compile #'comp-tests-aref-f) + + (should (= (comp-tests-aref-f) 3))) + (ert-deftest comp-tests-ffuncall () "Testing varset." (defun comp-tests-ffuncall-callee-f (x y z) From 770e52e7001ccdd309a47cbf8b8c9862bfd44ab5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 14:48:24 +0200 Subject: [PATCH 0014/1452] add discard and dup --- src/comp.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index bafb980dc69..5f250c81432 100644 --- a/src/comp.c +++ b/src/comp.c @@ -85,6 +85,10 @@ along with GNU Emacs. If not, see . */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) +/* Discard n values from the stack. */ + +#define DISCARD(n) (stack -= (n)) + /* The compiler context */ typedef struct { @@ -800,12 +804,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Breturn: printf("Breturn\n"); break; + case Bdiscard: - printf("Bdiscard\n"); + DISCARD (1); break; + case Bdup: - printf("Bdup\n"); + PUSH (*(stack - 1)); break; + case Bsave_excursion: printf("Bsave_excursion\n"); break; From bebd14acc1f646c79702fca4f7081df30a49a66c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 14:48:55 +0200 Subject: [PATCH 0015/1452] add aset --- src/comp.c | 5 ++++- test/src/comp-tests.el | 16 +++++++++------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5f250c81432..2e7ef4f077a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -624,8 +624,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Baset: - printf("Baset\n"); + POP3; + res = jit_emit_call ("Faset", comp.lisp_obj_type, 3, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Bsymbol_value: printf("Bsymbol_value\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index be131f7de76..769cd086b5a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -85,14 +85,16 @@ (should (= (comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref () - "Testing aref." - (defun comp-tests-aref-f () - (aref [1 2 3] 2)) - (byte-compile #'comp-tests-aref-f) - (native-compile #'comp-tests-aref-f) +(ert-deftest comp-tests-aref-aset () + "Testing aref and aset." + (defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (aset vec 2 100) + (aref vec 2))) + (byte-compile #'comp-tests-aref-aset-f) + (native-compile #'comp-tests-aref-aset-f) - (should (= (comp-tests-aref-f) 3))) + (should (= (comp-tests-aref-aset-f) 100))) (ert-deftest comp-tests-ffuncall () "Testing varset." From 17807af213da9eb08507d47dff142a1f8672b4e7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 15:00:34 +0200 Subject: [PATCH 0016/1452] add symbol-value --- src/comp.c | 5 ++++- test/src/comp-tests.el | 11 +++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 2e7ef4f077a..33528f98004 100644 --- a/src/comp.c +++ b/src/comp.c @@ -630,8 +630,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsymbol_value: - printf("Bsymbol_value\n"); + POP1; + res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Bsymbol_function: printf("Bsymbol_function\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 769cd086b5a..36344d361fc 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -96,6 +96,17 @@ (should (= (comp-tests-aref-aset-f) 100))) +(ert-deftest comp-tests-symbol-value () + "Testing aref and aset." + (defvar comp-tests-var2 3) + (defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + (byte-compile #'comp-tests-symbol-value-f) + (native-compile #'comp-tests-symbol-value-f) + + (should (= (comp-tests-symbol-value-f) 3))) + + (ert-deftest comp-tests-ffuncall () "Testing varset." (defun comp-tests-ffuncall-callee-f (x y z) From f42b2b0143f5f6e6fd9741b482cd98785feb95da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 15:43:00 +0200 Subject: [PATCH 0017/1452] introduce CASE_CALL_NARGS macro and add various ops symbol_function set fset fget fget Bsubstring --- src/comp.c | 94 +++++++++++++++++------------------------------------- 1 file changed, 30 insertions(+), 64 deletions(-) diff --git a/src/comp.c b/src/comp.c index 33528f98004..07629fa00b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -89,6 +89,18 @@ along with GNU Emacs. If not, see . */ #define DISCARD(n) (stack -= (n)) +#define STR(s) #s + +/* With most of the ops we need to do the same stuff so this save some + typing. */ + +#define CASE_CALL_NARGS(name, nargs) \ + case B##name: \ + POP##nargs; \ + res = jit_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + break + /* The compiler context */ typedef struct { @@ -555,35 +567,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Blistp: printf("Blistp\n"); break; - case Beq: - POP2; - res = jit_emit_call ("Feq", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - case Bmemq: - POP1; - res = jit_emit_call ("Fmemq", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - break; + + CASE_CALL_NARGS (eq, 2); + CASE_CALL_NARGS (memq, 1); + case Bnot: printf("Bnot\n"); break; - case Bcar: - POP1; - res = jit_emit_call ("Fcar", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - case Bcdr: - POP1; - res = jit_emit_call ("Fcdr", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - case Bcons: - POP2; - res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; + + CASE_CALL_NARGS (car, 1); + CASE_CALL_NARGS (cdr, 1); + CASE_CALL_NARGS (cons, 2); case BlistN: op = FETCH; @@ -611,45 +605,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Blength: - POP1; - res = jit_emit_call ("Flength", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; + CASE_CALL_NARGS (length, 1); + CASE_CALL_NARGS (aref, 2); + CASE_CALL_NARGS (aset, 3); + CASE_CALL_NARGS (symbol_value, 1); + CASE_CALL_NARGS (symbol_function, 1); + CASE_CALL_NARGS (set, 2); + CASE_CALL_NARGS (fset, 2); + CASE_CALL_NARGS (fget, 2); + CASE_CALL_NARGS (fget, 2); + CASE_CALL_NARGS (Bsubstring, 3); - case Baref: - POP2; - res = jit_emit_call ("Faref", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - - case Baset: - POP3; - res = jit_emit_call ("Faset", comp.lisp_obj_type, 3, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - - case Bsymbol_value: - POP1; - res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - - case Bsymbol_function: - printf("Bsymbol_function\n"); - break; - case Bset: - printf("Bset\n"); - break; - case Bfset: - printf("Bfset\n"); - break; - case Bget: - printf("Bget\n"); - break; - case Bsubstring: - printf("Bsubstring\n"); - break; case Bconcat2: printf("Bconcat2\n"); break; From 38a5a36a17578a5e06ab18986ce6dae68938e1be Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 15:53:09 +0200 Subject: [PATCH 0018/1452] some more ops --- src/comp.c | 31 ++++++++----------------------- 1 file changed, 8 insertions(+), 23 deletions(-) diff --git a/src/comp.c b/src/comp.c index 07629fa00b7..eecfd5121ca 100644 --- a/src/comp.c +++ b/src/comp.c @@ -552,29 +552,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpushcatch: printf("Bpushcatch\n"); break; - case Bnth: - printf("Bnth\n"); - break; - case Bsymbolp: - printf("Bsymbolp\n"); - break; - case Bconsp: - printf("Bconsp\n"); - break; - case Bstringp: - printf("Bstringp\n"); - break; - case Blistp: - printf("Blistp\n"); - break; + CASE_CALL_NARGS (nth, 2); + CASE_CALL_NARGS (symbolp, 1); + CASE_CALL_NARGS (consp, 1); + CASE_CALL_NARGS (stringp, 1); + CASE_CALL_NARGS (listp, 1); CASE_CALL_NARGS (eq, 2); CASE_CALL_NARGS (memq, 1); - - case Bnot: - printf("Bnot\n"); - break; - + CASE_CALL_NARGS (not, 1); CASE_CALL_NARGS (car, 1); CASE_CALL_NARGS (cdr, 1); CASE_CALL_NARGS (cons, 2); @@ -612,9 +598,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (symbol_function, 1); CASE_CALL_NARGS (set, 2); CASE_CALL_NARGS (fset, 2); - CASE_CALL_NARGS (fget, 2); - CASE_CALL_NARGS (fget, 2); - CASE_CALL_NARGS (Bsubstring, 3); + CASE_CALL_NARGS (get, 2); + CASE_CALL_NARGS (substring, 3); case Bconcat2: printf("Bconcat2\n"); From 28cd3abbdf24660d8c3587ee983037f82058b87c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 16:05:41 +0200 Subject: [PATCH 0019/1452] rationalize jit_emit_Ffuncall --- src/comp.c | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index eecfd5121ca..d8a5545d6ee 100644 --- a/src/comp.c +++ b/src/comp.c @@ -275,15 +275,15 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, static gcc_jit_lvalue * jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) { - /* Here we set all the pointers into the scratch call area. */ - /* TODO: distinguish primitive for faster call convention. */ + /* TODO: distinguish primitives for faster calling convention. */ /* Lisp_Object *p; p = scratch_call_area; - p[0] = 0x...; + p[0] = nargs; + p[1] = 0x...; . . . @@ -311,9 +311,12 @@ jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) NULL, gcc_jit_lvalue_as_rvalue(p), idx), - args[i + 1]); + args[i]); } + args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + nargs); args[1] = comp.scratch; gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, @@ -508,12 +511,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, docall: { ptrdiff_t nargs = op + 1; - - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs); - pop (nargs, &stack, &args[1]); - + pop (nargs, &stack, args); res = jit_emit_Ffuncall (nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; From 6ce8092a01519acd2afe29a68b11809280677ad7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 16:08:52 +0200 Subject: [PATCH 0020/1452] add jit_emit_callN --- src/comp.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index d8a5545d6ee..feec3c965e0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -273,7 +273,8 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) +jit_emit_callN (gcc_jit_function *func, unsigned nargs, + gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -327,7 +328,7 @@ jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) res, gcc_jit_context_new_call(comp.ctxt, NULL, - comp.Ffuncall, + func, 2, args)); return res; @@ -512,7 +513,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = jit_emit_Ffuncall (nargs, args); + res = jit_emit_callN (comp.Ffuncall, nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } From 2a5c81a5c92d15e8db471d16f3a014a338f9c271 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 16:32:25 +0200 Subject: [PATCH 0021/1452] store ffuncall with all other functions --- src/comp.c | 38 +++----------------------------------- 1 file changed, 3 insertions(+), 35 deletions(-) diff --git a/src/comp.c b/src/comp.c index feec3c965e0..2e5f3342cbd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -110,7 +110,6 @@ typedef struct { gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ - gcc_jit_function *Ffuncall; /* Current function being compiled */ gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_block *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ @@ -273,8 +272,7 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -jit_emit_callN (gcc_jit_function *func, unsigned nargs, - gcc_jit_rvalue **args) +jit_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -320,18 +318,7 @@ jit_emit_callN (gcc_jit_function *func, unsigned nargs, nargs); args[1] = comp.scratch; - gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, - NULL, - comp.lisp_obj_type, - "res"); - gcc_jit_block_add_assignment(comp.block, NULL, - res, - gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - 2, - args)); - return res; + return jit_emit_call (f_name, comp.lisp_obj_type, 2, args); } static comp_f_res_t @@ -513,7 +500,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = jit_emit_callN (comp.Ffuncall, nargs, args); + res = jit_emit_callN ("Ffuncall", nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -1090,25 +1077,6 @@ init_comp (void) comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); - gcc_jit_param *funcall_param[2] = { - gcc_jit_context_new_param(comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param(comp.ctxt, - NULL, - gcc_jit_type_get_pointer (comp.lisp_obj_type), - "args") }; - - comp.Ffuncall = - gcc_jit_context_new_function(comp.ctxt, NULL, - GCC_JIT_FUNCTION_IMPORTED, - comp.lisp_obj_type, - "Ffuncall", - 2, - funcall_param, - 0); - comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, From a5524504164ed9077984b90ecf5067d1e8bcbdb2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 16:57:55 +0200 Subject: [PATCH 0022/1452] add concat --- src/comp.c | 28 ++++++++++++++++++++-------- test/src/comp-tests.el | 9 +++++++++ 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2e5f3342cbd..8745908708a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -91,8 +91,10 @@ along with GNU Emacs. If not, see . */ #define STR(s) #s -/* With most of the ops we need to do the same stuff so this save some - typing. */ +/* With most of the ops we need to do the same stuff so this macros are meant + to save some typing. */ + +/* Generate appropriate case and emit convential calls to function. */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ @@ -101,6 +103,14 @@ along with GNU Emacs. If not, see . */ PUSH (gcc_jit_lvalue_as_rvalue (res)); \ break +/* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) + This is done aggregating args into the scratch_call_area. */ + +#define EMIT_SCRATCH_CALL_N(name, nargs) \ + pop (nargs, &stack, args); \ + res = jit_emit_callN (name, nargs, args); \ + PUSH (gcc_jit_lvalue_as_rvalue (res)) + /* The compiler context */ typedef struct { @@ -588,14 +598,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (substring, 3); case Bconcat2: - printf("Bconcat2\n"); + EMIT_SCRATCH_CALL_N ("Fconcat", 2); break; case Bconcat3: - printf("Bconcat3\n"); + EMIT_SCRATCH_CALL_N ("Fconcat", 3); break; case Bconcat4: - printf("Bconcat4\n"); + EMIT_SCRATCH_CALL_N ("Fconcat", 4); break; + case BconcatN: + op = FETCH; + EMIT_SCRATCH_CALL_N ("Fconcat", op); + break; + case Bsub1: printf("Bsub1\n"); break; @@ -864,9 +879,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case BRgotoifnonnilelsepop: printf("BRgotoifnonnilelsepop\n"); break; - case BconcatN: - printf("BconcatN\n"); - break; case BinsertN: printf("BinsertN\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 36344d361fc..006336393dd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -106,6 +106,15 @@ (should (= (comp-tests-symbol-value-f) 3))) +(ert-deftest comp-tests-concat () + "Testing concatX opcodes." + (defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + (byte-compile #'comp-tests-concat-f) + (native-compile #'comp-tests-concat-f) + + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) (ert-deftest comp-tests-ffuncall () "Testing varset." From 7ad90d410813dae9d2fda3c251d14678b8f104d0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 17:26:54 +0200 Subject: [PATCH 0023/1452] add some more ops --- src/comp.c | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8745908708a..259cba6691b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -633,22 +633,22 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, printf("Bgeq\n"); break; case Bdiff: - printf("Bdiff\n"); + EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: printf("Bnegate\n"); break; case Bplus: - printf("Bplus\n"); + EMIT_SCRATCH_CALL_N ("Fplus", 2); break; case Bmax: - printf("Bmax\n"); + EMIT_SCRATCH_CALL_N ("Fmax", 2); break; case Bmin: - printf("Bmin\n"); + EMIT_SCRATCH_CALL_N ("Fmin", 2); break; case Bmult: - printf("Bmult\n"); + EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: printf("Bpoint\n"); @@ -656,12 +656,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: printf("Bsave_current_buffer\n"); break; - case Bgoto_char: - printf("Bgoto_char\n"); - break; + + CASE_CALL_NARGS (goto_char, 1); + case Binsert: - printf("Binsert\n"); + EMIT_SCRATCH_CALL_N ("Finsert", 1); break; + case Bpoint_max: printf("Bpoint_max\n"); break; From 7e3d6657e7a952c2eaf9d814ac639613ec81ac1d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 17:35:15 +0200 Subject: [PATCH 0024/1452] replace printfs with proper errors for non supported ops --- src/comp.c | 180 ++++++++++++++++++++++++++--------------------------- 1 file changed, 90 insertions(+), 90 deletions(-) diff --git a/src/comp.c b/src/comp.c index 259cba6691b..3f0db646660 100644 --- a/src/comp.c +++ b/src/comp.c @@ -384,7 +384,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, while (pc < bytestr_length) { op = FETCH; - printf ("pc %td\t%ud\n", pc, op); + switch (op) { case Bstack_ref1: @@ -540,13 +540,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; case Bpophandler: - printf("Bpophandler\n"); + error ("Bpophandler\n"); break; case Bpushconditioncase: - printf("Bpushconditioncase\n"); + error ("Bpushconditioncase\n"); break; case Bpushcatch: - printf("Bpushcatch\n"); + error ("Bpushcatch\n"); break; CASE_CALL_NARGS (nth, 2); @@ -612,31 +612,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsub1: - printf("Bsub1\n"); + error ("Bsub1\n"); break; case Badd1: - printf("Badd1\n"); + error ("Badd1\n"); break; case Beqlsign: - printf("Beqlsign\n"); + error ("Beqlsign\n"); break; case Bgtr: - printf("Bgtr\n"); + error ("Bgtr\n"); break; case Blss: - printf("Blss\n"); + error ("Blss\n"); break; case Bleq: - printf("Bleq\n"); + error ("Bleq\n"); break; case Bgeq: - printf("Bgeq\n"); + error ("Bgeq\n"); break; case Bdiff: EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: - printf("Bnegate\n"); + error ("Bnegate\n"); break; case Bplus: EMIT_SCRATCH_CALL_N ("Fplus", 2); @@ -651,10 +651,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: - printf("Bpoint\n"); + error ("Bpoint\n"); break; case Bsave_current_buffer: - printf("Bsave_current_buffer\n"); + error ("Bsave_current_buffer\n"); break; CASE_CALL_NARGS (goto_char, 1); @@ -664,104 +664,105 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bpoint_max: - printf("Bpoint_max\n"); + error ("Bpoint_max\n"); break; case Bpoint_min: - printf("Bpoint_min\n"); + error ("Bpoint_min\n"); break; case Bchar_after: - printf("Bchar_after\n"); + error ("Bchar_after\n"); break; case Bfollowing_char: - printf("Bfollowing_char\n"); + error ("Bfollowing_char\n"); break; case Bpreceding_char: - printf("Bpreceding_char\n"); + error ("Bpreceding_char\n"); break; case Bcurrent_column: - printf("Bcurrent_column\n"); + error ("Bcurrent_column\n"); break; case Bindent_to: - printf("Bindent_to\n"); + error ("Bindent_to\n"); break; case Beolp: - printf("Beolp\n"); + error ("Beolp\n"); break; case Beobp: - printf("Beobp\n"); + error ("Beobp\n"); break; case Bbolp: - printf("Bbolp\n"); + error ("Bbolp\n"); break; case Bbobp: - printf("Bbobp\n"); + error ("Bbobp\n"); break; case Bcurrent_buffer: - printf("Bcurrent_buffer\n"); + error ("Bcurrent_buffer\n"); break; case Bset_buffer: - printf("Bset_buffer\n"); + error ("Bset_buffer\n"); break; case Bsave_current_buffer_1: - printf("Bsave_current_buffer_1\n"); + error ("Bsave_current_buffer_1\n"); break; case Binteractive_p: - printf("Binteractive_p\n"); + error ("Binteractive_p\n"); break; case Bforward_char: - printf("Bforward_char\n"); + error ("Bforward_char\n"); break; case Bforward_word: - printf("Bforward_word\n"); + error ("Bforward_word\n"); break; case Bskip_chars_forward: - printf("Bskip_chars_forward\n"); + error ("Bskip_chars_forward\n"); break; case Bskip_chars_backward: - printf("Bskip_chars_backward\n"); + error ("Bskip_chars_backward\n"); break; case Bforward_line: - printf("Bforward_line\n"); + error ("Bforward_line\n"); break; case Bchar_syntax: - printf("Bchar_syntax\n"); + error ("Bchar_syntax\n"); break; case Bbuffer_substring: - printf("Bbuffer_substring\n"); + error ("Bbuffer_substring\n"); break; case Bdelete_region: - printf("Bdelete_region\n"); + error ("Bdelete_region\n"); break; case Bnarrow_to_region: - printf("Bnarrow_to_region\n"); + error ("Bnarrow_to_region\n"); break; case Bwiden: - printf("Bwiden\n"); + error ("Bwiden\n"); break; case Bend_of_line: - printf("Bend_of_line\n"); + error ("Bend_of_line\n"); break; + case Bconstant2: - printf("Bconstant2\n"); goto do_constant; break; + case Bgoto: - printf("Bgoto\n"); + error ("Bgoto\n"); break; case Bgotoifnil: - printf("Bgotoifnil\n"); + error ("Bgotoifnil\n"); break; case Bgotoifnonnil: - printf("Bgotoifnonnil\n"); + error ("Bgotoifnonnil\n"); break; case Bgotoifnilelsepop: - printf("Bgotoifnilelsepop\n"); + error ("Bgotoifnilelsepop\n"); break; case Bgotoifnonnilelsepop: - printf("Bgotoifnonnilelsepop\n"); + error ("Bgotoifnonnilelsepop\n"); break; + case Breturn: - printf("Breturn\n"); break; case Bdiscard: @@ -773,127 +774,127 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - printf("Bsave_excursion\n"); + error ("Bsave_excursion\n"); break; case Bsave_window_excursion: - printf("Bsave_window_excursion\n"); + error ("Bsave_window_excursion\n"); break; case Bsave_restriction: - printf("Bsave_restriction\n"); + error ("Bsave_restriction\n"); break; case Bcatch: - printf("Bcatch\n"); + error ("Bcatch\n"); break; case Bunwind_protect: - printf("Bunwind_protect\n"); + error ("Bunwind_protect\n"); break; case Bcondition_case: - printf("Bcondition_case\n"); + error ("Bcondition_case\n"); break; case Btemp_output_buffer_setup: - printf("Btemp_output_buffer_setup\n"); + error ("Btemp_output_buffer_setup\n"); break; case Btemp_output_buffer_show: - printf("Btemp_output_buffer_show\n"); + error ("Btemp_output_buffer_show\n"); break; case Bunbind_all: - printf("Bunbind_all\n"); + error ("Bunbind_all\n"); break; case Bset_marker: - printf("Bset_marker\n"); + error ("Bset_marker\n"); break; case Bmatch_beginning: - printf("Bmatch_beginning\n"); + error ("Bmatch_beginning\n"); break; case Bmatch_end: - printf("Bmatch_end\n"); + error ("Bmatch_end\n"); break; case Bupcase: - printf("Bupcase\n"); + error ("Bupcase\n"); break; case Bdowncase: - printf("Bdowncase\n"); + error ("Bdowncase\n"); break; case Bstringeqlsign: - printf("Bstringeqlsign\n"); + error ("Bstringeqlsign\n"); break; case Bstringlss: - printf("Bstringlss\n"); + error ("Bstringlss\n"); break; case Bequal: - printf("Bequal\n"); + error ("Bequal\n"); break; case Bnthcdr: - printf("Bnthcdr\n"); + error ("Bnthcdr\n"); break; case Belt: - printf("Belt\n"); + error ("Belt\n"); break; case Bmember: - printf("Bmember\n"); + error ("Bmember\n"); break; case Bassq: - printf("Bassq\n"); + error ("Bassq\n"); break; case Bnreverse: - printf("Bnreverse\n"); + error ("Bnreverse\n"); break; case Bsetcar: - printf("Bsetcar\n"); + error ("Bsetcar\n"); break; case Bsetcdr: - printf("Bsetcdr\n"); + error ("Bsetcdr\n"); break; case Bcar_safe: - printf("Bcar_safe\n"); + error ("Bcar_safe\n"); break; case Bcdr_safe: - printf("Bcdr_safe\n"); + error ("Bcdr_safe\n"); break; case Bnconc: - printf("Bnconc\n"); + error ("Bnconc\n"); break; case Bquo: - printf("Bquo\n"); + error ("Bquo\n"); break; case Brem: - printf("Brem\n"); + error ("Brem\n"); break; case Bnumberp: - printf("Bnumberp\n"); + error ("Bnumberp\n"); break; case Bintegerp: - printf("Bintegerp\n"); + error ("Bintegerp\n"); break; case BRgoto: - printf("BRgoto\n"); + error ("BRgoto\n"); break; case BRgotoifnil: - printf("BRgotoifnil\n"); + error ("BRgotoifnil\n"); break; case BRgotoifnonnil: - printf("BRgotoifnonnil\n"); + error ("BRgotoifnonnil\n"); break; case BRgotoifnilelsepop: - printf("BRgotoifnilelsepop\n"); + error ("BRgotoifnilelsepop\n"); break; case BRgotoifnonnilelsepop: - printf("BRgotoifnonnilelsepop\n"); + error ("BRgotoifnonnilelsepop\n"); break; case BinsertN: - printf("BinsertN\n"); + error ("BinsertN\n"); break; case Bstack_set: - printf("Bstack_set\n"); + error ("Bstack_set\n"); break; case Bstack_set2: - printf("Bstack_set2\n"); + error ("Bstack_set2\n"); break; case BdiscardN: - printf("BdiscardN\n"); + error ("BdiscardN\n"); break; case Bswitch: - printf("Bswitch\n"); + error ("Bswitch\n"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have @@ -903,7 +904,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; default: case Bconstant: - printf("Bconstant "); { if (op < Bconstant || op > Bconstant + vector_size) goto fail; @@ -919,7 +919,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); PUSH (c); - Fprint(vectorp[op], Qnil); + /* Fprint(vectorp[op], Qnil); */ break; } From a80140032be992d170925f274fad215de97d9a50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 17:38:02 +0200 Subject: [PATCH 0025/1452] move return into the right place --- src/comp.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3f0db646660..4b01a057054 100644 --- a/src/comp.c +++ b/src/comp.c @@ -763,6 +763,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Breturn: + POP1; + gcc_jit_block_end_with_return(comp.block, + NULL, + args[0]); break; case Bdiscard: @@ -930,10 +934,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } } - stack--; - gcc_jit_block_end_with_return(comp.block, - NULL, - *stack); comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); goto exit; From 68472f45a6a441b1436b5949c0384dd57111077c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 17:51:16 +0200 Subject: [PATCH 0026/1452] some more ops --- src/comp.c | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4b01a057054..8cb7cbf4ad6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -669,18 +669,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpoint_min: error ("Bpoint_min\n"); break; - case Bchar_after: - error ("Bchar_after\n"); - break; - case Bfollowing_char: - error ("Bfollowing_char\n"); - break; + + CASE_CALL_NARGS (char_after, 1); + CASE_CALL_NARGS (following_char, 0); + case Bpreceding_char: - error ("Bpreceding_char\n"); - break; - case Bcurrent_column: - error ("Bcurrent_column\n"); + res = jit_emit_call (Fprevious_char, comp.lisp_obj_type, 0, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + + CASE_CALL_NARGS (current_column, 0); + case Bindent_to: error ("Bindent_to\n"); break; From 15b4f9d8786d4ecc9eab81d114f09448de2b9ce9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 17:54:43 +0200 Subject: [PATCH 0027/1452] precompute nil --- src/comp.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8cb7cbf4ad6..9b4dea98d7f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -49,6 +49,8 @@ along with GNU Emacs. If not, see . */ stack++; \ } while (0) +#define POP0 + #define POP1 \ do { \ stack--; \ @@ -120,6 +122,7 @@ typedef struct { gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_block *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ @@ -454,9 +457,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - args[2] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - Qnil); + args[2] = comp.nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -674,7 +675,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = jit_emit_call (Fprevious_char, comp.lisp_obj_type, 0, args); + res = jit_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -1089,6 +1090,10 @@ init_comp (void) comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + comp.nil = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj_type, + Qnil); + comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, From 1121416cfde99f0738d0dac63b6fdd2667de2c5e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 May 2019 18:01:02 +0200 Subject: [PATCH 0028/1452] adding stuffs --- src/comp.c | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9b4dea98d7f..80c1c2a863c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -117,10 +117,11 @@ along with GNU Emacs. If not, see . */ typedef struct { gcc_jit_context *ctxt; - gcc_jit_type *lisp_obj_type; + gcc_jit_type *void_type; gcc_jit_type *int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; + gcc_jit_type *lisp_obj_type; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ @@ -654,9 +655,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpoint: error ("Bpoint\n"); break; - case Bsave_current_buffer: - error ("Bsave_current_buffer\n"); - break; CASE_CALL_NARGS (goto_char, 1); @@ -682,29 +680,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (current_column, 0); case Bindent_to: - error ("Bindent_to\n"); - break; - case Beolp: - error ("Beolp\n"); + POP1; + args[1] = comp.nil; + res = jit_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); break; + + CASE_CALL_NARGS (eolp, 0); + case Beobp: error ("Beobp\n"); break; - case Bbolp: - error ("Bbolp\n"); - break; + + CASE_CALL_NARGS (bolp, 0); + case Bbobp: error ("Bbobp\n"); break; - case Bcurrent_buffer: - error ("Bcurrent_buffer\n"); - break; - case Bset_buffer: - error ("Bset_buffer\n"); - break; + + CASE_CALL_NARGS (current_buffer, 0); + CASE_CALL_NARGS (set_buffer, 1); + + case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - error ("Bsave_current_buffer_1\n"); + jit_emit_call ("record_unwind_current_buffer", + comp.void_type, 0, NULL); break; + case Binteractive_p: error ("Binteractive_p\n"); break; @@ -1074,6 +1075,7 @@ init_comp (void) comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); #endif + comp.void_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID); comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); comp.void_ptr_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); From c6680e15d7c46b9c15358c5bcca4c70b3b2608be Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 May 2019 09:44:06 +0200 Subject: [PATCH 0029/1452] better error msg --- src/comp.c | 116 ++++++++++++++++++++++++++--------------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/src/comp.c b/src/comp.c index 80c1c2a863c..a460d960506 100644 --- a/src/comp.c +++ b/src/comp.c @@ -707,40 +707,40 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: - error ("Binteractive_p\n"); + error ("Binteractive_p not supported"); break; case Bforward_char: - error ("Bforward_char\n"); + error ("Bforward_char not supported"); break; case Bforward_word: - error ("Bforward_word\n"); + error ("Bforward_word not supported"); break; case Bskip_chars_forward: - error ("Bskip_chars_forward\n"); + error ("Bskip_chars_forward not supported"); break; case Bskip_chars_backward: - error ("Bskip_chars_backward\n"); + error ("Bskip_chars_backward not supported"); break; case Bforward_line: - error ("Bforward_line\n"); + error ("Bforward_line not supported"); break; case Bchar_syntax: - error ("Bchar_syntax\n"); + error ("Bchar_syntax not supported"); break; case Bbuffer_substring: - error ("Bbuffer_substring\n"); + error ("Bbuffer_substring not supported"); break; case Bdelete_region: - error ("Bdelete_region\n"); + error ("Bdelete_region not supported"); break; case Bnarrow_to_region: - error ("Bnarrow_to_region\n"); + error ("Bnarrow_to_region not supported"); break; case Bwiden: - error ("Bwiden\n"); + error ("Bwiden not supported"); break; case Bend_of_line: - error ("Bend_of_line\n"); + error ("Bend_of_line not supported"); break; case Bconstant2: @@ -748,19 +748,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bgoto: - error ("Bgoto\n"); + error ("Bgoto not supported"); break; case Bgotoifnil: - error ("Bgotoifnil\n"); + error ("Bgotoifnil not supported"); break; case Bgotoifnonnil: - error ("Bgotoifnonnil\n"); + error ("Bgotoifnonnil not supported"); break; case Bgotoifnilelsepop: - error ("Bgotoifnilelsepop\n"); + error ("Bgotoifnilelsepop not supported"); break; case Bgotoifnonnilelsepop: - error ("Bgotoifnonnilelsepop\n"); + error ("Bgotoifnonnilelsepop not supported"); break; case Breturn: @@ -779,127 +779,127 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - error ("Bsave_excursion\n"); + error ("Bsave_excursion not supported"); break; case Bsave_window_excursion: - error ("Bsave_window_excursion\n"); + error ("Bsave_window_excursion not supported"); break; case Bsave_restriction: - error ("Bsave_restriction\n"); + error ("Bsave_restriction not supported"); break; case Bcatch: - error ("Bcatch\n"); + error ("Bcatch not supported"); break; case Bunwind_protect: - error ("Bunwind_protect\n"); + error ("Bunwind_protect not supported"); break; case Bcondition_case: - error ("Bcondition_case\n"); + error ("Bcondition_case not supported"); break; case Btemp_output_buffer_setup: - error ("Btemp_output_buffer_setup\n"); + error ("Btemp_output_buffer_setup not supported"); break; case Btemp_output_buffer_show: - error ("Btemp_output_buffer_show\n"); + error ("Btemp_output_buffer_show not supported"); break; case Bunbind_all: - error ("Bunbind_all\n"); + error ("Bunbind_all not supported"); break; case Bset_marker: - error ("Bset_marker\n"); + error ("Bset_marker not supported"); break; case Bmatch_beginning: - error ("Bmatch_beginning\n"); + error ("Bmatch_beginning not supported"); break; case Bmatch_end: - error ("Bmatch_end\n"); + error ("Bmatch_end not supported"); break; case Bupcase: - error ("Bupcase\n"); + error ("Bupcase not supported"); break; case Bdowncase: - error ("Bdowncase\n"); + error ("Bdowncase not supported"); break; case Bstringeqlsign: - error ("Bstringeqlsign\n"); + error ("Bstringeqlsign not supported"); break; case Bstringlss: - error ("Bstringlss\n"); + error ("Bstringlss not supported"); break; case Bequal: - error ("Bequal\n"); + error ("Bequal not supported"); break; case Bnthcdr: - error ("Bnthcdr\n"); + error ("Bnthcdr not supported"); break; case Belt: - error ("Belt\n"); + error ("Belt not supported"); break; case Bmember: - error ("Bmember\n"); + error ("Bmember not supported"); break; case Bassq: - error ("Bassq\n"); + error ("Bassq not supported"); break; case Bnreverse: - error ("Bnreverse\n"); + error ("Bnreverse not supported"); break; case Bsetcar: - error ("Bsetcar\n"); + error ("Bsetcar not supported"); break; case Bsetcdr: - error ("Bsetcdr\n"); + error ("Bsetcdr not supported"); break; case Bcar_safe: - error ("Bcar_safe\n"); + error ("Bcar_safe not supported"); break; case Bcdr_safe: - error ("Bcdr_safe\n"); + error ("Bcdr_safe not supported"); break; case Bnconc: - error ("Bnconc\n"); + error ("Bnconc not supported"); break; case Bquo: - error ("Bquo\n"); + error ("Bquo not supported"); break; case Brem: - error ("Brem\n"); + error ("Brem not supported"); break; case Bnumberp: - error ("Bnumberp\n"); + error ("Bnumberp not supported"); break; case Bintegerp: - error ("Bintegerp\n"); + error ("Bintegerp not supported"); break; case BRgoto: - error ("BRgoto\n"); + error ("BRgoto not supported"); break; case BRgotoifnil: - error ("BRgotoifnil\n"); + error ("BRgotoifnil not supported"); break; case BRgotoifnonnil: - error ("BRgotoifnonnil\n"); + error ("BRgotoifnonnil not supported"); break; case BRgotoifnilelsepop: - error ("BRgotoifnilelsepop\n"); + error ("BRgotoifnilelsepop not supported"); break; case BRgotoifnonnilelsepop: - error ("BRgotoifnonnilelsepop\n"); + error ("BRgotoifnonnilelsepop not supported"); break; case BinsertN: - error ("BinsertN\n"); + error ("BinsertN not supported"); break; case Bstack_set: - error ("Bstack_set\n"); + error ("Bstack_set not supported"); break; case Bstack_set2: - error ("Bstack_set2\n"); + error ("Bstack_set2 not supported"); break; case BdiscardN: - error ("BdiscardN\n"); + error ("BdiscardN not supported"); break; case Bswitch: - error ("Bswitch\n"); + error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have From 3943db1ab27a29105520bb4e2975e68540e3f055 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 May 2019 10:10:45 +0200 Subject: [PATCH 0030/1452] adding more stuffs --- src/comp.c | 135 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 85 insertions(+), 50 deletions(-) diff --git a/src/comp.c b/src/comp.c index a460d960506..3f7e093b570 100644 --- a/src/comp.c +++ b/src/comp.c @@ -28,6 +28,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "bytecode.h" #include "atimer.h" +#include "window.h" #define COMP_DEBUG 0 @@ -145,16 +146,16 @@ typedef struct { INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]); -static gcc_jit_function *jit_func_declare (const char *f_name, - gcc_jit_type *ret_type, - unsigned nargs, - gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, - bool reusable); - void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, bool dump_asm); + +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + /* Pop form the main evaluation stack and place the elements in args in reversed order. */ @@ -683,6 +684,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = comp.nil; res = jit_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; CASE_CALL_NARGS (eolp, 0); @@ -706,43 +708,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.void_type, 0, NULL); break; - case Binteractive_p: - error ("Binteractive_p not supported"); - break; - case Bforward_char: - error ("Bforward_char not supported"); - break; - case Bforward_word: - error ("Bforward_word not supported"); - break; - case Bskip_chars_forward: - error ("Bskip_chars_forward not supported"); - break; - case Bskip_chars_backward: - error ("Bskip_chars_backward not supported"); - break; - case Bforward_line: - error ("Bforward_line not supported"); - break; - case Bchar_syntax: - error ("Bchar_syntax not supported"); - break; - case Bbuffer_substring: - error ("Bbuffer_substring not supported"); - break; - case Bdelete_region: - error ("Bdelete_region not supported"); - break; - case Bnarrow_to_region: - error ("Bnarrow_to_region not supported"); - break; - case Bwiden: - error ("Bwiden not supported"); - break; - case Bend_of_line: - error ("Bend_of_line not supported"); + case Binteractive_p: /* Obsolete since 24.1. */ + PUSH (gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj_type, + intern ("interactive-p"))); + res = jit_emit_call ("call0", comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + CASE_CALL_NARGS (forward_char, 1); + CASE_CALL_NARGS (forward_word, 1); + CASE_CALL_NARGS (skip_chars_forward, 2); + CASE_CALL_NARGS (skip_chars_backward, 2); + CASE_CALL_NARGS (forward_line, 1); + CASE_CALL_NARGS (char_syntax, 1); + CASE_CALL_NARGS (buffer_substring, 2); + CASE_CALL_NARGS (delete_region, 2); + CASE_CALL_NARGS (narrow_to_region, 2); + CASE_CALL_NARGS (widen, 0); + CASE_CALL_NARGS (end_of_line, 1); + case Bconstant2: goto do_constant; break; @@ -779,20 +764,43 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - error ("Bsave_excursion not supported"); + res = jit_emit_call ("record_unwind_protect_excursion", + comp.void_type, 0, args); break; - case Bsave_window_excursion: - error ("Bsave_window_excursion not supported"); + + case Bsave_window_excursion: /* Obsolete since 24.1. */ + POP1; + res = jit_emit_call ("helper_save_window_excursion", + comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Bsave_restriction: - error ("Bsave_restriction not supported"); + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + save_restriction_restore); + args[1] = + gcc_jit_lvalue_as_rvalue (jit_emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL)); + jit_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - case Bcatch: - error ("Bcatch not supported"); + + case Bcatch: /* Obsolete since 24.4. */ + POP2; + args[2] = args[1]; + args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + eval_sub); + jit_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; - case Bunwind_protect: - error ("Bunwind_protect not supported"); + + case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ + POP1; + jit_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; + case Bcondition_case: error ("Bcondition_case not supported"); break; @@ -1139,4 +1147,31 @@ syms_of_comp (void) staticpro (&comp.func_hash); } +/******************************************************************************/ +/* Helper functions called from the runtime. */ +/* These can't be statics till shared mechanism is used to solve relocations. */ +/******************************************************************************/ + +Lisp_Object helper_save_window_excursion (Lisp_Object v1); + +void helper_unwind_protect (Lisp_Object handler); + +Lisp_Object +helper_save_window_excursion (Lisp_Object v1) +{ + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (restore_window_configuration, + Fcurrent_window_configuration (Qnil)); + v1 = Fprogn (v1); + unbind_to (count1, v1); + return v1; +} + +void helper_unwind_protect (Lisp_Object handler) +{ + /* Support for a function here is new in 24.4. */ + record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, + handler); +} + #endif /* HAVE_LIBJIT */ From 70fc2a742d28697b0bb05c16665f038f6f79c86e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 May 2019 10:52:55 +0200 Subject: [PATCH 0031/1452] naming change --- src/comp.c | 50 +++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3f7e093b570..08cdf29f9f3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -102,7 +102,7 @@ along with GNU Emacs. If not, see . */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ POP##nargs; \ - res = jit_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + res = gcc_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ PUSH (gcc_jit_lvalue_as_rvalue (res)); \ break @@ -111,7 +111,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_SCRATCH_CALL_N(name, nargs) \ pop (nargs, &stack, args); \ - res = jit_emit_callN (name, nargs, args); \ + res = gcc_emit_callN (name, nargs, args); \ PUSH (gcc_jit_lvalue_as_rvalue (res)) /* The compiler context */ @@ -174,7 +174,7 @@ pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) } static gcc_jit_function * -jit_func_declare (const char *f_name, gcc_jit_type *ret_type, +gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { @@ -253,7 +253,7 @@ jit_func_declare (const char *f_name, gcc_jit_type *ret_type, } static gcc_jit_lvalue * -jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, +gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); @@ -263,7 +263,7 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - jit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + gcc_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); @@ -287,7 +287,7 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -jit_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -333,7 +333,7 @@ jit_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) nargs); args[1] = comp.scratch; - return jit_emit_call (f_name, comp.lisp_obj_type, 2, args); + return gcc_emit_call (f_name, comp.lisp_obj_type, 2, args); } static comp_f_res_t @@ -378,7 +378,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. Return a lips obj. */ - comp.func = jit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) @@ -432,7 +432,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -463,7 +463,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = jit_emit_call ("set_internal", comp.lisp_obj_type, 4, args); + res = gcc_emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; @@ -489,7 +489,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); pop (1, &stack, &args[1]); - res = jit_emit_call ("specbind", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -513,7 +513,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = jit_emit_callN ("Ffuncall", nargs, args); + res = gcc_emit_callN ("Ffuncall", nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -539,7 +539,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - res = jit_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); + res = gcc_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -579,12 +579,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, Qnil); - res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); for (int i = 0; i < op; ++i) { POP2; - res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; @@ -674,7 +674,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = jit_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); + res = gcc_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -683,7 +683,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; args[1] = comp.nil; - res = jit_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -704,7 +704,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - jit_emit_call ("record_unwind_current_buffer", + gcc_emit_call ("record_unwind_current_buffer", comp.void_type, 0, NULL); break; @@ -712,7 +712,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH (gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, intern ("interactive-p"))); - res = jit_emit_call ("call0", comp.lisp_obj_type, 1, args); + res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -764,13 +764,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - res = jit_emit_call ("record_unwind_protect_excursion", + res = gcc_emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; case Bsave_window_excursion: /* Obsolete since 24.1. */ POP1; - res = jit_emit_call ("helper_save_window_excursion", + res = gcc_emit_call ("helper_save_window_excursion", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -780,11 +780,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.void_ptr_type, save_restriction_restore); args[1] = - gcc_jit_lvalue_as_rvalue (jit_emit_call ("save_restriction_save", + gcc_jit_lvalue_as_rvalue (gcc_emit_call ("save_restriction_save", comp.lisp_obj_type, 0, NULL)); - jit_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + gcc_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; case Bcatch: /* Obsolete since 24.4. */ @@ -793,12 +793,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, eval_sub); - jit_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + gcc_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ POP1; - jit_emit_call ("helper_unwind_protect", comp.void_type, 1, args); + gcc_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; case Bcondition_case: From d234e9bc8ae3c8ea1ecb82970a4fd1fd89850249 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 May 2019 11:17:01 +0200 Subject: [PATCH 0032/1452] add stuffs --- src/comp.c | 48 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 40 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 08cdf29f9f3..8cf3131daea 100644 --- a/src/comp.c +++ b/src/comp.c @@ -539,7 +539,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - res = gcc_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); + gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -801,16 +801,30 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - case Bcondition_case: - error ("Bcondition_case not supported"); + case Bcondition_case: /* Obsolete since 24.4. */ + POP3; + gcc_emit_call ("internal_lisp_condition_case", + comp.lisp_obj_type, 3, args); break; - case Btemp_output_buffer_setup: - error ("Btemp_output_buffer_setup not supported"); + + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ + POP1; + res = gcc_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, + 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; - case Btemp_output_buffer_show: - error ("Btemp_output_buffer_show not supported"); + + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ + POP2; + gcc_emit_call ("temp_output_buffer_show", comp.void_type, 1, + &args[1]); + PUSH (args[0]); + gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + break; - case Bunbind_all: + case Bunbind_all: /* Obsolete. Never used. */ + /* To unbind back to the beginning of this frame. Not used yet, + but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); break; case Bset_marker: @@ -1156,6 +1170,10 @@ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); +Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); + +Lisp_Object helper_unbind_n (int val); + Lisp_Object helper_save_window_excursion (Lisp_Object v1) { @@ -1174,4 +1192,18 @@ void helper_unwind_protect (Lisp_Object handler) handler); } +Lisp_Object +helper_temp_output_buffer_setup (Lisp_Object x) +{ + CHECK_STRING (x); + temp_output_buffer_setup (SSDATA (x)); + return Vstandard_output; +} + +Lisp_Object +helper_unbind_n (int val) +{ + return unbind_to (SPECPDL_INDEX () - val, Qnil); +} + #endif /* HAVE_LIBJIT */ From 37381fb9b2cc225d127d8eb7cfc0e42c27cc1413 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 May 2019 12:35:27 +0200 Subject: [PATCH 0033/1452] generalize bblocks --- src/comp.c | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8cf3131daea..3b058348a42 100644 --- a/src/comp.c +++ b/src/comp.c @@ -109,10 +109,16 @@ along with GNU Emacs. If not, see . */ /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) This is done aggregating args into the scratch_call_area. */ -#define EMIT_SCRATCH_CALL_N(name, nargs) \ - pop (nargs, &stack, args); \ - res = gcc_emit_callN (name, nargs, args); \ - PUSH (gcc_jit_lvalue_as_rvalue (res)) +#define EMIT_SCRATCH_CALL_N(name, nargs) \ + do { \ + pop (nargs, &stack, args); \ + res = gcc_emit_callN (name, nargs, args); \ + PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + } while (0) + +/* Current basic block we are emiting in. */ + +#define BBLOCK comp.bblocks[comp.bb_n] /* The compiler context */ @@ -126,7 +132,8 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ - gcc_jit_block *block; /* Current basic block */ + gcc_jit_block **bblocks; /* Basic blocks */ + unsigned bb_n; /* Current basic block number */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -276,7 +283,7 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, NULL, ret_type, "res"); - gcc_jit_block_add_assignment(comp.block, NULL, + gcc_jit_block_add_assignment(BBLOCK, NULL, res, gcc_jit_context_new_call(comp.ctxt, NULL, @@ -310,7 +317,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(comp.block, NULL, + gcc_jit_block_add_assignment(BBLOCK, NULL, p, comp.scratch); @@ -320,7 +327,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT), i); - gcc_jit_block_add_assignment (comp.block, NULL, + gcc_jit_block_add_assignment (BBLOCK, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue(p), @@ -355,6 +362,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); stack_over = stack_base + stack_depth; + comp.bblocks = + (gcc_jit_block **) xzalloc (bytestr_length * sizeof (gcc_jit_block *)); + comp.bb_n = 0; + if (FIXNUMP (args_template)) { ptrdiff_t at = XFIXNUM (args_template); @@ -384,7 +395,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); - comp.block = gcc_jit_function_new_block(comp.func, "foo_blk"); + BBLOCK = gcc_jit_function_new_block(comp.func, NULL); while (pc < bytestr_length) { @@ -750,7 +761,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Breturn: POP1; - gcc_jit_block_end_with_return(comp.block, + gcc_jit_block_end_with_return(BBLOCK, NULL, args[0]); break; From c43a9d940a9d033f7770f241f920a537167b211b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 May 2019 15:33:02 +0200 Subject: [PATCH 0034/1452] add bb computation --- src/comp.c | 149 ++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 131 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3b058348a42..ffc79d1c24b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -116,10 +116,6 @@ along with GNU Emacs. If not, see . */ PUSH (gcc_jit_lvalue_as_rvalue (res)); \ } while (0) -/* Current basic block we are emiting in. */ - -#define BBLOCK comp.bblocks[comp.bb_n] - /* The compiler context */ typedef struct { @@ -132,8 +128,7 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ - gcc_jit_block **bblocks; /* Basic blocks */ - unsigned bb_n; /* Current basic block number */ + gcc_jit_block *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -283,7 +278,7 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, NULL, ret_type, "res"); - gcc_jit_block_add_assignment(BBLOCK, NULL, + gcc_jit_block_add_assignment(comp.bblock, NULL, res, gcc_jit_context_new_call(comp.ctxt, NULL, @@ -317,7 +312,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(BBLOCK, NULL, + gcc_jit_block_add_assignment(comp.bblock, NULL, p, comp.scratch); @@ -327,7 +322,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT), i); - gcc_jit_block_add_assignment (BBLOCK, NULL, + gcc_jit_block_add_assignment (comp.bblock, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue(p), @@ -343,6 +338,122 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return gcc_emit_call (f_name, comp.lisp_obj_type, 2, args); } +static int +ucmp(const void *a, const void *b) +{ +#define _I(x) *(const int*)x + return _I(a) < _I(b) ? -1 : _I(a) > _I(b); +#undef _I +} + +/* Compute and initialize all basic blocks. */ +static gcc_jit_block ** +compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) +{ + ptrdiff_t pc = 0; + unsigned op; + bool new_bb = true; + gcc_jit_block **bb_map = xmalloc (bytestr_length * sizeof (gcc_jit_block *)); + unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); + unsigned bb_n = 0; + + while (pc < bytestr_length) + { + if (new_bb) + { + bb_start_pc[bb_n++] = pc; + new_bb = false; + } + + op = FETCH; + switch (op) + { + /* 3 byte non branch ops */ + case Bvarref7: + case Bvarset7: + case Bvarbind7: + case Bcall7: + case Bunbind7: + case Bpushcatch: + case Bpushconditioncase: + case Bstack_ref7: + case Bstack_set2: + pc += 2; + break; + /* 2 byte non branch ops */ + case Bvarref6: + case Bvarset6: + case Bvarbind6: + case Bcall6: + case Bunbind6: + case Bconstant2: + case BlistN: + case BconcatN: + case BinsertN: + case Bstack_ref6: + case Bstack_set: + case BdiscardN: + ++pc; + break; + /* Absolute branches */ + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + op = FETCH2; + bb_start_pc[bb_n++] = op; + new_bb = true; + break; + /* PC relative branches */ + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + op = FETCH - 128; + bb_start_pc[bb_n++] = op; + new_bb = true; + break; + /* Return */ + case Breturn: + new_bb = true; + break; + default: + break; + } + } + + /* Sort and remove possible duplicates. */ + qsort (bb_start_pc, bb_n, sizeof(unsigned), ucmp); + { + unsigned i, j; + for (i = j = 0; i < bb_n; i++) + if (bb_start_pc[i] != bb_start_pc[j]) + bb_start_pc[++j] = bb_start_pc[i]; + bb_n = j + 1; + } + + /* for (int i = 0; i < bb_n; i++) */ + /* printf ("%d ", bb_start_pc[i]); */ + /* printf ("\n"); */ + + gcc_jit_block *curr_bb; + for (int i = 0, pc = 0; pc < bytestr_length; pc++) + { + if (i < bb_n && pc == bb_start_pc[i]) + { + ++i; + curr_bb = gcc_jit_function_new_block (comp.func, NULL); + } + bb_map[pc] = curr_bb; + } + + xfree (bb_start_pc); + + return bb_map; +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -362,10 +473,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); stack_over = stack_base + stack_depth; - comp.bblocks = - (gcc_jit_block **) xzalloc (bytestr_length * sizeof (gcc_jit_block *)); - comp.bb_n = 0; - if (FIXNUMP (args_template)) { ptrdiff_t at = XFIXNUM (args_template); @@ -388,17 +495,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, eassert (SYMBOLP (args_template) && args_template == Qnil); - /* Current function being compiled. Return a lips obj. */ + /* Current function being compiled. */ comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); + gcc_jit_block **bb_map = compute_bblocks (bytestr_length, bytestr_data); + + for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); - BBLOCK = gcc_jit_function_new_block(comp.func, NULL); - while (pc < bytestr_length) { + comp.bblock = bb_map[pc]; op = FETCH; switch (op) @@ -747,7 +856,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Bgoto not supported"); break; case Bgotoifnil: - error ("Bgotoifnil not supported"); + POP1; + op = FETCH2; + /* PUSH_PC (op); */ + /* error ("Bgotoifnil not supported"); */ break; case Bgotoifnonnil: error ("Bgotoifnonnil not supported"); @@ -761,7 +873,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Breturn: POP1; - gcc_jit_block_end_with_return(BBLOCK, + gcc_jit_block_end_with_return(comp.bblock, NULL, args[0]); break; @@ -977,6 +1089,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, exit: xfree (stack_base); + xfree (bb_map); return comp_res; } From 2b56339f75811a670a18439fedd17de932662c78 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 26 May 2019 11:02:56 +0200 Subject: [PATCH 0035/1452] adding conditionals --- src/comp.c | 260 ++++++++++++++++++++++++++++------------- test/src/comp-tests.el | 19 +++ 2 files changed, 196 insertions(+), 83 deletions(-) diff --git a/src/comp.c b/src/comp.c index ffc79d1c24b..f9e77b16471 100644 --- a/src/comp.c +++ b/src/comp.c @@ -30,7 +30,7 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" -#define COMP_DEBUG 0 +#define COMP_DEBUG 1 #define MAX_FUN_NAME 256 @@ -43,40 +43,67 @@ along with GNU Emacs. If not, see . */ #define CHECK_STACK \ eassert (stack >= stack_base && stack < stack_over) -#define PUSH(obj) \ - do { \ - CHECK_STACK; \ - *stack = obj; \ - stack++; \ +#define PUSH_LVAL(obj) \ + do { \ + CHECK_STACK; \ + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + NULL, \ + *stack, \ + gcc_jit_lvalue_as_rvalue(obj)); \ + stack++; \ } while (0) +#define PUSH_RVAL(obj) \ + do { \ + CHECK_STACK; \ + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + NULL, \ + *stack, \ + (obj)); \ + stack++; \ + } while (0) + +/* This always happens in the first basic block. */ + +#define PUSH_PARAM(obj) \ + do { \ + CHECK_STACK; \ + gcc_jit_block_add_assignment (bb_map[0].gcc_bb, \ + NULL, \ + *stack, \ + gcc_jit_param_as_rvalue(obj)); \ + stack++; \ + } while (0) + +#define TOS (*(stack - 1)) + #define POP0 -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = *stack; \ +#define POP1 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ } while (0) -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = *stack; \ - stack--; \ - args[0] = *stack; \ +#define POP2 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ } while (0) -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = *stack; \ - stack--; \ - args[1] = *stack; \ - stack--; \ - args[0] = *stack; \ +#define POP3 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[2] = gcc_jit_lvalue_as_rvalue (*stack); \ + stack--; \ + args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ } while (0) /* Fetch the next byte from the bytecode stream. */ @@ -88,10 +115,6 @@ along with GNU Emacs. If not, see . */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) -/* Discard n values from the stack. */ - -#define DISCARD(n) (stack -= (n)) - #define STR(s) #s /* With most of the ops we need to do the same stuff so this macros are meant @@ -103,7 +126,7 @@ along with GNU Emacs. If not, see . */ case B##name: \ POP##nargs; \ res = gcc_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ - PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + PUSH_LVAL (res); \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) @@ -113,9 +136,14 @@ along with GNU Emacs. If not, see . */ do { \ pop (nargs, &stack, args); \ res = gcc_emit_callN (name, nargs, args); \ - PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + PUSH_LVAL (res); \ } while (0) +typedef struct { + gcc_jit_block *gcc_bb; + bool terminated; +} basic_block_t; + /* The compiler context */ typedef struct { @@ -128,7 +156,7 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ - gcc_jit_block *bblock; /* Current basic block */ + basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -136,7 +164,7 @@ static comp_t comp; Lisp_Object scratch_call_area[MAX_ARGS]; -FILE *logfile; +FILE *logfile = NULL; /* The result of one function compilation. */ @@ -145,7 +173,7 @@ typedef struct { short min_args, max_args; } comp_f_res_t; -INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, +INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]); void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, @@ -162,14 +190,14 @@ bcall0 (Lisp_Object f) order. */ INLINE static void -pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) +pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) { - gcc_jit_rvalue **stack = *stack_ref; + gcc_jit_lvalue **stack = *stack_ref; while (n--) { stack--; - args[n] = *stack; + args[n] = gcc_jit_lvalue_as_rvalue (*stack); } *stack_ref = stack; @@ -278,7 +306,7 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, NULL, ret_type, "res"); - gcc_jit_block_add_assignment(comp.bblock, NULL, + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, res, gcc_jit_context_new_call(comp.ctxt, NULL, @@ -312,7 +340,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(comp.bblock, NULL, + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, p, comp.scratch); @@ -322,7 +350,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT), i); - gcc_jit_block_add_assignment (comp.bblock, NULL, + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue(p), @@ -347,13 +375,13 @@ ucmp(const void *a, const void *b) } /* Compute and initialize all basic blocks. */ -static gcc_jit_block ** +static basic_block_t * compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) { ptrdiff_t pc = 0; unsigned op; bool new_bb = true; - gcc_jit_block **bb_map = xmalloc (bytestr_length * sizeof (gcc_jit_block *)); + basic_block_t *bb_map = xmalloc (bytestr_length * sizeof (basic_block_t)); unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); unsigned bb_n = 0; @@ -438,13 +466,14 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* printf ("%d ", bb_start_pc[i]); */ /* printf ("\n"); */ - gcc_jit_block *curr_bb; + basic_block_t curr_bb; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { if (i < bb_n && pc == bb_start_pc[i]) { ++i; - curr_bb = gcc_jit_function_new_block (comp.func, NULL); + curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, NULL); + curr_bb.terminated = false; } bb_map[pc] = curr_bb; } @@ -454,6 +483,27 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) return bb_map; } +/* Close current basic block emitting a conditional. */ + +static gcc_jit_rvalue * +gcc_emit_conditional (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, + NULL, + op, + a, b); + gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, + NULL, + test, + then_target, + else_target); + comp.bblock->terminated = true; + + return test; +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -468,9 +518,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* This is the stack we use to flat the bytecode written for push and pop Emacs VM.*/ - gcc_jit_rvalue **stack_base, **stack, **stack_over; + gcc_jit_lvalue **stack_base, **stack, **stack_over; stack_base = stack = - (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); + (gcc_jit_lvalue **) xmalloc (stack_depth * sizeof (gcc_jit_lvalue *)); stack_over = stack_base + stack_depth; if (FIXNUMP (args_template)) @@ -499,15 +549,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); - gcc_jit_block **bb_map = compute_bblocks (bytestr_length, bytestr_data); + char local_name[256]; + for (int i = 0; i < stack_depth; ++i) + { + snprintf (local_name, sizeof (local_name), "local_%d", i); + stack[i] = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + local_name); + } + basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); + /* basic_block_t *nil_ret_bb = NULL; */ for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); + PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + + comp.bblock = NULL; while (pc < bytestr_length) { - comp.bblock = bb_map[pc]; + /* If we are changing BB and the last was one wasn't terminated + terminate it with a fall through. */ + if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb && + !comp.bblock->terminated) + { + gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, bb_map[pc].gcc_bb); + comp.bblock->terminated = true; + } + comp.bblock = &bb_map[pc]; op = FETCH; switch (op) @@ -518,17 +588,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstack_ref4: case Bstack_ref5: { - PUSH (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); break; } case Bstack_ref6: { - PUSH (stack_base[(stack - stack_base) - FETCH - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); break; } case Bstack_ref7: { - PUSH (stack_base[(stack - stack_base) - FETCH2 - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); break; } @@ -553,7 +623,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; } @@ -584,7 +654,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.int_type, SET_INTERNAL_SET); res = gcc_emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); } break; @@ -610,7 +680,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, vectorp[op]); pop (1, &stack, &args[1]); res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; } @@ -634,7 +704,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); res = gcc_emit_callN ("Ffuncall", nargs, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; } @@ -700,12 +770,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, Qnil); res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); for (int i = 0; i < op; ++i) { POP2; res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); } break; } @@ -795,7 +865,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpreceding_char: res = gcc_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; CASE_CALL_NARGS (current_column, 0); @@ -804,7 +874,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = comp.nil; res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; CASE_CALL_NARGS (eolp, 0); @@ -829,11 +899,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH (gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - intern ("interactive-p"))); + PUSH_RVAL (gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.lisp_obj_type, + intern ("interactive-p"))); res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; CASE_CALL_NARGS (forward_char, 1); @@ -853,37 +923,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bgoto: - error ("Bgoto not supported"); - break; - case Bgotoifnil: - POP1; op = FETCH2; - /* PUSH_PC (op); */ - /* error ("Bgotoifnil not supported"); */ + gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + NULL, + bb_map[op].gcc_bb); + comp.bblock->terminated = true; break; + + case Bgotoifnil: + op = FETCH2; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + break; + case Bgotoifnonnil: - error ("Bgotoifnonnil not supported"); + op = FETCH2; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case Bgotoifnilelsepop: - error ("Bgotoifnilelsepop not supported"); + op = FETCH2; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; + case Bgotoifnonnilelsepop: - error ("Bgotoifnonnilelsepop not supported"); + op = FETCH2; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; case Breturn: POP1; - gcc_jit_block_end_with_return(comp.bblock, + gcc_jit_block_end_with_return(comp.bblock->gcc_bb, NULL, args[0]); + comp.bblock->terminated = true; break; case Bdiscard: - DISCARD (1); + POP1; break; case Bdup: - PUSH (*(stack - 1)); + PUSH_LVAL (TOS); break; case Bsave_excursion: @@ -895,7 +987,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = gcc_emit_call ("helper_save_window_excursion", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; case Bsave_restriction: @@ -934,14 +1026,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = gcc_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; gcc_emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); - PUSH (args[0]); + PUSH_RVAL (args[0]); gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; @@ -1068,7 +1160,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - PUSH (c); + PUSH_RVAL (c); /* Fprint(vectorp[op], Qnil); */ break; } @@ -1088,6 +1180,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Something went wrong"); exit: + /* if (nil_ret_bb) */ + /* xfree (nil_ret_bb); */ xfree (stack_base); xfree (bb_map); return comp_res; @@ -1273,7 +1367,7 @@ release_comp (void) if (comp.ctxt) gcc_jit_context_release(comp.ctxt); - if (COMP_DEBUG) + if (logfile) fclose (logfile); } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 006336393dd..e1d6f313fd7 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -127,6 +127,25 @@ (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))) +(ert-deftest comp-tests-conditionals () + "Testing conditionals." + (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)) + (byte-compile #'comp-tests-conditionals-1-f) + (byte-compile #'comp-tests-conditionals-2-f) + (native-compile #'comp-tests-conditionals-1-f) + (native-compile #'comp-tests-conditionals-2-f) + + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From b3038fa86716edfe9f015c3d0a4c53b9a61c975e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 4 Jun 2019 22:16:19 +0200 Subject: [PATCH 0036/1452] add relative branch ops --- src/comp.c | 41 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index f9e77b16471..e990c6e5762 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1108,21 +1108,52 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bintegerp: error ("Bintegerp not supported"); break; + case BRgoto: - error ("BRgoto not supported"); + op = FETCH - 128; + op += pc; + gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + NULL, + bb_map[op].gcc_bb); + comp.bblock->terminated = true; break; + case BRgotoifnil: - error ("BRgotoifnil not supported"); + op = FETCH - 128; + op += pc; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case BRgotoifnonnil: - error ("BRgotoifnonnil not supported"); + op = FETCH - 128; + op += pc; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case BRgotoifnilelsepop: - error ("BRgotoifnilelsepop not supported"); + op = FETCH - 128; + op += pc; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; + case BRgotoifnonnilelsepop: - error ("BRgotoifnonnilelsepop not supported"); + op = FETCH - 128; + op += pc; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; + case BinsertN: error ("BinsertN not supported"); break; From 5cbb6ad8951e8393c3cd728738214a0c87e149be Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 5 Jun 2019 12:21:40 +0200 Subject: [PATCH 0037/1452] better errors --- src/comp.c | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/comp.c b/src/comp.c index e990c6e5762..48db20a2789 100644 --- a/src/comp.c +++ b/src/comp.c @@ -733,13 +733,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; case Bpophandler: - error ("Bpophandler\n"); + error ("Bpophandler unsupported bytecode\n"); break; case Bpushconditioncase: - error ("Bpushconditioncase\n"); + error ("Bpushconditioncase unsupported bytecode\n"); break; case Bpushcatch: - error ("Bpushcatch\n"); + error ("Bpushcatch unsupported bytecode\n"); break; CASE_CALL_NARGS (nth, 2); @@ -805,31 +805,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsub1: - error ("Bsub1\n"); + error ("Bsub1 unsupported bytecode\n"); break; case Badd1: - error ("Badd1\n"); + error ("Badd1 unsupported bytecode\n"); break; case Beqlsign: - error ("Beqlsign\n"); + error ("Beqlsign unsupported bytecode\n"); break; case Bgtr: - error ("Bgtr\n"); + error ("Bgtr unsupported bytecode\n"); break; case Blss: - error ("Blss\n"); + error ("Blss unsupported bytecode\n"); break; case Bleq: - error ("Bleq\n"); + error ("Bleq unsupported bytecode\n"); break; case Bgeq: - error ("Bgeq\n"); + error ("Bgeq unsupported bytecode\n"); break; case Bdiff: EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: - error ("Bnegate\n"); + error ("Bnegate unsupported bytecode\n"); break; case Bplus: EMIT_SCRATCH_CALL_N ("Fplus", 2); @@ -844,7 +844,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: - error ("Bpoint\n"); + error ("Bpoint unsupported bytecode\n"); break; CASE_CALL_NARGS (goto_char, 1); @@ -854,10 +854,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bpoint_max: - error ("Bpoint_max\n"); + error ("Bpoint_max unsupported bytecode\n"); break; case Bpoint_min: - error ("Bpoint_min\n"); + error ("Bpoint_min unsupported bytecode\n"); break; CASE_CALL_NARGS (char_after, 1); @@ -880,13 +880,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (eolp, 0); case Beobp: - error ("Beobp\n"); + error ("Beobp unsupported bytecode\n"); break; CASE_CALL_NARGS (bolp, 0); case Bbobp: - error ("Bbobp\n"); + error ("Bbobp unsupported bytecode\n"); break; CASE_CALL_NARGS (current_buffer, 0); From 16b2a5471eaa7ae2514398720696b3da12514e84 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 8 Jun 2019 11:52:21 +0200 Subject: [PATCH 0038/1452] add some new constant --- src/comp.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 48db20a2789..8a88e5819c7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -150,12 +150,16 @@ typedef struct { gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *int_type; + gcc_jit_type *long_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ + gcc_jit_rvalue *most_positive_fixnum; + gcc_jit_rvalue *most_negative_fixnum; + gcc_jit_rvalue *one; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -1348,9 +1352,21 @@ init_comp (void) comp.void_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID); comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + comp.long_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG); comp.void_ptr_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); - + comp.most_positive_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_type, /* FIXME? */ + MOST_POSITIVE_FIXNUM); + comp.most_negative_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_type, /* FIXME? */ + MOST_NEGATIVE_FIXNUM); + comp.one = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.lisp_obj_type, + 1); enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) ptrdiff_t_gcc = GCC_JIT_TYPE_INT; From b8aeb2e35d99e14970d15561fcf161ce78fd2426 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 8 Jun 2019 15:45:27 +0200 Subject: [PATCH 0039/1452] move to lispobj as union --- src/comp.c | 133 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 85 insertions(+), 48 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8a88e5819c7..ddc0bd067f3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -151,11 +151,13 @@ typedef struct { gcc_jit_type *void_type; gcc_jit_type *int_type; gcc_jit_type *long_type; + gcc_jit_type *long_long_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; + gcc_jit_field *lisp_obj_as_ptr; + gcc_jit_field *lisp_obj_as_num; gcc_jit_function *func; /* Current function being compiled */ - gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -207,6 +209,32 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) *stack_ref = stack; } +/* Construct fill and return a lisp object form a raw pointer. */ + +INLINE static gcc_jit_rvalue * +gcc_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) +{ + gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj"); + gcc_jit_lvalue *lisp_obj_as_ptr = + gcc_jit_lvalue_access_field (lisp_obj, + NULL, + comp.lisp_obj_as_ptr); + + gcc_jit_rvalue *void_ptr = + gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + p); + + gcc_jit_block_add_assignment (bblock->gcc_bb, + NULL, + lisp_obj_as_ptr, + void_ptr); + return gcc_jit_lvalue_as_rvalue (lisp_obj); +} + static gcc_jit_function * gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, @@ -564,11 +592,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); - /* basic_block_t *nil_ret_bb = NULL; */ for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + gcc_jit_rvalue *nil = gcc_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); + comp.bblock = NULL; while (pc < bytestr_length) @@ -623,9 +652,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -650,10 +677,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); - args[2] = comp.nil; + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -679,9 +704,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); @@ -770,9 +793,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, make_list: { POP1; - args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - Qnil); + args[1] = nil; res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); for (int i = 0; i < op; ++i) @@ -876,7 +897,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; - args[1] = comp.nil; + args[1] = nil; res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -903,9 +924,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.lisp_obj_type, - intern ("interactive-p"))); + PUSH_RVAL (gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, + intern ("interactive-p"))); res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -937,14 +957,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; @@ -952,7 +972,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -961,7 +981,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; gcc_emit_conditional (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -995,9 +1015,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_restriction: - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - save_restriction_restore); + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, + save_restriction_restore); args[1] = gcc_jit_lvalue_as_rvalue (gcc_emit_call ("save_restriction_save", comp.lisp_obj_type, @@ -1009,9 +1028,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - eval_sub); + args[1] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); gcc_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -1126,7 +1143,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; @@ -1134,7 +1151,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; @@ -1143,7 +1160,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1153,7 +1170,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; gcc_emit_conditional (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1192,9 +1209,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); + gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); /* Fprint(vectorp[op], Qnil); */ break; @@ -1342,19 +1357,44 @@ init_comp (void) { comp.ctxt = gcc_jit_context_acquire(); + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); + comp.void_ptr_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); + comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_LONG_LONG); + #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); + #else /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); #endif - comp.void_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID); - comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); - comp.long_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG); - comp.void_ptr_type = - gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; + comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "LispObj", + 2, + lisp_obj_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.long_type, /* FIXME? */ @@ -1365,8 +1405,9 @@ init_comp (void) MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.lisp_obj_type, + comp.int_type, 1); + enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) ptrdiff_t_gcc = GCC_JIT_TYPE_INT; @@ -1379,10 +1420,6 @@ init_comp (void) comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); - comp.nil = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - Qnil); - comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, From e642113184136a66fee782c3cdec832ec2ba4c0b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 8 Jun 2019 16:00:24 +0200 Subject: [PATCH 0040/1452] remame compiler functions --- src/comp.c | 196 ++++++++++++++++++++++++++--------------------------- 1 file changed, 98 insertions(+), 98 deletions(-) diff --git a/src/comp.c b/src/comp.c index ddc0bd067f3..c675095cece 100644 --- a/src/comp.c +++ b/src/comp.c @@ -40,7 +40,7 @@ along with GNU Emacs. If not, see . */ #define DISASS_FILE_NAME "emacs-asm.s" -#define CHECK_STACK \ +#define CHECK_STACK \ eassert (stack >= stack_base && stack < stack_over) #define PUSH_LVAL(obj) \ @@ -125,7 +125,7 @@ along with GNU Emacs. If not, see . */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ POP##nargs; \ - res = gcc_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + res = comp_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ PUSH_LVAL (res); \ break @@ -135,7 +135,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_SCRATCH_CALL_N(name, nargs) \ do { \ pop (nargs, &stack, args); \ - res = gcc_emit_callN (name, nargs, args); \ + res = comp_emit_callN (name, nargs, args); \ PUSH_LVAL (res); \ } while (0) @@ -193,7 +193,7 @@ bcall0 (Lisp_Object f) } /* Pop form the main evaluation stack and place the elements in args in reversed - order. */ + order. */ INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) @@ -212,11 +212,11 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) /* Construct fill and return a lisp object form a raw pointer. */ INLINE static gcc_jit_rvalue * -gcc_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) +comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) { gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, + NULL, + comp.lisp_obj_type, "lisp_obj"); gcc_jit_lvalue *lisp_obj_as_ptr = gcc_jit_lvalue_access_field (lisp_obj, @@ -236,9 +236,9 @@ gcc_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) } static gcc_jit_function * -gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) +comp_func_declare (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; gcc_jit_type *type[4]; @@ -315,8 +315,8 @@ gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, } static gcc_jit_lvalue * -gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) +comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, + gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); EMACS_UINT hash = 0; @@ -325,8 +325,8 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - gcc_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, - true); + comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + true); i = hash_lookup (ht, key, &hash); eassert (i != -1); } @@ -349,21 +349,21 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ /* - Lisp_Object *p; - p = scratch_call_area; + Lisp_Object *p; + p = scratch_call_area; - p[0] = nargs; - p[1] = 0x...; - . - . - . - p[n] = 0x...; + p[0] = nargs; + p[1] = 0x...; + . + . + . + p[n] = 0x...; */ gcc_jit_lvalue *p = @@ -395,7 +395,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) nargs); args[1] = comp.scratch; - return gcc_emit_call (f_name, comp.lisp_obj_type, 2, args); + return comp_emit_call (f_name, comp.lisp_obj_type, 2, args); } static int @@ -518,9 +518,9 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* Close current basic block emitting a conditional. */ static gcc_jit_rvalue * -gcc_emit_conditional (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) +comp_emit_conditional (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, NULL, @@ -578,8 +578,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. */ - comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); + comp.func = comp_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); char local_name[256]; for (int i = 0; i < stack_depth; ++i) @@ -596,7 +596,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - gcc_jit_rvalue *nil = gcc_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); + gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); comp.bblock = NULL; @@ -652,8 +652,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); - res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; } @@ -677,12 +677,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = gcc_emit_call ("set_internal", comp.lisp_obj_type, 4, args); + res = comp_emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH_LVAL (res); } break; @@ -704,9 +704,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); - res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; } @@ -730,7 +730,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = gcc_emit_callN ("Ffuncall", nargs, args); + res = comp_emit_callN ("Ffuncall", nargs, args); PUSH_LVAL (res); break; } @@ -756,7 +756,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -794,12 +794,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = nil; - res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); for (int i = 0; i < op; ++i) { POP2; - res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); } break; @@ -889,7 +889,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = gcc_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); + res = comp_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_LVAL (res); break; @@ -898,7 +898,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; args[1] = nil; - res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -919,14 +919,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - gcc_emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); + comp_emit_call ("record_unwind_current_buffer", + comp.void_type, 0, NULL); break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, - intern ("interactive-p"))); - res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); + PUSH_RVAL (comp_lisp_obj_as_ptr_from_ptr (comp.bblock, + intern ("interactive-p"))); + res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -957,32 +957,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1003,59 +1003,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - res = gcc_emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); + res = comp_emit_call ("record_unwind_protect_excursion", + comp.void_type, 0, args); break; case Bsave_window_excursion: /* Obsolete since 24.1. */ POP1; - res = gcc_emit_call ("helper_save_window_excursion", - comp.lisp_obj_type, 1, args); + res = comp_emit_call ("helper_save_window_excursion", + comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; case Bsave_restriction: - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, - save_restriction_restore); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, + save_restriction_restore); args[1] = - gcc_jit_lvalue_as_rvalue (gcc_emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL)); - gcc_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL)); + comp_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); - gcc_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + args[1] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); + comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ POP1; - gcc_emit_call ("helper_unwind_protect", comp.void_type, 1, args); + comp_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; case Bcondition_case: /* Obsolete since 24.4. */ POP3; - gcc_emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); + comp_emit_call ("internal_lisp_condition_case", + comp.lisp_obj_type, 3, args); break; case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ POP1; - res = gcc_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, - 1, args); + res = comp_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, + 1, args); PUSH_LVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; - gcc_emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); + comp_emit_call ("temp_output_buffer_show", comp.void_type, 1, + &args[1]); PUSH_RVAL (args[0]); - gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; case Bunbind_all: /* Obsolete. Never used. */ @@ -1143,35 +1143,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1209,7 +1209,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); /* Fprint(vectorp[op], Qnil); */ break; @@ -1422,11 +1422,11 @@ init_comp (void) comp.scratch = gcc_jit_lvalue_get_address( - gcc_jit_context_new_global (comp.ctxt, NULL, - GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj_type, - "scratch_call_area"), - NULL); + gcc_jit_context_new_global (comp.ctxt, NULL, + GCC_JIT_GLOBAL_IMPORTED, + comp.lisp_obj_type, + "scratch_call_area"), + NULL); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); From 1e9bd1df4c1def12750b2ce6dc335c1921a21686 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 8 Jun 2019 17:24:29 +0200 Subject: [PATCH 0041/1452] adding sub1 --- src/comp.c | 116 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 81 insertions(+), 35 deletions(-) diff --git a/src/comp.c b/src/comp.c index c675095cece..e46cd5cfecf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -475,7 +475,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) bb_start_pc[bb_n++] = op; new_bb = true; break; - /* Return */ + case Bsub1: case Breturn: new_bb = true; break; @@ -517,21 +517,32 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* Close current basic block emitting a conditional. */ -static gcc_jit_rvalue * +static void comp_emit_conditional (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { - gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, - NULL, - op, - a, b); gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, NULL, test, then_target, else_target); comp.bblock->terminated = true; +} + +/* Close current basic block emitting a comparison between two rval. */ + +static gcc_jit_rvalue * +comp_emit_comparison (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, + NULL, + op, + a, b); + + comp_emit_conditional (op, test, then_target, else_target); return test; } @@ -830,7 +841,42 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsub1: - error ("Bsub1 unsupported bytecode\n"); + { + gcc_jit_block *sub1_inline = + gcc_jit_function_new_block (comp.func, "-1 inline"); + gcc_jit_block *sub1_fcall = + gcc_jit_function_new_block (comp.func, "-1 fcall"); + + gcc_jit_rvalue *tos_as_num = + gcc_jit_rvalue_access_field (gcc_jit_lvalue_as_rvalue (TOS), + NULL, + comp.lisp_obj_as_num); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_negative_fixnum, + sub1_inline, sub1_fcall); + gcc_jit_rvalue *sub1_inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.lisp_obj_type, + tos_as_num, + comp.one); + gcc_jit_block_add_assignment (sub1_inline, + NULL, + TOS, + sub1_inline_res); + + /* TODO fill sub1_fcall */ + /* comp.bblock->gcc_bb = sub1_fcall; */ + /* comp.bblock->terminated = false; */ + + gcc_jit_block_end_with_jump (sub1_inline, NULL, + bb_map[pc].gcc_bb); + gcc_jit_block_end_with_jump (sub1_fcall, NULL, + bb_map[pc].gcc_bb); + } + break; case Badd1: error ("Badd1 unsupported bytecode\n"); @@ -957,32 +1003,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1143,35 +1189,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1397,15 +1443,15 @@ init_comp (void) lisp_obj_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_type, /* FIXME? */ + comp.long_long_type, /* FIXME? */ MOST_POSITIVE_FIXNUM); comp.most_negative_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_type, /* FIXME? */ + comp.long_long_type, /* FIXME? */ MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, + comp.long_long_type, /* FIXME? */ 1); enum gcc_jit_types ptrdiff_t_gcc; From 34d1a15307a4cb1f667e8af6ecca523369c436c1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 8 Jun 2019 17:24:47 +0200 Subject: [PATCH 0042/1452] fix uninitialized read --- src/comp.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index e46cd5cfecf..44d9a783f0e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1355,9 +1355,13 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, /* FIXME how many other characters are not allowed in C? This will introduce name clashs too. */ - for (int i; i < strlen(c_f_name); i++) - if (c_f_name[i] == '-') - c_f_name[i] = '_'; + char *c = c_f_name; + while (*c) + { + if (*c == '-') + *c = '_'; + ++c; + } func = indirect_function (func); if (!COMPILEDP (func)) From efd20b8c4bec0b6edfeb0c415719cb7b230496ba Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 9 Jun 2019 16:58:54 +0200 Subject: [PATCH 0043/1452] add comp_xfixnum + comp_make_fixnum --- src/comp.c | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 60 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 44d9a783f0e..12d952ca2a1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -162,6 +162,8 @@ typedef struct { gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; + gcc_jit_rvalue *inttypebits; + gcc_jit_rvalue *lisp_int0; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -209,6 +211,54 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) *stack_ref = stack; } +INLINE static gcc_jit_rvalue * +comp_xfixnum (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num), + comp.inttypebits); +} + +INLINE static gcc_jit_rvalue * +comp_make_fixnum (gcc_jit_rvalue *obj) +{ + gcc_jit_rvalue *tmp = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.long_long_type, + obj, + comp.inttypebits); + + tmp = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.long_long_type, + tmp, + comp.lisp_int0); + + gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj_fixnum"); + + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + gcc_jit_lvalue_access_field ( + res, + NULL, + comp.lisp_obj_as_num), + tmp); + + return gcc_jit_lvalue_as_rvalue (res); +} + /* Construct fill and return a lisp object form a raw pointer. */ INLINE static gcc_jit_rvalue * @@ -217,7 +267,7 @@ comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - "lisp_obj"); + "lisp_obj_from_ptr"); gcc_jit_lvalue *lisp_obj_as_ptr = gcc_jit_lvalue_access_field (lisp_obj, NULL, @@ -1457,6 +1507,15 @@ init_comp (void) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, /* FIXME? */ 1); + comp.inttypebits = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + INTTYPEBITS); + + comp.lisp_int0 = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + Lisp_Int0); enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) From 96fc40d7dbdc77efa7b2e01f231bef9e19e96786 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 9 Jun 2019 16:59:34 +0200 Subject: [PATCH 0044/1452] generate reproducer if needed --- src/comp.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/comp.c b/src/comp.c index 12d952ca2a1..63bf88870bd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1457,6 +1457,9 @@ init_comp (void) { comp.ctxt = gcc_jit_context_acquire(); + if (COMP_DEBUG > 1) + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); From 8bfe8ce8d0885e8022b2bea82d1cff9cbed86fb1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 9 Jun 2019 17:01:06 +0200 Subject: [PATCH 0045/1452] add sub1 --- src/comp.c | 289 ++++++++++++++++++++++++++++++++--------- test/src/comp-tests.el | 16 +++ 2 files changed, 241 insertions(+), 64 deletions(-) diff --git a/src/comp.c b/src/comp.c index 63bf88870bd..0098b814581 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,7 +149,9 @@ typedef struct { typedef struct { gcc_jit_context *ctxt; gcc_jit_type *void_type; + gcc_jit_type *bool_type; gcc_jit_type *int_type; + gcc_jit_type *unsigned_type; gcc_jit_type *long_type; gcc_jit_type *long_long_type; gcc_jit_type *void_ptr_type; @@ -157,6 +159,13 @@ typedef struct { gcc_jit_type *lisp_obj_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* libgccjit has really limited support for casting therefore this union will + be used for the scope. */ + gcc_jit_type *cast_union_type; + gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_u; + gcc_jit_field *cast_union_as_i; + gcc_jit_field *cast_union_as_b; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_rvalue *most_positive_fixnum; @@ -211,22 +220,118 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) *stack_ref = stack; } -INLINE static gcc_jit_rvalue * -comp_xfixnum (gcc_jit_rvalue *obj) +INLINE static gcc_jit_field * +type_to_cast_field (gcc_jit_type *type) { - return gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, - gcc_jit_rvalue_access_field (obj, - NULL, - comp.lisp_obj_as_num), - comp.inttypebits); + gcc_jit_field *field; + + if (type == comp.long_long_type) + field = comp.cast_union_as_ll; + else if (type == comp.unsigned_type) + field = comp.cast_union_as_u; + else if (type == comp.int_type) + field = comp.cast_union_as_i; + else if (type == comp.bool_type) + field = comp.cast_union_as_b; + else + error ("unsopported cast\n"); + + return field; +} + +static gcc_jit_rvalue * +comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +{ + gcc_jit_field *orig_field = + type_to_cast_field (gcc_jit_rvalue_get_type (obj)); + gcc_jit_field *dest_field = type_to_cast_field (new_type); + + gcc_jit_lvalue *tmp_u = + gcc_jit_function_new_local (comp.func, + NULL, + comp.cast_union_type, + "union_cast"); + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + gcc_jit_lvalue_access_field (tmp_u, + NULL, + orig_field), + obj); + + return gcc_jit_rvalue_access_field ( gcc_jit_lvalue_as_rvalue (tmp_u), + NULL, + dest_field); } INLINE static gcc_jit_rvalue * -comp_make_fixnum (gcc_jit_rvalue *obj) +comp_XLI (gcc_jit_rvalue *obj) +{ + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num); +} + +static gcc_jit_rvalue * +comp_FIXNUMP (gcc_jit_rvalue *obj) +{ + /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + & ((1 << INTTYPEBITS) - 1))) */ + + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + comp_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, + (USE_LSB_TAG ? 0 : FIXNUM_BITS))); + + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + comp_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +comp_XFIXNUM (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + comp_XLI (obj), + comp.inttypebits); +} + +static gcc_jit_rvalue * +comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -248,7 +353,7 @@ comp_make_fixnum (gcc_jit_rvalue *obj) comp.lisp_obj_type, "lisp_obj_fixnum"); - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (block, NULL, gcc_jit_lvalue_access_field ( res, @@ -261,7 +366,7 @@ comp_make_fixnum (gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ -INLINE static gcc_jit_rvalue * +static gcc_jit_rvalue * comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) { gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, @@ -567,9 +672,8 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* Close current basic block emitting a conditional. */ -static void -comp_emit_conditional (enum gcc_jit_comparison op, - gcc_jit_rvalue *test, +INLINE static void +comp_emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, @@ -583,16 +687,16 @@ comp_emit_conditional (enum gcc_jit_comparison op, /* Close current basic block emitting a comparison between two rval. */ static gcc_jit_rvalue * -comp_emit_comparison (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) +comp_emit_comp_jump (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, NULL, op, a, b); - comp_emit_conditional (op, test, then_target, else_target); + comp_emit_cond_jump (test, then_target, else_target); return test; } @@ -892,38 +996,60 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsub1: { - gcc_jit_block *sub1_inline = - gcc_jit_function_new_block (comp.func, "-1 inline"); - gcc_jit_block *sub1_fcall = - gcc_jit_function_new_block (comp.func, "-1 fcall"); + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)) */ + + gcc_jit_block *sub1_inline_block = + gcc_jit_function_new_block (comp.func, "inline-1"); + gcc_jit_block *sub1_fcall_block = + gcc_jit_function_new_block (comp.func, "fcall-1"); gcc_jit_rvalue *tos_as_num = - gcc_jit_rvalue_access_field (gcc_jit_lvalue_as_rvalue (TOS), - NULL, - comp.lisp_obj_as_num); - comp_emit_comparison (GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum, - sub1_inline, sub1_fcall); + comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + + comp_emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + comp_cast (comp.bool_type, + comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_negative_fixnum)), + sub1_inline_block, + sub1_fcall_block); + gcc_jit_rvalue *sub1_inline_res = gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_MINUS, - comp.lisp_obj_type, + comp.long_long_type, tos_as_num, comp.one); - gcc_jit_block_add_assignment (sub1_inline, + + gcc_jit_block_add_assignment (sub1_inline_block, NULL, TOS, - sub1_inline_res); + comp_make_fixnum (sub1_inline_block, + sub1_inline_res)); + basic_block_t bb_orig = *comp.bblock; - /* TODO fill sub1_fcall */ - /* comp.bblock->gcc_bb = sub1_fcall; */ - /* comp.bblock->terminated = false; */ + comp.bblock->gcc_bb = sub1_fcall_block; + POP1; + res = comp_emit_call ("Fsub1", comp.lisp_obj_type, 1, args); + PUSH_LVAL (res); - gcc_jit_block_end_with_jump (sub1_inline, NULL, + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (sub1_inline_block, NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall, NULL, + gcc_jit_block_end_with_jump (sub1_fcall_block, NULL, bb_map[pc].gcc_bb); } @@ -1053,32 +1179,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1239,35 +1365,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1464,6 +1590,9 @@ init_comp (void) comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); @@ -1498,6 +1627,38 @@ init_comp (void) "LispObj", 2, lisp_obj_fields); + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, /* FIXME? */ + "ll"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + + gcc_jit_field *cast_union_fields[4] = + { comp.cast_union_as_ll, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b,}; + comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + 4, + cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.long_long_type, /* FIXME? */ diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e1d6f313fd7..e13db89ddc6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -146,6 +146,22 @@ (should (= (comp-tests-conditionals-2-f t) 1340)) (should (eq (comp-tests-conditionals-2-f nil) nil))) +(ert-deftest comp-tests-fixnum () + "Testing some fixnum inline operation." + (defun comp-tests-fixnum-1-f (x) + (1- x)) + + (byte-compile #'comp-tests-fixnum-1-f) + (native-compile #'comp-tests-fixnum-1-f) + + (should (= (comp-tests-fixnum-1-f 10) 9)) + (should (= (comp-tests-fixnum-1-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1-f 'a) + (error (print err))) + '(wrong-type-argument number-or-marker-p a)))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From a5803441934b5a128f02169c37e4e00b25b4fc10 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 10 Jun 2019 10:08:03 +0200 Subject: [PATCH 0046/1452] add speed parameter --- src/comp.c | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0098b814581..7de222b5b2b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -30,6 +30,8 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" +#define DEFAULT_SPEED 2 /* From 0 to 3 map to gcc -O */ + #define COMP_DEBUG 1 #define MAX_FUN_NAME 256 @@ -194,7 +196,7 @@ INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]); void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, bool dump_asm); + Lisp_Object func, int opt_level, bool dump_asm); static void @@ -1461,7 +1463,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, bool dump_asm) + Lisp_Object func, int opt_level, bool dump_asm) { Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); CHECK_STRING (bytestr); @@ -1487,6 +1489,10 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, sigset_t oldset; block_atimers (&oldset); + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + opt_level); + comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), XFIXNAT (maxdepth) + 1, vectorp, ASIZE (vector), @@ -1512,9 +1518,9 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, } DEFUN ("native-compile", Fnative_compile, Snative_compile, - 1, 2, 0, + 1, 3, 0, doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ - (Lisp_Object func, Lisp_Object disassemble) + (Lisp_Object func, Lisp_Object speed, Lisp_Object disassemble) { static char c_f_name[MAX_FUN_NAME]; char *lisp_f_name; @@ -1543,7 +1549,20 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, if (!COMPILEDP (func)) error ("Not a byte-compiled function"); - emacs_native_compile (lisp_f_name, c_f_name, func, disassemble != Qnil); + if (speed != Qnil && + (!FIXNUMP (speed) || + !(XFIXNUM (speed) >= 0 && + XFIXNUM (speed) <= 3))) + error ("opt-level must be number between 0 and 3"); + + int opt_level; + if (speed == Qnil) + opt_level = DEFAULT_SPEED; + else + opt_level = XFIXNUM (speed); + + emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, + disassemble != Qnil); if (disassemble) { From f867699b23ad012ad71f08f88ecf3e0e8df045da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 10 Jun 2019 10:33:25 +0200 Subject: [PATCH 0047/1452] allow + in lisp functions to be compiled --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 7de222b5b2b..ede417c794f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1540,7 +1540,8 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, char *c = c_f_name; while (*c) { - if (*c == '-') + if (*c == '-' || + *c == '+') *c = '_'; ++c; } From 097f36bc75a6570e64f80451ae4bbe2172d610e0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 10 Jun 2019 10:34:04 +0200 Subject: [PATCH 0048/1452] add Badd1 support --- src/comp.c | 63 ++++++++++++++++++++++++++++++++++++++++-- test/src/comp-tests.el | 25 ++++++++++++----- 2 files changed, 78 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index ede417c794f..3cb51892959 100644 --- a/src/comp.c +++ b/src/comp.c @@ -633,6 +633,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) new_bb = true; break; case Bsub1: + case Badd1: case Breturn: new_bb = true; break; @@ -1004,9 +1005,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, : Fsub1 (TOP)) */ gcc_jit_block *sub1_inline_block = - gcc_jit_function_new_block (comp.func, "inline-1"); + gcc_jit_function_new_block (comp.func, "inline_sub1"); gcc_jit_block *sub1_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall-1"); + gcc_jit_function_new_block (comp.func, "fcall_sub1"); gcc_jit_rvalue *tos_as_num = comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -1057,7 +1058,63 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Badd1: - error ("Badd1 unsupported bytecode\n"); + { + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd (TOP)) */ + + gcc_jit_block *add1_inline_block = + gcc_jit_function_new_block (comp.func, "inline_add1"); + gcc_jit_block *add1_fcall_block = + gcc_jit_function_new_block (comp.func, "fcall_add1"); + + gcc_jit_rvalue *tos_as_num = + comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + + comp_emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + comp_cast (comp.bool_type, + comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_positive_fixnum)), + add1_inline_block, + add1_fcall_block); + + gcc_jit_rvalue *add1_inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.long_long_type, + tos_as_num, + comp.one); + + gcc_jit_block_add_assignment (add1_inline_block, + NULL, + TOS, + comp_make_fixnum (add1_inline_block, + add1_inline_res)); + basic_block_t bb_orig = *comp.bblock; + + comp.bblock->gcc_bb = add1_fcall_block; + POP1; + res = comp_emit_call ("Fadd1", comp.lisp_obj_type, 1, args); + PUSH_LVAL (res); + + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (add1_inline_block, NULL, + bb_map[pc].gcc_bb); + gcc_jit_block_end_with_jump (add1_fcall_block, NULL, + bb_map[pc].gcc_bb); + } break; case Beqlsign: error ("Beqlsign unsupported bytecode\n"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e13db89ddc6..06c7697be74 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -148,18 +148,29 @@ (ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." - (defun comp-tests-fixnum-1-f (x) + (defun comp-tests-fixnum-1--f (x) (1- x)) + (defun comp-tests-fixnum-1+-f (x) + (1+ x)) - (byte-compile #'comp-tests-fixnum-1-f) - (native-compile #'comp-tests-fixnum-1-f) + (byte-compile #'comp-tests-fixnum-1--f) + (byte-compile #'comp-tests-fixnum-1+-f) + ;; (native-compile #'comp-tests-fixnum-1--f) + (native-compile #'comp-tests-fixnum-1+-f) - (should (= (comp-tests-fixnum-1-f 10) 9)) - (should (= (comp-tests-fixnum-1-f most-negative-fixnum) + (should (= (comp-tests-fixnum-1--f 10) 9)) + (should (= (comp-tests-fixnum-1--f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err - (comp-tests-fixnum-1-f 'a) - (error (print err))) + (comp-tests-fixnum-1--f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-1+-f 10) 11)) + (should (= (comp-tests-fixnum-1+-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1+-f 'a) + (error err)) '(wrong-type-argument number-or-marker-p a)))) (ert-deftest comp-tests-gc () From 65eb55ff4194c67ede020ceabd7b92e7d2128908 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 10 Jun 2019 10:38:14 +0200 Subject: [PATCH 0049/1452] code cleanup --- src/comp.c | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3cb51892959..d92e4822266 100644 --- a/src/comp.c +++ b/src/comp.c @@ -652,10 +652,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) bb_n = j + 1; } - /* for (int i = 0; i < bb_n; i++) */ - /* printf ("%d ", bb_start_pc[i]); */ - /* printf ("\n"); */ - basic_block_t curr_bb; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { @@ -1492,7 +1488,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue *c = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); - /* Fprint(vectorp[op], Qnil); */ break; } @@ -1511,8 +1506,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Something went wrong"); exit: - /* if (nil_ret_bb) */ - /* xfree (nil_ret_bb); */ xfree (stack_base); xfree (bb_map); return comp_res; From 7ce2c17a0fbde3203f311c6b91d8bb2ba77adeda Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 10 Jun 2019 11:02:47 +0200 Subject: [PATCH 0050/1452] add Bnegate support --- src/comp.c | 63 ++++++++++++++++++++++++++++++++++++++---- test/src/comp-tests.el | 38 +++++++++++++++++-------- 2 files changed, 84 insertions(+), 17 deletions(-) diff --git a/src/comp.c b/src/comp.c index d92e4822266..712fd01af07 100644 --- a/src/comp.c +++ b/src/comp.c @@ -634,6 +634,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) break; case Bsub1: case Badd1: + case Bnegate: case Breturn: new_bb = true; break; @@ -997,8 +998,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)) */ gcc_jit_block *sub1_inline_block = gcc_jit_function_new_block (comp.func, "inline_sub1"); @@ -1057,8 +1058,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd (TOP)) */ gcc_jit_block *add1_inline_block = gcc_jit_function_new_block (comp.func, "inline_add1"); @@ -1131,7 +1132,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: - error ("Bnegate unsupported bytecode\n"); + { + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) + : Fminus (1, &TOP)) */ + + gcc_jit_block *negate_inline_block = + gcc_jit_function_new_block (comp.func, "inline_negate"); + gcc_jit_block *negate_fcall_block = + gcc_jit_function_new_block (comp.func, "fcall_negate"); + + gcc_jit_rvalue *tos_as_num = + comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + + comp_emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + comp_cast (comp.bool_type, + comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_negative_fixnum)), + negate_inline_block, + negate_fcall_block); + + gcc_jit_rvalue *negate_inline_res = + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_MINUS, + comp.long_long_type, + tos_as_num); + + gcc_jit_block_add_assignment (negate_inline_block, + NULL, + TOS, + comp_make_fixnum (negate_inline_block, + negate_inline_res)); + basic_block_t bb_orig = *comp.bblock; + + comp.bblock->gcc_bb = negate_fcall_block; + EMIT_SCRATCH_CALL_N ("Fminus", 1); + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (negate_inline_block, NULL, + bb_map[pc].gcc_bb); + gcc_jit_block_end_with_jump (negate_fcall_block, NULL, + bb_map[pc].gcc_bb); + } break; case Bplus: EMIT_SCRATCH_CALL_N ("Fplus", 2); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 06c7697be74..dc2c396392b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -148,28 +148,42 @@ (ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." - (defun comp-tests-fixnum-1--f (x) + (defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 (1- x)) - (defun comp-tests-fixnum-1+-f (x) + (defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 (1+ x)) + (defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) - (byte-compile #'comp-tests-fixnum-1--f) - (byte-compile #'comp-tests-fixnum-1+-f) - ;; (native-compile #'comp-tests-fixnum-1--f) - (native-compile #'comp-tests-fixnum-1+-f) + (byte-compile #'comp-tests-fixnum-1-minus-f) + (byte-compile #'comp-tests-fixnum-1-plus-f) + (byte-compile #'comp-tests-fixnum-minus-f) + (native-compile #'comp-tests-fixnum-1-minus-f) + (native-compile #'comp-tests-fixnum-1-plus-f) + (native-compile #'comp-tests-fixnum-minus-f) - (should (= (comp-tests-fixnum-1--f 10) 9)) - (should (= (comp-tests-fixnum-1--f most-negative-fixnum) + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err - (comp-tests-fixnum-1--f 'a) + (comp-tests-fixnum-1-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-1+-f 10) 11)) - (should (= (comp-tests-fixnum-1+-f most-positive-fixnum) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) (should (equal (condition-case err - (comp-tests-fixnum-1+-f 'a) + (comp-tests-fixnum-1-plus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a)))) From 5c406adac75e1b007545991fb7f20068bcaa5b22 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 11 Jun 2019 23:40:29 +0200 Subject: [PATCH 0051/1452] add arithmetic comparisons --- src/comp.c | 31 ++++++++++++++++++++-------- test/src/comp-tests.el | 46 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 712fd01af07..1c2a5818be0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -141,6 +141,17 @@ along with GNU Emacs. If not, see . */ PUSH_LVAL (res); \ } while (0) +#define EMIT_ARITHCOMPARE(comparison) \ + do { \ + POP2; \ + args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ + comp.int_type, \ + comparison); \ + res = comp_emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ + PUSH_LVAL (res); \ + } while (0) + + typedef struct { gcc_jit_block *gcc_bb; bool terminated; @@ -192,9 +203,6 @@ typedef struct { short min_args, max_args; } comp_f_res_t; -INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, - gcc_jit_rvalue *args[]); - void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); @@ -1113,24 +1121,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb); } break; + case Beqlsign: - error ("Beqlsign unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_EQUAL); break; + case Bgtr: - error ("Bgtr unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_GRTR); break; + case Blss: - error ("Blss unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_LESS); break; + case Bleq: - error ("Bleq unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); break; + case Bgeq: - error ("Bgeq unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); break; + case Bdiff: EMIT_SCRATCH_CALL_N ("Fminus", 2); break; + case Bnegate: { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dc2c396392b..f83fa8c8be9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -187,6 +187,52 @@ (error err)) '(wrong-type-argument number-or-marker-p a)))) +(ert-deftest comp-tests-arith-comp () + "Testing arithmetic comparisons." + (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)) + + (byte-compile #'comp-tests-eqlsign-f) + (byte-compile #'comp-tests-gtr-f) + (byte-compile #'comp-tests-lss-f) + (byte-compile #'comp-tests-les-f) + (byte-compile #'comp-tests-geq-f) + + (native-compile #'comp-tests-eqlsign-f) + (native-compile #'comp-tests-gtr-f) + (native-compile #'comp-tests-lss-f) + (native-compile #'comp-tests-les-f) + (native-compile #'comp-tests-geq-f) + + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 3ee58c64e57cde232a062cb199688b2686488ef1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 11 Jun 2019 23:47:16 +0200 Subject: [PATCH 0052/1452] add setcar setcdr --- src/comp.c | 11 +++++++++-- test/src/comp-tests.el | 17 +++++++++++++++++ 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1c2a5818be0..aa4bb7fa45c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1447,12 +1447,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bnreverse: error ("Bnreverse not supported"); break; + case Bsetcar: - error ("Bsetcar not supported"); + POP2; + res = comp_emit_call ("Fsetcar", comp.lisp_obj_type, 2, args); + PUSH_LVAL (res); break; + case Bsetcdr: - error ("Bsetcdr not supported"); + POP2; + res = comp_emit_call ("Fsetcdr", comp.lisp_obj_type, 2, args); + PUSH_LVAL (res); break; + case Bcar_safe: error ("Bcar_safe not supported"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f83fa8c8be9..e7d5ca67f47 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -233,6 +233,23 @@ (should (eq (comp-tests-geq-f 3 3) t)) (should (eq (comp-tests-geq-f 2 3) nil))) +(ert-deftest comp-tests-setcarcdr () + "Testing setcar setcdr." + (defun comp-tests-setcar-f (x y) + (setcar x y) + x) + (defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + + (byte-compile #'comp-tests-setcar-f) + (byte-compile #'comp-tests-setcdr-f) + (native-compile #'comp-tests-setcar-f) + (native-compile #'comp-tests-setcdr-f) + + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From edcadf5c440a95c0c6a564d89eb9beac64e229fc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 12 Jun 2019 03:36:31 +0200 Subject: [PATCH 0053/1452] add Bstack_set --- src/comp.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index aa4bb7fa45c..5fd11e7a7ee 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1530,9 +1530,18 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case BinsertN: error ("BinsertN not supported"); break; + case Bstack_set: - error ("Bstack_set not supported"); + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ + op = FETCH; + POP1; + if (op > 0) + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + *(stack - op), + args[0]); break; + case Bstack_set2: error ("Bstack_set2 not supported"); break; From 203b6ce9fa148ca05fc2688a8a1a607dc922acd7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 12 Jun 2019 03:36:46 +0200 Subject: [PATCH 0054/1452] improve comp_lisp_obj_as_ptr_from_ptr generated var naming --- src/comp.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 5fd11e7a7ee..a14056e4c58 100644 --- a/src/comp.c +++ b/src/comp.c @@ -379,10 +379,18 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) static gcc_jit_rvalue * comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) { + static unsigned i; + char ptr_var_name[40]; + + int res = snprintf (ptr_var_name, sizeof (ptr_var_name), + "lisp_obj_from_ptr_%u", i++); + if (res >= sizeof (ptr_var_name)) + error ("Internal error, truncating temporary variable"); + gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - "lisp_obj_from_ptr"); + ptr_var_name); gcc_jit_lvalue *lisp_obj_as_ptr = gcc_jit_lvalue_access_field (lisp_obj, NULL, From 87bf022f2f5457febf23c2ce792c549928771bbd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 12 Jun 2019 03:54:59 +0200 Subject: [PATCH 0055/1452] fix prologue strategy --- src/comp.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index a14056e4c58..97b617ce2be 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,7 +70,7 @@ along with GNU Emacs. If not, see . */ #define PUSH_PARAM(obj) \ do { \ CHECK_STACK; \ - gcc_jit_block_add_assignment (bb_map[0].gcc_bb, \ + gcc_jit_block_add_assignment (prologue_bb, \ NULL, \ *stack, \ gcc_jit_param_as_rvalue(obj)); \ @@ -729,7 +729,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue *args[4]; unsigned op; - /* This is the stack we use to flat the bytecode written for push and pop + /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ gcc_jit_lvalue **stack_base, **stack, **stack_over; stack_base = stack = @@ -772,10 +772,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, local_name); } + gcc_jit_block *prologue_bb = + gcc_jit_function_new_block (comp.func, "prologue"); + basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); From 1001af9b847c1c338638ba1aee037dd8451882d0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 11 Jun 2019 18:56:25 +0200 Subject: [PATCH 0056/1452] add bubble sort into to tests --- test/src/comp-tests.el | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e7d5ca67f47..74ed33a43cf 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -250,6 +250,28 @@ (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))) +(defun comp-bubble-sort () + "Run bubble sort." + (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)) + + (byte-compile #'comp-bubble-sort-f) + (native-compile #'comp-bubble-sort-f) + + (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 4da353c6a3900ddacab00d685432fba12099dbd0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 11 Jun 2019 19:23:31 +0200 Subject: [PATCH 0057/1452] add comp_TAGGEDP --- src/comp.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/src/comp.c b/src/comp.c index 97b617ce2be..823956e147a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -281,6 +281,54 @@ comp_XLI (gcc_jit_rvalue *obj) comp.lisp_obj_as_num); } +static gcc_jit_rvalue * +comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) +{ + /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ + - (unsigned) (tag)) \ + & ((1 << GCTYPEBITS) - 1))) */ + + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + comp_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, + (USE_LSB_TAG ? 0 : VALBITS))); + + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + comp_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + tag)); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << GCTYPEBITS) - 1)))); + + return res; +} + static gcc_jit_rvalue * comp_FIXNUMP (gcc_jit_rvalue *obj) { From b3d858da8d577449e2ab40572422fdd1bdf8b538 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 11 Jun 2019 19:41:34 +0200 Subject: [PATCH 0058/1452] inline consp --- src/comp.c | 16 +++++++++++++++- test/src/comp-tests.el | 9 +++++++++ 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 823956e147a..93edd4df452 100644 --- a/src/comp.c +++ b/src/comp.c @@ -329,6 +329,12 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) return res; } +static gcc_jit_rvalue * +comp_CONSP (gcc_jit_rvalue *obj) +{ + return comp_TAGGEDP(obj, Lisp_Cons); +} + static gcc_jit_rvalue * comp_FIXNUMP (gcc_jit_rvalue *obj) { @@ -1004,7 +1010,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (nth, 2); CASE_CALL_NARGS (symbolp, 1); - CASE_CALL_NARGS (consp, 1); + + case Bconsp: + gcc_jit_block_add_assignment ( + comp.bblock->gcc_bb, + NULL, + TOS, + comp_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); + break; + CASE_CALL_NARGS (stringp, 1); CASE_CALL_NARGS (listp, 1); CASE_CALL_NARGS (eq, 2); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 74ed33a43cf..63dfafafb04 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -272,6 +272,15 @@ (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) +(ert-deftest comp-tests-list-inline () + "Test some inlined list functions." + (defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) + + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 592bfe5a978c949883472e66bd6c00f58808a506 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 12 Jun 2019 18:21:32 +0200 Subject: [PATCH 0059/1452] adding other ops --- src/comp.c | 123 +++++++++++++++++++++++++---------------------------- 1 file changed, 59 insertions(+), 64 deletions(-) diff --git a/src/comp.c b/src/comp.c index 93edd4df452..d4f08df48ee 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1288,7 +1288,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: - error ("Bpoint unsupported bytecode\n"); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + PT); + res = comp_emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); + PUSH_LVAL (res); break; CASE_CALL_NARGS (goto_char, 1); @@ -1298,10 +1306,27 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bpoint_max: - error ("Bpoint_max unsupported bytecode\n"); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + ZV); + res = comp_emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); + PUSH_LVAL (res); break; + case Bpoint_min: - error ("Bpoint_min unsupported bytecode\n"); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + BEGV); + res = comp_emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); + PUSH_LVAL (res); break; CASE_CALL_NARGS (char_after, 1); @@ -1322,17 +1347,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE_CALL_NARGS (eolp, 0); - - case Beobp: - error ("Beobp unsupported bytecode\n"); - break; - + CASE_CALL_NARGS (eobp, 0); CASE_CALL_NARGS (bolp, 0); - - case Bbobp: - error ("Bbobp unsupported bytecode\n"); - break; - + CASE_CALL_NARGS (bobp, 0); CASE_CALL_NARGS (current_buffer, 0); CASE_CALL_NARGS (set_buffer, 1); @@ -1482,57 +1499,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); break; - case Bset_marker: - error ("Bset_marker not supported"); - break; - case Bmatch_beginning: - error ("Bmatch_beginning not supported"); - break; - case Bmatch_end: - error ("Bmatch_end not supported"); - break; - case Bupcase: - error ("Bupcase not supported"); - break; - case Bdowncase: - error ("Bdowncase not supported"); - break; + + CASE_CALL_NARGS (set_marker, 3); + CASE_CALL_NARGS (match_beginning, 1); + CASE_CALL_NARGS (match_end, 1); + CASE_CALL_NARGS (upcase, 1); + CASE_CALL_NARGS (downcase, 1); + case Bstringeqlsign: - error ("Bstringeqlsign not supported"); + POP2; + res = comp_emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); + PUSH_LVAL (res); break; + case Bstringlss: - error ("Bstringlss not supported"); - break; - case Bequal: - error ("Bequal not supported"); - break; - case Bnthcdr: - error ("Bnthcdr not supported"); - break; - case Belt: - error ("Belt not supported"); - break; - case Bmember: - error ("Bmember not supported"); - break; - case Bassq: - error ("Bassq not supported"); - break; - case Bnreverse: - error ("Bnreverse not supported"); - break; - - case Bsetcar: POP2; - res = comp_emit_call ("Fsetcar", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; - case Bsetcdr: - POP2; - res = comp_emit_call ("Fsetcdr", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); - break; + CASE_CALL_NARGS (equal, 2); + CASE_CALL_NARGS (nthcdr, 2); + CASE_CALL_NARGS (elt, 2); + CASE_CALL_NARGS (member, 2); + CASE_CALL_NARGS (assq, 2); + CASE_CALL_NARGS (setcar, 2); + CASE_CALL_NARGS (setcdr, 2); case Bcar_safe: error ("Bcar_safe not supported"); @@ -1540,18 +1532,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bcdr_safe: error ("Bcdr_safe not supported"); break; + case Bnconc: - error ("Bnconc not supported"); + EMIT_SCRATCH_CALL_N ("Fnconc", 2); break; + case Bquo: - error ("Bquo not supported"); - break; - case Brem: - error ("Brem not supported"); + EMIT_SCRATCH_CALL_N ("Fquo", 2); break; + + CASE_CALL_NARGS (rem, 2); + case Bnumberp: error ("Bnumberp not supported"); break; + case Bintegerp: error ("Bintegerp not supported"); break; @@ -1932,7 +1927,7 @@ init_comp (void) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); if (COMP_DEBUG) { - logfile = fopen ("libjit.log", "w"); + logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, logfile, 0, 0); @@ -2009,4 +2004,4 @@ helper_unbind_n (int val) return unbind_to (SPECPDL_INDEX () - val, Qnil); } -#endif /* HAVE_LIBJIT */ +#endif /* HAVE_LIBGCCJIT */ From d6ab30499153b2d6b9565039714f210930a10f65 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 12 Jun 2019 22:11:20 +0200 Subject: [PATCH 0060/1452] add comp_VECTORLIKEP --- src/comp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.c b/src/comp.c index d4f08df48ee..3c837555d74 100644 --- a/src/comp.c +++ b/src/comp.c @@ -329,6 +329,12 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) return res; } +static gcc_jit_rvalue * +comp_VECTORLIKEP (gcc_jit_rvalue *obj) +{ + return comp_TAGGEDP(obj, Lisp_Vectorlike); +} + static gcc_jit_rvalue * comp_CONSP (gcc_jit_rvalue *obj) { From f3fd0293d9112e5e1ad9ad3bfb1e982dcb0d032b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Jun 2019 00:36:01 +0200 Subject: [PATCH 0061/1452] make some order into debug facilities --- src/comp.c | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3c837555d74..79aa0bdc031 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1812,8 +1812,24 @@ init_comp (void) { comp.ctxt = gcc_jit_context_acquire(); + if (COMP_DEBUG) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + } if (COMP_DEBUG > 1) - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + { + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); + } comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = @@ -1931,20 +1947,6 @@ init_comp (void) NULL); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - - if (COMP_DEBUG) { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); - } - - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); } void From d88694315f88baa24d4e0bd40be450218088292b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Jun 2019 20:56:44 +0200 Subject: [PATCH 0062/1452] reset compiler context for everi run --- src/comp.c | 314 ++++++++++++++++++++++++++-------------------------- src/emacs.c | 10 -- src/lisp.h | 2 - 3 files changed, 158 insertions(+), 168 deletions(-) diff --git a/src/comp.c b/src/comp.c index 79aa0bdc031..7522e726d14 100644 --- a/src/comp.c +++ b/src/comp.c @@ -777,6 +777,162 @@ comp_emit_comp_jump (enum gcc_jit_comparison op, return test; } +static void +init_comp (int opt_level) +{ + comp.ctxt = gcc_jit_context_acquire(); + + if (COMP_DEBUG) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + } + if (COMP_DEBUG > 1) + { + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); + } + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + opt_level); + + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); + comp.void_ptr_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); + comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); + comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_LONG_LONG); + +#if EMACS_INT_MAX <= LONG_MAX + /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); + +#else + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); +#endif + + gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; + comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "LispObj", + 2, + lisp_obj_fields); + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, /* FIXME? */ + "ll"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + + gcc_jit_field *cast_union_fields[4] = + { comp.cast_union_as_ll, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b,}; + comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + 4, + cast_union_fields); + comp.most_positive_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_long_type, /* FIXME? */ + MOST_POSITIVE_FIXNUM); + comp.most_negative_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_long_type, /* FIXME? */ + MOST_NEGATIVE_FIXNUM); + comp.one = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + 1); + comp.inttypebits = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + INTTYPEBITS); + + comp.lisp_int0 = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + Lisp_Int0); + + enum gcc_jit_types ptrdiff_t_gcc; + if (sizeof (ptrdiff_t) == sizeof (int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_INT; + else if (sizeof (ptrdiff_t) == sizeof (long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; + else if (sizeof (ptrdiff_t) == sizeof (long long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; + else + eassert ("ptrdiff_t size not handled."); + + comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + + comp.scratch = + gcc_jit_lvalue_get_address( + gcc_jit_context_new_global (comp.ctxt, NULL, + GCC_JIT_GLOBAL_IMPORTED, + comp.lisp_obj_type, + "scratch_call_area"), + NULL); + + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); +} + +static void +release_comp (void) +{ + if (comp.ctxt) + gcc_jit_context_release(comp.ctxt); + + if (logfile) + fclose (logfile); +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -1674,6 +1830,7 @@ void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm) { + init_comp (opt_level); Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); CHECK_STRING (bytestr); @@ -1698,10 +1855,6 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, sigset_t oldset; block_atimers (&oldset); - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - opt_level); - comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), XFIXNAT (maxdepth) + 1, vectorp, ASIZE (vector), @@ -1724,6 +1877,7 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, DISASS_FILE_NAME); } unblock_atimers (&oldset); + release_comp (); } DEFUN ("native-compile", Fnative_compile, Snative_compile, @@ -1807,158 +1961,6 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, return Qnil; } -void -init_comp (void) -{ - comp.ctxt = gcc_jit_context_acquire(); - - if (COMP_DEBUG) - { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); - } - if (COMP_DEBUG > 1) - { - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); - } - - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); - comp.void_ptr_type = - gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); - comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); - comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, - GCC_JIT_TYPE_UNSIGNED_INT); - comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); - comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); - comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, - GCC_JIT_TYPE_LONG_LONG); - -#if EMACS_INT_MAX <= LONG_MAX - /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); - -#else - /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); -#endif - - gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, - comp.lisp_obj_as_num }; - comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "LispObj", - 2, - lisp_obj_fields); - - comp.cast_union_as_ll = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, /* FIXME? */ - "ll"); - comp.cast_union_as_u = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_type, - "u"); - comp.cast_union_as_i = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "i"); - comp.cast_union_as_b = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "b"); - - gcc_jit_field *cast_union_fields[4] = - { comp.cast_union_as_ll, - comp.cast_union_as_u, - comp.cast_union_as_i, - comp.cast_union_as_b,}; - comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "cast_union", - 4, - cast_union_fields); - comp.most_positive_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ - MOST_POSITIVE_FIXNUM); - comp.most_negative_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ - MOST_NEGATIVE_FIXNUM); - comp.one = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ - 1); - comp.inttypebits = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ - INTTYPEBITS); - - comp.lisp_int0 = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ - Lisp_Int0); - - enum gcc_jit_types ptrdiff_t_gcc; - if (sizeof (ptrdiff_t) == sizeof (int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_INT; - else if (sizeof (ptrdiff_t) == sizeof (long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; - else if (sizeof (ptrdiff_t) == sizeof (long long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; - else - eassert ("ptrdiff_t size not handled."); - - comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); - - comp.scratch = - gcc_jit_lvalue_get_address( - gcc_jit_context_new_global (comp.ctxt, NULL, - GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj_type, - "scratch_call_area"), - NULL); - - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); -} - -void -release_comp (void) -{ - if (comp.ctxt) - gcc_jit_context_release(comp.ctxt); - - if (logfile) - fclose (logfile); -} - void syms_of_comp (void) { diff --git a/src/emacs.c b/src/emacs.c index db6d54dff43..1491ba5a479 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1778,12 +1778,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem xputenv ("LANG=C"); #endif - /* This is here because init_buffer can already call Lisp. */ -#ifdef HAVE_LIBGCCJIT - if (initialized) - init_comp(); -#endif - /* Init buffer storage and default directory of main buffer. */ init_buffer (); @@ -2400,10 +2394,6 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } -#ifdef HAVE_LIBGCCJIT - release_comp(); -#endif - if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/lisp.h b/src/lisp.h index 5a563069df5..6f0177436d8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4745,8 +4745,6 @@ extern void syms_of_profiler (void); /* Defined in comp.c. */ #ifdef HAVE_LIBGCCJIT -extern void init_comp (void); -extern void release_comp (void); extern void syms_of_comp (void); #endif /* HAVE_LIBGCCJIT */ From 187c1eed6f5e21088c5b9b129c65b3e2fe512d1b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Jun 2019 21:07:30 +0200 Subject: [PATCH 0063/1452] rename comp_lisp_obj_from_ptr --- src/comp.c | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/comp.c b/src/comp.c index 7522e726d14..3f938e2c5d6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -437,7 +437,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * -comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) +comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; char ptr_var_name[40]; @@ -997,7 +997,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); - gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); + gcc_jit_rvalue *nil = comp_lisp_obj_from_ptr (&bb_map[0], Qnil); comp.bblock = NULL; @@ -1053,7 +1053,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -1078,7 +1078,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1105,7 +1105,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); @@ -1522,8 +1522,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (comp_lisp_obj_as_ptr_from_ptr (comp.bblock, - intern ("interactive-p"))); + PUSH_RVAL (comp_lisp_obj_from_ptr (comp.bblock, + intern ("interactive-p"))); res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -1613,8 +1613,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_restriction: - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, - save_restriction_restore); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, + save_restriction_restore); args[1] = gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save", comp.lisp_obj_type, @@ -1626,7 +1626,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); + args[1] = comp_lisp_obj_from_ptr (comp.bblock, eval_sub); comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -1801,7 +1801,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); break; } From 79dc3a717e23cf66d04cf3ec3392bd7635839bd0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Jun 2019 21:18:25 +0200 Subject: [PATCH 0064/1452] XLP XLI l and r values --- src/comp.c | 44 ++++++++++++++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 14 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3f938e2c5d6..5ae4e1b0532 100644 --- a/src/comp.c +++ b/src/comp.c @@ -274,13 +274,37 @@ comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } INLINE static gcc_jit_rvalue * -comp_XLI (gcc_jit_rvalue *obj) +comp_rval_XLI (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_as_num); } +INLINE static gcc_jit_lvalue * +comp_lval_XLI (gcc_jit_lvalue *obj) +{ + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num); +} + +INLINE static gcc_jit_rvalue * +comp_rval_XLP (gcc_jit_rvalue *obj) +{ + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} + +INLINE static gcc_jit_lvalue * +comp_lval_XLP (gcc_jit_lvalue *obj) +{ + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} + static gcc_jit_rvalue * comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) { @@ -294,7 +318,7 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_XLI (obj), + comp_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : VALBITS))); @@ -354,7 +378,7 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_XLI (obj), + comp_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); @@ -396,7 +420,7 @@ comp_XFIXNUM (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_XLI (obj), + comp_rval_XLI (obj), comp.inttypebits); } @@ -425,10 +449,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) gcc_jit_block_add_assignment (block, NULL, - gcc_jit_lvalue_access_field ( - res, - NULL, - comp.lisp_obj_as_num), + comp_lval_XLI (res), tmp); return gcc_jit_lvalue_as_rvalue (res); @@ -451,11 +472,6 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) NULL, comp.lisp_obj_type, ptr_var_name); - gcc_jit_lvalue *lisp_obj_as_ptr = - gcc_jit_lvalue_access_field (lisp_obj, - NULL, - comp.lisp_obj_as_ptr); - gcc_jit_rvalue *void_ptr = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, @@ -463,7 +479,7 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, - lisp_obj_as_ptr, + comp_lval_XLP (lisp_obj), void_ptr); return gcc_jit_lvalue_as_rvalue (lisp_obj); } From 8f446c06498b0c41e58d9265aa72c4615a220956 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 17:40:14 +0200 Subject: [PATCH 0065/1452] add declare_PSEUDOVECTORP --- src/comp.c | 374 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 230 insertions(+), 144 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5ae4e1b0532..6405df9cf7e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -186,6 +186,7 @@ typedef struct { gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; + gcc_jit_function *pseudovectorp; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -249,6 +250,150 @@ type_to_cast_field (gcc_jit_type *type) return field; } +static gcc_jit_function * +comp_func_declare (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, bool reusable) +{ + gcc_jit_param *param[4]; + gcc_jit_type *type[4]; + + /* If args are passed types are extracted from that otherwise assume params */ + /* are all lisp objs. */ + if (args) + for (int i = 0; i < nargs; i++) + type[i] = gcc_jit_rvalue_get_type (args[i]); + else + for (int i = 0; i < nargs; i++) + type[i] = comp.lisp_obj_type; + + switch (nargs) { + case 4: + param[3] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[3], + "c"); + /* Fall through */ + FALLTHROUGH; + case 3: + param[2] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[2], + "c"); + /* Fall through */ + FALLTHROUGH; + case 2: + param[1] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[1], + "b"); + /* Fall through */ + FALLTHROUGH; + case 1: + param[0] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[0], + "a"); + /* Fall through */ + FALLTHROUGH; + case 0: + break; + default: + /* Argnum not supported */ + eassert (0); + } + + gcc_jit_function *func = + gcc_jit_context_new_function(comp.ctxt, NULL, + kind, + ret_type, + f_name, + nargs, + param, + 0); + + if (reusable) + { + Lisp_Object value; + Lisp_Object key = make_string (f_name, strlen (f_name)); + value = make_pointer_integer (XPL (func)); + + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + /* Don't want to declare the same function two times */ + eassert (i == -1); + hash_put (ht, key, value, hash); + } + + return func; +} + +static gcc_jit_lvalue * +comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, + gcc_jit_rvalue **args) +{ + Lisp_Object key = make_string (f_name, strlen (f_name)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + + if (i == -1) + { + comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + true); + i = hash_lookup (ht, key, &hash); + eassert (i != -1); + } + + Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); + gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); + + gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, + NULL, + ret_type, + "res"); + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, + res, + gcc_jit_context_new_call(comp.ctxt, + NULL, + func, + nargs, + args)); + return res; +} + +/* Close current basic block emitting a conditional. */ + +INLINE static void +comp_emit_cond_jump (gcc_jit_rvalue *test, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, + NULL, + test, + then_target, + else_target); + comp.bblock->terminated = true; +} + +/* Close current basic block emitting a comparison between two rval. */ + +static gcc_jit_rvalue * +comp_emit_comp_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, + NULL, + op, + a, b); + + comp_emit_cond_jump (test, then_target, else_target); + + return test; +} + static gcc_jit_rvalue * comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { @@ -365,6 +510,79 @@ comp_CONSP (gcc_jit_rvalue *obj) return comp_TAGGEDP(obj, Lisp_Cons); } +/* static gcc_jit_rvalue * */ +/* comp_BIGNUMP (gcc_jit_rvalue *obj) */ +/* { */ + +/* } */ + + +/* Declare a substitute for PSEUDOVECTORP as inline function. */ + +static void +declare_PSEUDOVECTORP (void) +{ + gcc_jit_param *param[2] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "code") }; + + comp.pseudovectorp = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.bool_type, + "PSEUDOVECTORP", + 2, + param, + 0); + + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); + + gcc_jit_block *ret_false_b = + gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); + + gcc_jit_block *call_pseudovector_typep_b = + gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); + + /* Set current context as needed */ + basic_block_t bblock = { .gcc_bb = initial_block, + .terminated = false }; + comp.bblock = &bblock; + comp.func = comp.pseudovectorp; + + comp_emit_cond_jump ( + comp_cast (comp.bool_type, + comp_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), + call_pseudovector_typep_b, + ret_false_b); + + comp.bblock->gcc_bb = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b, + NULL, + gcc_jit_context_new_rvalue_from_int( + comp.ctxt, + comp.bool_type, + false)); + + gcc_jit_rvalue *args[2] = + { gcc_jit_param_as_rvalue (param[0]), + gcc_jit_param_as_rvalue (param[1]) }; + comp.bblock->gcc_bb = call_pseudovector_typep_b; + gcc_jit_block_end_with_return (call_pseudovector_typep_b, + NULL, + gcc_jit_lvalue_as_rvalue( + comp_emit_call ("helper_PSEUDOVECTOR_TYPEP", + comp.bool_type, + 2, + args))); +} + static gcc_jit_rvalue * comp_FIXNUMP (gcc_jit_rvalue *obj) { @@ -484,119 +702,6 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) return gcc_jit_lvalue_as_rvalue (lisp_obj); } -static gcc_jit_function * -comp_func_declare (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) -{ - gcc_jit_param *param[4]; - gcc_jit_type *type[4]; - - /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ - if (args) - for (int i = 0; i < nargs; i++) - type[i] = gcc_jit_rvalue_get_type (args[i]); - else - for (int i = 0; i < nargs; i++) - type[i] = comp.lisp_obj_type; - - switch (nargs) { - case 4: - param[3] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[3], - "c"); - /* Fall through */ - FALLTHROUGH; - case 3: - param[2] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[2], - "c"); - /* Fall through */ - FALLTHROUGH; - case 2: - param[1] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[1], - "b"); - /* Fall through */ - FALLTHROUGH; - case 1: - param[0] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[0], - "a"); - /* Fall through */ - FALLTHROUGH; - case 0: - break; - default: - /* Argnum not supported */ - eassert (0); - } - - gcc_jit_function *func = - gcc_jit_context_new_function(comp.ctxt, NULL, - kind, - comp.lisp_obj_type, - f_name, - nargs, - param, - 0); - - if (reusable) - { - Lisp_Object value; - Lisp_Object key = make_string (f_name, strlen (f_name)); - value = make_pointer_integer (XPL (func)); - - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); - /* Don't want to declare the same function two times */ - eassert (i == -1); - hash_put (ht, key, value, hash); - } - - return func; -} - -static gcc_jit_lvalue * -comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) -{ - Lisp_Object key = make_string (f_name, strlen (f_name)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); - - if (i == -1) - { - comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, - true); - i = hash_lookup (ht, key, &hash); - eassert (i != -1); - } - - Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); - gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); - - gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, - NULL, - ret_type, - "res"); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, - res, - gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - nargs, - args)); - return res; -} - static gcc_jit_lvalue * comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { @@ -762,37 +867,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) return bb_map; } -/* Close current basic block emitting a conditional. */ - -INLINE static void -comp_emit_cond_jump (gcc_jit_rvalue *test, - gcc_jit_block *then_target, gcc_jit_block *else_target) -{ - gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, - NULL, - test, - then_target, - else_target); - comp.bblock->terminated = true; -} - -/* Close current basic block emitting a comparison between two rval. */ - -static gcc_jit_rvalue * -comp_emit_comp_jump (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) -{ - gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, - NULL, - op, - a, b); - - comp_emit_cond_jump (test, then_target, else_target); - - return test; -} - static void init_comp (int opt_level) { @@ -937,6 +1011,8 @@ init_comp (int opt_level) NULL); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + + declare_PSEUDOVECTORP (); } static void @@ -1998,6 +2074,9 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (int val); +bool helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, + enum pvec_type code); + Lisp_Object helper_save_window_excursion (Lisp_Object v1) { @@ -2030,4 +2109,11 @@ helper_unbind_n (int val) return unbind_to (SPECPDL_INDEX () - val, Qnil); } +bool +helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, + enum pvec_type code) +{ + return PSEUDOVECTOR_TYPEP (a, code); +} + #endif /* HAVE_LIBGCCJIT */ From a11dc2c8ad5f4162fbad497ce7a813d9f58837b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 17:53:46 +0200 Subject: [PATCH 0066/1452] better naming ocnvention --- src/comp.c | 270 +++++++++++++++++++++++++++-------------------------- 1 file changed, 136 insertions(+), 134 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6405df9cf7e..b4774b9c331 100644 --- a/src/comp.c +++ b/src/comp.c @@ -127,7 +127,7 @@ along with GNU Emacs. If not, see . */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ POP##nargs; \ - res = comp_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + res = emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ PUSH_LVAL (res); \ break @@ -137,7 +137,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_SCRATCH_CALL_N(name, nargs) \ do { \ pop (nargs, &stack, args); \ - res = comp_emit_callN (name, nargs, args); \ + res = emit_callN (name, nargs, args); \ PUSH_LVAL (res); \ } while (0) @@ -147,7 +147,7 @@ along with GNU Emacs. If not, see . */ args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ comp.int_type, \ comparison); \ - res = comp_emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ + res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ PUSH_LVAL (res); \ } while (0) @@ -251,7 +251,7 @@ type_to_cast_field (gcc_jit_type *type) } static gcc_jit_function * -comp_func_declare (const char *f_name, gcc_jit_type *ret_type, +emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { @@ -329,8 +329,9 @@ comp_func_declare (const char *f_name, gcc_jit_type *ret_type, return func; } +/* TODO this should return an rval */ static gcc_jit_lvalue * -comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, +emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); @@ -340,7 +341,7 @@ comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + emit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); @@ -366,7 +367,7 @@ comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, /* Close current basic block emitting a conditional. */ INLINE static void -comp_emit_cond_jump (gcc_jit_rvalue *test, +emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, @@ -380,7 +381,7 @@ comp_emit_cond_jump (gcc_jit_rvalue *test, /* Close current basic block emitting a comparison between two rval. */ static gcc_jit_rvalue * -comp_emit_comp_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ +emit_comparison_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ gcc_jit_rvalue *a, gcc_jit_rvalue *b, gcc_jit_block *then_target, gcc_jit_block *else_target) { @@ -389,13 +390,13 @@ comp_emit_comp_jump (enum gcc_jit_comparison op, /* TODO add basick block as par op, a, b); - comp_emit_cond_jump (test, then_target, else_target); + emit_cond_jump (test, then_target, else_target); return test; } static gcc_jit_rvalue * -comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { gcc_jit_field *orig_field = type_to_cast_field (gcc_jit_rvalue_get_type (obj)); @@ -419,7 +420,7 @@ comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } INLINE static gcc_jit_rvalue * -comp_rval_XLI (gcc_jit_rvalue *obj) +emit_rval_XLI (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -427,7 +428,7 @@ comp_rval_XLI (gcc_jit_rvalue *obj) } INLINE static gcc_jit_lvalue * -comp_lval_XLI (gcc_jit_lvalue *obj) +emit_lval_XLI (gcc_jit_lvalue *obj) { return gcc_jit_lvalue_access_field (obj, NULL, @@ -435,7 +436,7 @@ comp_lval_XLI (gcc_jit_lvalue *obj) } INLINE static gcc_jit_rvalue * -comp_rval_XLP (gcc_jit_rvalue *obj) +emit_rval_XLP (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -443,7 +444,7 @@ comp_rval_XLP (gcc_jit_rvalue *obj) } INLINE static gcc_jit_lvalue * -comp_lval_XLP (gcc_jit_lvalue *obj) +emit_lval_XLP (gcc_jit_lvalue *obj) { return gcc_jit_lvalue_access_field (obj, NULL, @@ -451,7 +452,7 @@ comp_lval_XLP (gcc_jit_lvalue *obj) } static gcc_jit_rvalue * -comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) +emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) { /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -463,7 +464,7 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_rval_XLI (obj), + emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : VALBITS))); @@ -473,7 +474,7 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - comp_cast (comp.unsigned_type, sh_res), + emit_cast (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -499,19 +500,19 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) } static gcc_jit_rvalue * -comp_VECTORLIKEP (gcc_jit_rvalue *obj) +emit_VECTORLIKEP (gcc_jit_rvalue *obj) { - return comp_TAGGEDP(obj, Lisp_Vectorlike); + return emit_TAGGEDP(obj, Lisp_Vectorlike); } static gcc_jit_rvalue * -comp_CONSP (gcc_jit_rvalue *obj) +emit_CONSP (gcc_jit_rvalue *obj) { - return comp_TAGGEDP(obj, Lisp_Cons); + return emit_TAGGEDP(obj, Lisp_Cons); } /* static gcc_jit_rvalue * */ -/* comp_BIGNUMP (gcc_jit_rvalue *obj) */ +/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ /* { */ /* } */ @@ -556,9 +557,9 @@ declare_PSEUDOVECTORP (void) comp.bblock = &bblock; comp.func = comp.pseudovectorp; - comp_emit_cond_jump ( - comp_cast (comp.bool_type, - comp_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), call_pseudovector_typep_b, ret_false_b); @@ -574,17 +575,18 @@ declare_PSEUDOVECTORP (void) { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; comp.bblock->gcc_bb = call_pseudovector_typep_b; + /* FIXME XUNTAG missing here. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, gcc_jit_lvalue_as_rvalue( - comp_emit_call ("helper_PSEUDOVECTOR_TYPEP", - comp.bool_type, - 2, - args))); + emit_call ("helper_PSEUDOVECTOR_TYPEP", + comp.bool_type, + 2, + args))); } static gcc_jit_rvalue * -comp_FIXNUMP (gcc_jit_rvalue *obj) +emit_FIXNUMP (gcc_jit_rvalue *obj) { /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) @@ -596,7 +598,7 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_rval_XLI (obj), + emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); @@ -606,7 +608,7 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - comp_cast (comp.unsigned_type, sh_res), + emit_cast (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -632,18 +634,18 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -comp_XFIXNUM (gcc_jit_rvalue *obj) +emit_XFIXNUM (gcc_jit_rvalue *obj) { return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_rval_XLI (obj), + emit_rval_XLI (obj), comp.inttypebits); } static gcc_jit_rvalue * -comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) +emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -667,7 +669,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) gcc_jit_block_add_assignment (block, NULL, - comp_lval_XLI (res), + emit_lval_XLI (res), tmp); return gcc_jit_lvalue_as_rvalue (res); @@ -676,7 +678,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * -comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) +emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; char ptr_var_name[40]; @@ -697,13 +699,13 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, - comp_lval_XLP (lisp_obj), + emit_lval_XLP (lisp_obj), void_ptr); return gcc_jit_lvalue_as_rvalue (lisp_obj); } static gcc_jit_lvalue * -comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -749,7 +751,7 @@ comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) nargs); args[1] = comp.scratch; - return comp_emit_call (f_name, comp.lisp_obj_type, 2, args); + return emit_call (f_name, comp.lisp_obj_type, 2, args); } static int @@ -1067,7 +1069,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. */ - comp.func = comp_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); char local_name[256]; @@ -1089,7 +1091,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); - gcc_jit_rvalue *nil = comp_lisp_obj_from_ptr (&bb_map[0], Qnil); + gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (&bb_map[0], Qnil); comp.bblock = NULL; @@ -1145,8 +1147,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); - res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; } @@ -1170,12 +1172,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = comp_emit_call ("set_internal", comp.lisp_obj_type, 4, args); + res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH_LVAL (res); } break; @@ -1197,9 +1199,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); - res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args); + res = emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; } @@ -1223,7 +1225,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = comp_emit_callN ("Ffuncall", nargs, args); + res = emit_callN ("Ffuncall", nargs, args); PUSH_LVAL (res); break; } @@ -1249,7 +1251,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -1270,7 +1272,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->gcc_bb, NULL, TOS, - comp_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); + emit_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); break; CASE_CALL_NARGS (stringp, 1); @@ -1295,12 +1297,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = nil; - res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); for (int i = 0; i < op; ++i) { POP2; - res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); } break; @@ -1343,16 +1345,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_function_new_block (comp.func, "fcall_sub1"); gcc_jit_rvalue *tos_as_num = - comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); - comp_emit_cond_jump ( + emit_cond_jump ( gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - comp_cast (comp.bool_type, - comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -1372,13 +1374,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block_add_assignment (sub1_inline_block, NULL, TOS, - comp_make_fixnum (sub1_inline_block, + emit_make_fixnum (sub1_inline_block, sub1_inline_res)); basic_block_t bb_orig = *comp.bblock; comp.bblock->gcc_bb = sub1_fcall_block; POP1; - res = comp_emit_call ("Fsub1", comp.lisp_obj_type, 1, args); + res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); *comp.bblock = bb_orig; @@ -1403,16 +1405,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_function_new_block (comp.func, "fcall_add1"); gcc_jit_rvalue *tos_as_num = - comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); - comp_emit_cond_jump ( + emit_cond_jump ( gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - comp_cast (comp.bool_type, - comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -1432,13 +1434,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block_add_assignment (add1_inline_block, NULL, TOS, - comp_make_fixnum (add1_inline_block, + emit_make_fixnum (add1_inline_block, add1_inline_res)); basic_block_t bb_orig = *comp.bblock; comp.bblock->gcc_bb = add1_fcall_block; POP1; - res = comp_emit_call ("Fadd1", comp.lisp_obj_type, 1, args); + res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); *comp.bblock = bb_orig; @@ -1487,16 +1489,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_function_new_block (comp.func, "fcall_negate"); gcc_jit_rvalue *tos_as_num = - comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); - comp_emit_cond_jump ( + emit_cond_jump ( gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - comp_cast (comp.bool_type, - comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -1515,7 +1517,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block_add_assignment (negate_inline_block, NULL, TOS, - comp_make_fixnum (negate_inline_block, + emit_make_fixnum (negate_inline_block, negate_inline_res)); basic_block_t bb_orig = *comp.bblock; @@ -1546,10 +1548,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, PT); - res = comp_emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); + res = emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); PUSH_LVAL (res); break; @@ -1564,10 +1566,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, ZV); - res = comp_emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); + res = emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); PUSH_LVAL (res); break; @@ -1576,10 +1578,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, BEGV); - res = comp_emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); + res = emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); PUSH_LVAL (res); break; @@ -1587,7 +1589,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = comp_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); + res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_LVAL (res); break; @@ -1596,7 +1598,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; args[1] = nil; - res = comp_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -1609,14 +1611,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - comp_emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); + emit_call ("record_unwind_current_buffer", + comp.void_type, 0, NULL); break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (comp_lisp_obj_from_ptr (comp.bblock, + PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); - res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args); + res = emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -1647,32 +1649,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1693,59 +1695,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - res = comp_emit_call ("record_unwind_protect_excursion", + res = emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; case Bsave_window_excursion: /* Obsolete since 24.1. */ POP1; - res = comp_emit_call ("helper_save_window_excursion", - comp.lisp_obj_type, 1, args); + res = emit_call ("helper_save_window_excursion", + comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; case Bsave_restriction: - args[0] = comp_lisp_obj_from_ptr (comp.bblock, + args[0] = emit_lisp_obj_from_ptr (comp.bblock, save_restriction_restore); args[1] = - gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL)); - comp_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + gcc_jit_lvalue_as_rvalue (emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL)); + emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = comp_lisp_obj_from_ptr (comp.bblock, eval_sub); - comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); + emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ POP1; - comp_emit_call ("helper_unwind_protect", comp.void_type, 1, args); + emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; case Bcondition_case: /* Obsolete since 24.4. */ POP3; - comp_emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); + emit_call ("internal_lisp_condition_case", + comp.lisp_obj_type, 3, args); break; case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ POP1; - res = comp_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, - 1, args); + res = emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, + 1, args); PUSH_LVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; - comp_emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); + emit_call ("temp_output_buffer_show", comp.void_type, 1, + &args[1]); PUSH_RVAL (args[0]); - comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; case Bunbind_all: /* Obsolete. Never used. */ @@ -1762,13 +1764,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstringeqlsign: POP2; - res = comp_emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); + res = emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; case Bstringlss: POP2; - res = comp_emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); + res = emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -1818,35 +1820,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1893,7 +1895,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); break; } From 4ca1857b501875fa3695ee7d42712e681c4767f4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 18:07:59 +0200 Subject: [PATCH 0067/1452] fix intern_c_string_1 --- src/lread.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index bedb3d57cb5..ca7b29f690b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4178,7 +4178,7 @@ intern_c_string_1 (const char *str, ptrdiff_t len) if (!SYMBOLP (tem)) { - if NILP (Vpurify_flag) + if (NILP (Vpurify_flag)) string = make_string (str, len); else string = make_pure_c_string (str, len); From 433108104abecb5e84f28a476b9b977c0086694f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 18:09:49 +0200 Subject: [PATCH 0068/1452] helper_PSEUDOVECTOR_TYPEP -> helper_PSEUDOVECTOR_TYPEP_XUNTAG --- src/comp.c | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index b4774b9c331..caa5cc96003 100644 --- a/src/comp.c +++ b/src/comp.c @@ -579,10 +579,11 @@ declare_PSEUDOVECTORP (void) gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, gcc_jit_lvalue_as_rvalue( - emit_call ("helper_PSEUDOVECTOR_TYPEP", - comp.bool_type, - 2, - args))); + emit_call ( + "helper_PSEUDOVECTOR_TYPEP_XUNTAG", + comp.bool_type, + 2, + args))); } static gcc_jit_rvalue * @@ -2076,8 +2077,8 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (int val); -bool helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, - enum pvec_type code); +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, + enum pvec_type code); Lisp_Object helper_save_window_excursion (Lisp_Object v1) @@ -2112,10 +2113,12 @@ helper_unbind_n (int val) } bool -helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, - enum pvec_type code) +helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, + enum pvec_type code) { - return PSEUDOVECTOR_TYPEP (a, code); + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); } #endif /* HAVE_LIBGCCJIT */ From f245990714abfd33c869573ebc2ba91eaa336e59 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 18:31:41 +0200 Subject: [PATCH 0069/1452] emit_call funcs return now rval --- src/comp.c | 87 ++++++++++++++++++++++++------------------------------ 1 file changed, 38 insertions(+), 49 deletions(-) diff --git a/src/comp.c b/src/comp.c index caa5cc96003..e74e67d1175 100644 --- a/src/comp.c +++ b/src/comp.c @@ -128,7 +128,7 @@ along with GNU Emacs. If not, see . */ case B##name: \ POP##nargs; \ res = emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ - PUSH_LVAL (res); \ + PUSH_RVAL (res); \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) @@ -138,7 +138,7 @@ along with GNU Emacs. If not, see . */ do { \ pop (nargs, &stack, args); \ res = emit_callN (name, nargs, args); \ - PUSH_LVAL (res); \ + PUSH_RVAL (res); \ } while (0) #define EMIT_ARITHCOMPARE(comparison) \ @@ -148,7 +148,7 @@ along with GNU Emacs. If not, see . */ comp.int_type, \ comparison); \ res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ - PUSH_LVAL (res); \ + PUSH_RVAL (res); \ } while (0) @@ -329,10 +329,9 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, return func; } -/* TODO this should return an rval */ -static gcc_jit_lvalue * +static gcc_jit_rvalue * emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) + gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); EMACS_UINT hash = 0; @@ -350,18 +349,11 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); - gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, - NULL, - ret_type, - "res"); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, - res, - gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - nargs, - args)); - return res; + return gcc_jit_context_new_call(comp.ctxt, + NULL, + func, + nargs, + args); } /* Close current basic block emitting a conditional. */ @@ -578,12 +570,10 @@ declare_PSEUDOVECTORP (void) /* FIXME XUNTAG missing here. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, - gcc_jit_lvalue_as_rvalue( - emit_call ( - "helper_PSEUDOVECTOR_TYPEP_XUNTAG", - comp.bool_type, - 2, - args))); + emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", + comp.bool_type, + 2, + args)); } static gcc_jit_rvalue * @@ -705,7 +695,7 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) return gcc_jit_lvalue_as_rvalue (lisp_obj); } -static gcc_jit_lvalue * +static gcc_jit_rvalue * emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ @@ -1034,7 +1024,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMACS_INT stack_depth, Lisp_Object *vectorp, ptrdiff_t vector_size, Lisp_Object args_template) { - gcc_jit_lvalue *res; + gcc_jit_rvalue *res; comp_f_res_t comp_res = { NULL, 0, 0 }; ptrdiff_t pc = 0; gcc_jit_rvalue *args[4]; @@ -1150,7 +1140,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; } @@ -1179,7 +1169,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.int_type, SET_INTERNAL_SET); res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH_LVAL (res); + PUSH_RVAL (res); } break; @@ -1203,7 +1193,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); res = emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; } @@ -1227,7 +1217,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); res = emit_callN ("Ffuncall", nargs, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; } @@ -1299,12 +1289,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = nil; res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); for (int i = 0; i < op; ++i) { POP2; res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); } break; } @@ -1382,7 +1372,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->gcc_bb = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); *comp.bblock = bb_orig; @@ -1442,7 +1432,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->gcc_bb = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); *comp.bblock = bb_orig; @@ -1553,7 +1543,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (goto_char, 1); @@ -1571,7 +1561,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Bpoint_min: @@ -1583,7 +1573,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (char_after, 1); @@ -1591,7 +1581,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpreceding_char: res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (current_column, 0); @@ -1600,7 +1590,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = nil; res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (eolp, 0); @@ -1620,7 +1610,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (forward_char, 1); @@ -1704,17 +1694,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = emit_call ("helper_save_window_excursion", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Bsave_restriction: args[0] = emit_lisp_obj_from_ptr (comp.bblock, save_restriction_restore); - args[1] = - gcc_jit_lvalue_as_rvalue (emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL)); + args[1] = emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL); emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; @@ -1740,7 +1729,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ @@ -1766,13 +1755,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstringeqlsign: POP2; res = emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Bstringlss: POP2; res = emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (equal, 2); From cb4ce8b31c53a927f8ec8b542ad90acd14e951de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 18:34:18 +0200 Subject: [PATCH 0070/1452] add emit_BIGNUMP --- src/comp.c | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index e74e67d1175..a18ed07391b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -503,13 +503,6 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP(obj, Lisp_Cons); } -/* static gcc_jit_rvalue * */ -/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ -/* { */ - -/* } */ - - /* Declare a substitute for PSEUDOVECTORP as inline function. */ static void @@ -576,6 +569,21 @@ declare_PSEUDOVECTORP (void) args)); } +static gcc_jit_rvalue * +emit_BIGNUMP (gcc_jit_rvalue *obj) +{ + gcc_jit_rvalue *args[2] = { + obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; + + return emit_call ("PSEUDOVECTORP", + comp.bool_type, + 2, + args); +} + static gcc_jit_rvalue * emit_FIXNUMP (gcc_jit_rvalue *obj) { From 0438e245a15e91aac93a5df812ce292dd1ff681b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Jun 2019 18:38:20 +0200 Subject: [PATCH 0071/1452] add emit_INTEGERP --- src/comp.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/comp.c b/src/comp.c index a18ed07391b..1b1401caff9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -572,6 +572,7 @@ declare_PSEUDOVECTORP (void) static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { + /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ gcc_jit_rvalue *args[2] = { obj, gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -643,6 +644,17 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) comp.inttypebits); } +static gcc_jit_rvalue * +emit_INTEGERP (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_FIXNUMP (obj), + emit_BIGNUMP (obj)); +} + static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { From 2a1bb41c14fba3ecb2f7ccdb251918ea0ac30c41 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 11:21:29 +0200 Subject: [PATCH 0072/1452] Bintegerp support --- src/comp.c | 227 ++++++++++++++++++++++++++--------------- test/src/comp-tests.el | 17 +++ 2 files changed, 160 insertions(+), 84 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1b1401caff9..f3fd8dc16bb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -187,6 +187,7 @@ typedef struct { gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; + gcc_jit_function *bool_to_lisp_obj; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -360,7 +361,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, INLINE static void emit_cond_jump (gcc_jit_rvalue *test, - gcc_jit_block *then_target, gcc_jit_block *else_target) + gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, NULL, @@ -503,72 +504,6 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP(obj, Lisp_Cons); } -/* Declare a substitute for PSEUDOVECTORP as inline function. */ - -static void -declare_PSEUDOVECTORP (void) -{ - gcc_jit_param *param[2] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "a"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.int_type, - "code") }; - - comp.pseudovectorp = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.bool_type, - "PSEUDOVECTORP", - 2, - param, - 0); - - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); - - gcc_jit_block *ret_false_b = - gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); - - gcc_jit_block *call_pseudovector_typep_b = - gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); - - /* Set current context as needed */ - basic_block_t bblock = { .gcc_bb = initial_block, - .terminated = false }; - comp.bblock = &bblock; - comp.func = comp.pseudovectorp; - - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), - call_pseudovector_typep_b, - ret_false_b); - - comp.bblock->gcc_bb = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b, - NULL, - gcc_jit_context_new_rvalue_from_int( - comp.ctxt, - comp.bool_type, - false)); - - gcc_jit_rvalue *args[2] = - { gcc_jit_param_as_rvalue (param[0]), - gcc_jit_param_as_rvalue (param[1]) }; - comp.bblock->gcc_bb = call_pseudovector_typep_b; - /* FIXME XUNTAG missing here. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b, - NULL, - emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", - comp.bool_type, - 2, - args)); -} - static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { @@ -579,10 +514,11 @@ emit_BIGNUMP (gcc_jit_rvalue *obj) comp.int_type, PVEC_BIGNUM) }; - return emit_call ("PSEUDOVECTORP", - comp.bool_type, - 2, - args); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); } static gcc_jit_rvalue * @@ -651,7 +587,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, - emit_FIXNUMP (obj), + emit_cast (comp.bool_type, + emit_FIXNUMP (obj)), emit_BIGNUMP (obj)); } @@ -687,7 +624,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) } /* Construct fill and return a lisp object form a raw pointer. */ - +/* TODO should we pass the bb? */ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { @@ -745,16 +682,19 @@ emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) for (int i = 0; i < nargs; i++) { gcc_jit_rvalue *idx = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - gcc_jit_context_get_type(comp.ctxt, - GCC_JIT_TYPE_UNSIGNED_INT), - i); - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, NULL, - gcc_jit_context_new_array_access (comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue(p), - idx), - args[i]); + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + gcc_jit_context_get_type(comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT), + i); + gcc_jit_block_add_assignment ( + comp.bblock->gcc_bb, + NULL, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue(p), + idx), + args[i]); } args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, @@ -765,6 +705,118 @@ emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +/* Declare a substitute for PSEUDOVECTORP as inline function. */ + +static void +declare_PSEUDOVECTORP (void) +{ + gcc_jit_param *param[2] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "code") }; + + comp.pseudovectorp = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.bool_type, + "PSEUDOVECTORP", + 2, + param, + 0); + + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); + + gcc_jit_block *ret_false_b = + gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); + + gcc_jit_block *call_pseudovector_typep_b = + gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); + + /* Set current context as needed */ + basic_block_t bblock = { .gcc_bb = initial_block, + .terminated = false }; + comp.bblock = &bblock; + comp.func = comp.pseudovectorp; + + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), + call_pseudovector_typep_b, + ret_false_b); + + comp.bblock->gcc_bb = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b, + NULL, + gcc_jit_context_new_rvalue_from_int( + comp.ctxt, + comp.bool_type, + false)); + + gcc_jit_rvalue *args[2] = + { gcc_jit_param_as_rvalue (param[0]), + gcc_jit_param_as_rvalue (param[1]) }; + comp.bblock->gcc_bb = call_pseudovector_typep_b; + /* FIXME XUNTAG missing here. */ + gcc_jit_block_end_with_return (call_pseudovector_typep_b, + NULL, + emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", + comp.bool_type, + 2, + args)); +} + +/* Declare a function to convert boolean into t or nil */ + +static void +declare_bool_to_lisp_obj (void) +{ + /* x ? Qt : Qnil */ + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "x"); + comp.bool_to_lisp_obj = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "bool_to_lisp_obj", + 1, + ¶m, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.bool_to_lisp_obj, + "bool_to_lisp_obj_initial_block"); + gcc_jit_block *ret_t_block = + gcc_jit_function_new_block (comp.bool_to_lisp_obj, + "ret_t"); + gcc_jit_block *ret_nil_block = + gcc_jit_function_new_block (comp.bool_to_lisp_obj, + "ret_nil"); + /* Set current context as needed */ + basic_block_t bblock = { .gcc_bb = initial_block, + .terminated = false }; + comp.bblock = &bblock; + comp.func = comp.bool_to_lisp_obj; + + emit_cond_jump (gcc_jit_param_as_rvalue (param), + ret_t_block, + ret_nil_block); + bblock.gcc_bb = ret_t_block; + gcc_jit_block_end_with_return (ret_t_block, + NULL, + emit_lisp_obj_from_ptr (&bblock, Qt)); + bblock.gcc_bb = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block, + NULL, + emit_lisp_obj_from_ptr (&bblock, Qnil)); +} + static int ucmp(const void *a, const void *b) { @@ -1026,6 +1078,7 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); declare_PSEUDOVECTORP (); + declare_bool_to_lisp_obj (); } static void @@ -1814,7 +1867,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bintegerp: - error ("Bintegerp not supported"); + POP1; + res = emit_INTEGERP(args[0]); + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); + PUSH_RVAL (res); break; case BRgoto: diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 63dfafafb04..d7e6954455b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -278,9 +278,26 @@ ;; Bconsp (consp x)) + ;; (byte-compile #'comp-tests-consp-f) + ;; (native-compile #'comp-tests-consp-f) + (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil))) +(ert-deftest comp-tests-num-inline () + "Test some inlined number functions." + (defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) + + (byte-compile #'comp-tests-integerp-f) + (native-compile #'comp-tests-integerp-f) + + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 96e1a5efb3bdeb9e70f7ea6030514e83e6ae8da1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 11:59:11 +0200 Subject: [PATCH 0073/1452] fix consp --- src/comp.c | 17 ++++++++++------- test/src/comp-tests.el | 4 ++-- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index f3fd8dc16bb..7bdf1a8615c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -495,13 +495,13 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) static gcc_jit_rvalue * emit_VECTORLIKEP (gcc_jit_rvalue *obj) { - return emit_TAGGEDP(obj, Lisp_Vectorlike); + return emit_TAGGEDP (obj, Lisp_Vectorlike); } static gcc_jit_rvalue * emit_CONSP (gcc_jit_rvalue *obj) { - return emit_TAGGEDP(obj, Lisp_Cons); + return emit_TAGGEDP (obj, Lisp_Cons); } static gcc_jit_rvalue * @@ -1332,11 +1332,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (symbolp, 1); case Bconsp: - gcc_jit_block_add_assignment ( - comp.bblock->gcc_bb, - NULL, - TOS, - emit_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); + POP1; + res = emit_cast (comp.bool_type, + emit_CONSP (args[0])); + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (stringp, 1); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d7e6954455b..99dce77dc29 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -278,8 +278,8 @@ ;; Bconsp (consp x)) - ;; (byte-compile #'comp-tests-consp-f) - ;; (native-compile #'comp-tests-consp-f) + (byte-compile #'comp-tests-consp-f) + (native-compile #'comp-tests-consp-f) (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil))) From 04aafb7f66dff551d80040a53c482bde08bbc254 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 12:08:48 +0200 Subject: [PATCH 0074/1452] Bnumberp support --- src/comp.c | 26 +++++++++++++++++++++++++- test/src/comp-tests.el | 11 ++++++++++- 2 files changed, 35 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 7bdf1a8615c..fd7e7beda1e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -504,6 +504,12 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } +static gcc_jit_rvalue * +emit_FLOATP (gcc_jit_rvalue *obj) +{ + return emit_TAGGEDP (obj, Lisp_Float); +} + static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { @@ -592,6 +598,18 @@ emit_INTEGERP (gcc_jit_rvalue *obj) emit_BIGNUMP (obj)); } +static gcc_jit_rvalue * +emit_NUMBERP (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP(obj), + emit_cast (comp.bool_type, + emit_FLOATP (obj))); +} + static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { @@ -1866,7 +1884,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (rem, 2); case Bnumberp: - error ("Bnumberp not supported"); + POP1; + res = emit_NUMBERP (args[0]); + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); + PUSH_RVAL (res); break; case Bintegerp: diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 99dce77dc29..9d1ee65e4ee 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -289,14 +289,23 @@ (defun comp-tests-integerp-f (x) ;; Bintegerp (integerp x)) + (defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) (byte-compile #'comp-tests-integerp-f) (native-compile #'comp-tests-integerp-f) + (byte-compile #'comp-tests-numberp-f) + (native-compile #'comp-tests-numberp-f) (should (eq (comp-tests-integerp-f 1) t)) (should (eq (comp-tests-integerp-f '(1)) nil)) (should (eq (comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t))) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." From 0c7115c7b894c8e1655a0d5e482cc7ed8b231506 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 12:40:23 +0200 Subject: [PATCH 0075/1452] BdiscardN support --- src/comp.c | 35 ++++++++++++++++++++++------------- test/src/comp-tests.el | 14 ++++++++++++++ 2 files changed, 36 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index fd7e7beda1e..f19fc84479b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1197,20 +1197,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstack_ref3: case Bstack_ref4: case Bstack_ref5: - { - PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); - break; - } + PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + break; + case Bstack_ref6: - { - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); - break; - } + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); + break; + case Bstack_ref7: - { - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); - break; - } + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); + break; case Bvarref7: op = FETCH2; @@ -1966,8 +1962,20 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstack_set2: error ("Bstack_set2 not supported"); break; + case BdiscardN: - error ("BdiscardN not supported"); + op = FETCH; + if (op & 0x80) + { + op &= 0x7F; + POP1; + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + *(stack - op - 1), + args[0]); + } + + stack -= op; break; case Bswitch: error ("Bswitch not supported"); @@ -1978,6 +1986,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, a constant on the stack. */ goto fail; break; + default: case Bconstant: { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9d1ee65e4ee..f1acc42b8ca 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -307,6 +307,20 @@ (should (eq (comp-tests-numberp-f 'a) nil)) (should (eq (comp-tests-numberp-f 3.5) t))) +(ert-deftest comp-tests-stack () + "Test some stack operation." + (defun comp-tests-discardn-f (x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) + + (byte-compile #'comp-tests-discardn-f) + (native-compile #'comp-tests-discardn-f) + + (should (= (comp-tests-discardn-f 10) 2))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 1510e15c3c709130ded1569fb1faee4e885c0ff8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 15:32:29 +0200 Subject: [PATCH 0076/1452] Binsert support --- src/comp.c | 3 ++- test/src/comp-tests.el | 14 ++++++++++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index f19fc84479b..134d1baabcd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1945,7 +1945,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case BinsertN: - error ("BinsertN not supported"); + op = FETCH; + EMIT_SCRATCH_CALL_N ("Finsert", op); break; case Bstack_set: diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f1acc42b8ca..931b9e06094 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -314,12 +314,22 @@ (1+ (let ((a 1) (_b) (_c)) - a))) + a))) + (defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) (byte-compile #'comp-tests-discardn-f) (native-compile #'comp-tests-discardn-f) + (byte-compile #'comp-tests-insertn-f) + (native-compile #'comp-tests-insertn-f) - (should (= (comp-tests-discardn-f 10) 2))) + (should (= (comp-tests-discardn-f 10) 2)) + + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." From eefd7d819cbcd4f1996875a6b4932845841eb099 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 15:38:15 +0200 Subject: [PATCH 0077/1452] Bstack_set2 support --- src/comp.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 134d1baabcd..65e480b5daf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1961,7 +1961,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bstack_set2: - error ("Bstack_set2 not supported"); + op = FETCH2; + POP1; + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + *(stack - op), + args[0]); break; case BdiscardN: From bb45450e4b63c4a40689b8b797de275713197a79 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 15:59:41 +0200 Subject: [PATCH 0078/1452] Bcar_safe Bcdr_safe support --- src/comp.c | 10 +++++++--- test/src/comp-tests.el | 16 +++++++++++++++- 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 65e480b5daf..4f50c1cc7c2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1863,10 +1863,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (setcdr, 2); case Bcar_safe: - error ("Bcar_safe not supported"); + POP2; + res = emit_call ("CAR_SAFE", comp.lisp_obj_type, 1, args); + PUSH_RVAL (res); break; + case Bcdr_safe: - error ("Bcdr_safe not supported"); + POP2; + res = emit_call ("CDR_SAFE", comp.lisp_obj_type, 1, args); + PUSH_RVAL (res); break; case Bnconc: @@ -2189,7 +2194,6 @@ Lisp_Object helper_unbind_n (int val); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); - Lisp_Object helper_save_window_excursion (Lisp_Object v1) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 931b9e06094..6a643df9d3e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -45,11 +45,25 @@ "Testing cons car cdr." (defun comp-tests-list-f () (list 1 2 3)) + (defun comp-tests-car-safe-f (x) + ;; Bcar_safe + (car-safe x)) + (defun comp-tests-cdr-safe-f (x) + ;; Bcdr_safe + (cdr-safe x)) (byte-compile #'comp-tests-list-f) (native-compile #'comp-tests-list-f) + (byte-compile #'comp-tests-car-safe-f) + (native-compile #'comp-tests-car-safe-f) + (byte-compile #'comp-tests-cdr-safe-f) + (native-compile #'comp-tests-cdr-safe-f) - (should (equal (comp-tests-list-f) '(1 2 3)))) + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) (ert-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." From 72e2d6752ce09e8fb75f1ddc5094e7810eefebcc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 16:34:14 +0200 Subject: [PATCH 0079/1452] some renaming convention --- src/comp.c | 49 +++++++++++++++++++++---------------------------- 1 file changed, 21 insertions(+), 28 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4f50c1cc7c2..2da173f7231 100644 --- a/src/comp.c +++ b/src/comp.c @@ -122,23 +122,28 @@ along with GNU Emacs. If not, see . */ /* With most of the ops we need to do the same stuff so this macros are meant to save some typing. */ -/* Generate appropriate case and emit convential calls to function. */ +/* Pop from the meta-stack, emit the call and push the result */ + +#define EMIT_CALL_N(name, nargs) \ + POP##nargs; \ + res = emit_call (name, comp.lisp_obj_type, nargs, args); \ + PUSH_RVAL (res); + +/* Generate appropriate case and emit call to function. */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ - POP##nargs; \ - res = emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ - PUSH_RVAL (res); \ + EMIT_CALL_N (STR(F##name), nargs) \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) This is done aggregating args into the scratch_call_area. */ -#define EMIT_SCRATCH_CALL_N(name, nargs) \ - do { \ - pop (nargs, &stack, args); \ - res = emit_callN (name, nargs, args); \ - PUSH_RVAL (res); \ +#define EMIT_SCRATCH_CALL_N(name, nargs) \ + do { \ + pop (nargs, &stack, args); \ + res = emit_scratch_callN (name, nargs, args); \ + PUSH_RVAL (res); \ } while (0) #define EMIT_ARITHCOMPARE(comparison) \ @@ -151,7 +156,6 @@ along with GNU Emacs. If not, see . */ PUSH_RVAL (res); \ } while (0) - typedef struct { gcc_jit_block *gcc_bb; bool terminated; @@ -671,7 +675,7 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) } static gcc_jit_rvalue * -emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -1303,7 +1307,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = emit_callN ("Ffuncall", nargs, args); + res = emit_scratch_callN ("Ffuncall", nargs, args); PUSH_RVAL (res); break; } @@ -1781,10 +1785,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_window_excursion: /* Obsolete since 24.1. */ - POP1; - res = emit_call ("helper_save_window_excursion", - comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("helper_save_window_excursion", 1); break; case Bsave_restriction: @@ -1843,15 +1844,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (downcase, 1); case Bstringeqlsign: - POP2; - res = emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); + EMIT_CALL_N ("Fstring_equal", 2); break; case Bstringlss: - POP2; - res = emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); + EMIT_CALL_N ("Fstring_lessp", 2); break; CASE_CALL_NARGS (equal, 2); @@ -1863,15 +1860,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (setcdr, 2); case Bcar_safe: - POP2; - res = emit_call ("CAR_SAFE", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("CAR_SAFE", 1); break; case Bcdr_safe: - POP2; - res = emit_call ("CDR_SAFE", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("CDR_SAFE", 1); break; case Bnconc: From 09b33fb6bf12d55efa612a9ab3a20477047024de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Jun 2019 22:04:43 +0200 Subject: [PATCH 0080/1452] use emacs_int --- src/comp.c | 77 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2da173f7231..54b3c8da2df 100644 --- a/src/comp.c +++ b/src/comp.c @@ -171,6 +171,7 @@ typedef struct { gcc_jit_type *unsigned_type; gcc_jit_type *long_type; gcc_jit_type *long_long_type; + gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; @@ -180,6 +181,7 @@ typedef struct { be used for the scope. */ gcc_jit_type *cast_union_type; gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_l; gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; @@ -243,6 +245,8 @@ type_to_cast_field (gcc_jit_type *type) if (type == comp.long_long_type) field = comp.cast_union_as_ll; + else if (type == comp.long_type) + field = comp.cast_union_as_l; else if (type == comp.unsigned_type) field = comp.cast_union_as_u; else if (type == comp.int_type) @@ -460,10 +464,10 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, + comp.emacs_int_type, emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, + comp.emacs_int_type, (USE_LSB_TAG ? 0 : VALBITS))); gcc_jit_rvalue *minus_res = @@ -543,10 +547,10 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, + comp.emacs_int_type, emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, + comp.emacs_int_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); gcc_jit_rvalue *minus_res = @@ -585,7 +589,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, + comp.emacs_int_type, emit_rval_XLI (obj), comp.inttypebits); } @@ -621,14 +625,14 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LSHIFT, - comp.long_long_type, + comp.emacs_int_type, obj, comp.inttypebits); tmp = gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_PLUS, - comp.long_long_type, + comp.emacs_int_type, tmp, comp.lisp_int0); @@ -999,23 +1003,26 @@ init_comp (int opt_level) NULL, comp.void_ptr_type, "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); - #else /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, comp.long_long_type, "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); #endif + if (sizeof (EMACS_INT) == sizeof (long)) + comp.emacs_int_type = comp.long_type; + else if (sizeof (EMACS_INT) == sizeof (long long)) + comp.emacs_int_type = comp.long_long_type; + else + error ("Unexpected EMACS_INT size."); + + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "num"); + gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, @@ -1027,8 +1034,13 @@ init_comp (int opt_level) comp.cast_union_as_ll = gcc_jit_context_new_field (comp.ctxt, NULL, - comp.long_long_type, /* FIXME? */ + comp.long_long_type, "ll"); + comp.cast_union_as_l = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_type, + "l"); comp.cast_union_as_u = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1045,36 +1057,39 @@ init_comp (int opt_level) comp.bool_type, "b"); - gcc_jit_field *cast_union_fields[4] = + gcc_jit_field *cast_union_fields[5] = { comp.cast_union_as_ll, + comp.cast_union_as_l, comp.cast_union_as_u, comp.cast_union_as_i, comp.cast_union_as_b,}; - comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "cast_union", - 4, - cast_union_fields); + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + sizeof (cast_union_fields) / + sizeof (*cast_union_fields), + cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, MOST_POSITIVE_FIXNUM); comp.most_negative_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, 1); comp.inttypebits = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, INTTYPEBITS); comp.lisp_int0 = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, Lisp_Int0); enum gcc_jit_types ptrdiff_t_gcc; @@ -1452,7 +1467,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_MINUS, - comp.long_long_type, + comp.emacs_int_type, tos_as_num, comp.one); @@ -1512,7 +1527,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_PLUS, - comp.long_long_type, + comp.emacs_int_type, tos_as_num, comp.one); @@ -1596,7 +1611,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_unary_op (comp.ctxt, NULL, GCC_JIT_UNARY_OP_MINUS, - comp.long_long_type, + comp.emacs_int_type, tos_as_num); gcc_jit_block_add_assignment (negate_inline_block, From 4665ad2c8968fcb1eb90391eb46615f23e27eb09 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 17 Jun 2019 09:18:17 +0200 Subject: [PATCH 0081/1452] better macro usage --- src/comp.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 54b3c8da2df..cbba5570117 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1832,10 +1832,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ - POP1; - res = emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, - 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ From a9adf96df39ce12990cb98c318bf6ac1d2dfe27c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 17 Jun 2019 09:59:41 +0200 Subject: [PATCH 0082/1452] more type definitions --- src/comp.c | 100 +++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 89 insertions(+), 11 deletions(-) diff --git a/src/comp.c b/src/comp.c index cbba5570117..c557fe9db52 100644 --- a/src/comp.c +++ b/src/comp.c @@ -167,6 +167,7 @@ typedef struct { gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *bool_type; + gcc_jit_type *char_type; gcc_jit_type *int_type; gcc_jit_type *unsigned_type; gcc_jit_type *long_type; @@ -174,9 +175,12 @@ typedef struct { gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; + gcc_jit_type *jmp_buf_type; gcc_jit_type *lisp_obj_type; + gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + gcc_jit_struct *handler; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -731,10 +735,75 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +static void +define_handler_struct (void) +{ + gcc_jit_field *fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "type"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "tag_or_ch"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "nonlocal_exit"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "next"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "nextfree"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "bytecode_top"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "bytecode_dest"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.jmp_buf_type, + "jmp"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "f_lisp_eval_depth"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "pdlcount"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "poll_suppress_count"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "interrupt_input_blocked") }; + comp.handler = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "handler", + sizeof (fields) + / sizeof (*fields), + fields); +} + /* Declare a substitute for PSEUDOVECTORP as inline function. */ static void -declare_PSEUDOVECTORP (void) +define_PSEUDOVECTORP (void) { gcc_jit_param *param[2] = { gcc_jit_context_new_param (comp.ctxt, @@ -800,7 +869,7 @@ declare_PSEUDOVECTORP (void) /* Declare a function to convert boolean into t or nil */ static void -declare_bool_to_lisp_obj (void) +define_bool_to_lisp_obj (void) { /* x ? Qt : Qnil */ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, @@ -989,6 +1058,7 @@ init_comp (int opt_level) comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT); @@ -1023,13 +1093,15 @@ init_comp (int opt_level) comp.emacs_int_type, "num"); - gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, - comp.lisp_obj_as_num }; + gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, "LispObj", - 2, + sizeof (lisp_obj_fields) + / sizeof (*lisp_obj_fields), lisp_obj_fields); + comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.cast_union_as_ll = gcc_jit_context_new_field (comp.ctxt, @@ -1057,7 +1129,7 @@ init_comp (int opt_level) comp.bool_type, "b"); - gcc_jit_field *cast_union_fields[5] = + gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, comp.cast_union_as_l, comp.cast_union_as_u, @@ -1067,8 +1139,8 @@ init_comp (int opt_level) gcc_jit_context_new_union_type (comp.ctxt, NULL, "cast_union", - sizeof (cast_union_fields) / - sizeof (*cast_union_fields), + sizeof (cast_union_fields) + / sizeof (*cast_union_fields), cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1102,8 +1174,13 @@ init_comp (int opt_level) else eassert ("ptrdiff_t size not handled."); - comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); + /* Opaque definition for jmp_buf. */ + comp.jmp_buf_type = gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (jmp_buf)); comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, @@ -1114,8 +1191,9 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - declare_PSEUDOVECTORP (); - declare_bool_to_lisp_obj (); + define_handler_struct (); + define_PSEUDOVECTORP (); + define_bool_to_lisp_obj (); } static void From 3dde8c0e126d82663ad638c6dd63c8ee5f79c021 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 17 Jun 2019 15:37:08 +0200 Subject: [PATCH 0083/1452] adding Bpushconditioncase Bpushcatch --- src/comp.c | 247 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 197 insertions(+), 50 deletions(-) diff --git a/src/comp.c b/src/comp.c index c557fe9db52..0bc8be47a4d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -113,14 +113,14 @@ along with GNU Emacs. If not, see . */ #define FETCH (bytestr_data[pc++]) /* Fetch two bytes from the bytecode stream and make a 16-bit number - out of them. */ + out of them. */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) #define STR(s) #s /* With most of the ops we need to do the same stuff so this macros are meant - to save some typing. */ + to save some typing. */ /* Pop from the meta-stack, emit the call and push the result */ @@ -161,7 +161,7 @@ typedef struct { bool terminated; } basic_block_t; -/* The compiler context */ +/* The compiler context */ typedef struct { gcc_jit_context *ctxt; @@ -180,7 +180,17 @@ typedef struct { gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* struct handler. */ gcc_jit_struct *handler; + gcc_jit_field *handler_jmp_field; + gcc_jit_field *handler_val_field; + gcc_jit_field *handler_next_field; + gcc_jit_type *handler_ptr_type; + /* struct thread_state. */ + gcc_jit_struct *thread_state; + gcc_jit_field *m_handlerlist; + gcc_jit_type *thread_state_ptr_type; + gcc_jit_rvalue *current_thread; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -198,8 +208,8 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; - basic_block_t *bblock; /* Current basic block */ - Lisp_Object func_hash; /* f_name -> gcc_func */ + basic_block_t *bblock; /* Current basic block */ + Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; static comp_t comp; @@ -266,13 +276,13 @@ type_to_cast_field (gcc_jit_type *type) static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) + enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; gcc_jit_type *type[4]; /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ + /* are all lisp objs. */ if (args) for (int i = 0; i < nargs; i++) type[i] = gcc_jit_rvalue_get_type (args[i]); @@ -543,7 +553,7 @@ static gcc_jit_rvalue * emit_FIXNUMP (gcc_jit_rvalue *obj) { /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) & ((1 << INTTYPEBITS) - 1))) */ gcc_jit_rvalue *sh_res = @@ -653,8 +663,8 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) return gcc_jit_lvalue_as_rvalue (res); } -/* Construct fill and return a lisp object form a raw pointer. */ -/* TODO should we pass the bb? */ +/* Construct fill and return a lisp object form a raw pointer. */ +/* TODO should we pass the bb? */ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { @@ -735,9 +745,27 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +/* struct handler definition */ + static void define_handler_struct (void) { + comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "handler"); + comp.handler_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler)); + + comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.jmp_buf_type, + "jmp"); + comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"); + comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "next"); gcc_jit_field *fields[] = { gcc_jit_context_new_field (comp.ctxt, NULL, @@ -751,17 +779,11 @@ define_handler_struct (void) NULL, comp.int_type, "nonlocal_exit"), + comp.handler_val_field, + comp.handler_next_field, gcc_jit_context_new_field (comp.ctxt, NULL, - comp.lisp_obj_type, - "val"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "next"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, + comp.handler_ptr_type, "nextfree"), gcc_jit_context_new_field (comp.ctxt, NULL, @@ -771,10 +793,7 @@ define_handler_struct (void) NULL, comp.int_type, "bytecode_dest"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.jmp_buf_type, - "jmp"), + comp.handler_jmp_field, gcc_jit_context_new_field (comp.ctxt, NULL, comp.emacs_int_type, @@ -791,13 +810,55 @@ define_handler_struct (void) NULL, comp.int_type, "interrupt_input_blocked") }; - comp.handler = + gcc_jit_struct_set_fields (comp.handler, + NULL, + sizeof (fields) / sizeof (*fields), + fields); + +} + +static void +define_thread_state_struct (void) +{ + /* Partially opaque definition for `thread_state'. + Because we need to access just m_handlerlist hopefully this is requires + less manutention then the full deifnition. */ + + comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "m_handlerlist"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct thread_state, + m_handlerlist)), + "pad0"), + comp.m_handlerlist, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (struct handler *)), + "pad1") }; + + comp.thread_state = gcc_jit_context_new_struct_type (comp.ctxt, NULL, - "handler", - sizeof (fields) - / sizeof (*fields), + "thread_state", + sizeof (fields) / sizeof (*fields), fields); + comp.thread_state_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state)); } /* Declare a substitute for PSEUDOVECTORP as inline function. */ @@ -948,8 +1009,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) case Bvarbind7: case Bcall7: case Bunbind7: - case Bpushcatch: - case Bpushconditioncase: case Bstack_ref7: case Bstack_set2: pc += 2; @@ -989,6 +1048,9 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) bb_start_pc[bb_n++] = op; new_bb = true; break; + /* Other ops changing bb */ + case Bpushcatch: + case Bpushconditioncase: case Bsub1: case Badd1: case Bnegate: @@ -1074,7 +1136,7 @@ init_comp (int opt_level) comp.void_ptr_type, "obj"); #else - /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, comp.long_long_type, @@ -1192,6 +1254,11 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); define_handler_struct (); + define_thread_state_struct (); + comp.current_thread = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.thread_state_ptr_type, + current_thread); define_PSEUDOVECTORP (); define_bool_to_lisp_obj (); } @@ -1276,6 +1343,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, while (pc < bytestr_length) { + enum handlertype type; + /* If we are changing BB and the last was one wasn't terminated terminate it with a fall through. */ if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb && @@ -1429,14 +1498,92 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; + case Bpophandler: - error ("Bpophandler unsupported bytecode\n"); - break; - case Bpushconditioncase: - error ("Bpushconditioncase unsupported bytecode\n"); - break; - case Bpushcatch: - error ("Bpushcatch unsupported bytecode\n"); + { + /* current_thread->m_handlerlist = + current_thread->m_handlerlist->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment( + comp.bblock->gcc_bb, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + break; + } + + case Bpushconditioncase: /* New in 24.4. */ + type = CATCHER; + goto pushhandler; + + case Bpushcatch: /* New in 24.4. */ + type = CONDITION_CASE;; + pushhandler: + { + /* struct handler *c = push_handler (POP, type); */ + int handler_pc = FETCH2; + gcc_jit_rvalue *c; + POP1; + args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + type); + c = emit_call ("push_handler", comp.handler_ptr_type, 2, args); + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field (c, + NULL, + comp.handler_jmp_field), + NULL); +#ifdef HAVE__SETJMP + res = emit_call ("_setjmp", comp.int_type, 1, args); +#else + res = emit_call ("setjmp", comp.int_type, 1, args); +#endif + gcc_jit_block *push_h_val_block = + gcc_jit_function_new_block (comp.func, "push_h_val"); + emit_cond_jump ( + /* This negation is just to move to bool. */ + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.bool_type, + res), + bb_map[pc].gcc_bb, + push_h_val_block); + + basic_block_t bb_orig = *comp.bblock; + comp.bblock->gcc_bb = push_h_val_block; + /* current_thread->m_handlerlist = c->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field ( + c, + NULL, + comp.handler_next_field))); + /* PUSH (c->val); */ + PUSH_LVAL ( + gcc_jit_rvalue_dereference_field (c, + NULL, + comp.handler_val_field)); + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (push_h_val_block, NULL, + bb_map[handler_pc].gcc_bb); + } break; CASE_CALL_NARGS (nth, 2); @@ -1514,8 +1661,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)) */ gcc_jit_block *sub1_inline_block = gcc_jit_function_new_block (comp.func, "inline_sub1"); @@ -1574,8 +1721,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd (TOP)) */ gcc_jit_block *add1_inline_block = gcc_jit_function_new_block (comp.func, "inline_add1"); @@ -1793,7 +1940,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.void_type, 0, NULL); break; - case Binteractive_p: /* Obsolete since 24.1. */ + case Binteractive_p: /* Obsolete since 24.1. */ PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); @@ -1891,7 +2038,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - case Bcatch: /* Obsolete since 24.4. */ + case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); @@ -1903,17 +2050,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - case Bcondition_case: /* Obsolete since 24.4. */ + case Bcondition_case: /* Obsolete since 24.4. */ POP3; emit_call ("internal_lisp_condition_case", comp.lisp_obj_type, 3, args); break; - case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; - case Btemp_output_buffer_show: /* Obsolete since 24.1. */ + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); @@ -1923,7 +2070,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bunbind_all: /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, - but will be needed for tail-recursion elimination. */ + but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); break; @@ -2074,7 +2221,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bswitch: error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is - all of them) are done in Bconstant, below. This is done + all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have taken a constant pool index inline, but instead looks for a constant on the stack. */ @@ -2099,7 +2246,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - /* We're compiling Bswitch instead. */ + /* We're compiling Bswitch instead. */ ++pc; break; } @@ -2131,7 +2278,7 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, /* BYTESTR must have been produced by Emacs 20.2 or the earlier because they produced a raw 8-bit string for byte-code and now such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must + characters converted to multibyte form. Thus, now we must convert them back to the originally intended unibyte form. */ bytestr = Fstring_as_unibyte (bytestr); From 9cb5ce763d6e9ccb795704c1dfe0aa711b047426 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 20 Jun 2019 22:11:38 +0200 Subject: [PATCH 0084/1452] name basic blocks --- src/comp.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 0bc8be47a4d..d08ec8c7c9c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1073,12 +1073,14 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) } basic_block_t curr_bb; + char block_name[256]; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { if (i < bb_n && pc == bb_start_pc[i]) { ++i; - curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, NULL); + snprintf (block_name, sizeof (block_name), "bb_%d", i); + curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, block_name); curr_bb.terminated = false; } bb_map[pc] = curr_bb; From 8f0bb7d2647c0f5d4da5ec1af3ca1936ca42f221 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 20 Jun 2019 23:31:16 +0200 Subject: [PATCH 0085/1452] rework debug dump --- src/comp.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index d08ec8c7c9c..201ffa65597 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1111,8 +1111,12 @@ init_comp (int opt_level) } if (COMP_DEBUG > 1) { + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); + } gcc_jit_context_set_int_option (comp.ctxt, @@ -1268,6 +1272,8 @@ init_comp (int opt_level) static void release_comp (void) { + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); if (comp.ctxt) gcc_jit_context_release(comp.ctxt); From a31a164ea0b75c6523346fb9cc05233e036596d3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Jun 2019 17:12:35 +0200 Subject: [PATCH 0086/1452] imrpve macros --- src/comp.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 201ffa65597..c724f46a9b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -125,15 +125,17 @@ along with GNU Emacs. If not, see . */ /* Pop from the meta-stack, emit the call and push the result */ #define EMIT_CALL_N(name, nargs) \ - POP##nargs; \ - res = emit_call (name, comp.lisp_obj_type, nargs, args); \ - PUSH_RVAL (res); + do { \ + POP##nargs; \ + res = emit_call (name, comp.lisp_obj_type, nargs, args); \ + PUSH_RVAL (res); \ + } while (0) /* Generate appropriate case and emit call to function. */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ - EMIT_CALL_N (STR(F##name), nargs) \ + EMIT_CALL_N (STR(F##name), nargs); \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) From 7cbfd437a9bb2bcb5f4d776bb09572bb50965102 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Jun 2019 17:13:03 +0200 Subject: [PATCH 0087/1452] better logging into emit_scratch_callN --- src/comp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.c b/src/comp.c index c724f46a9b3..2b439fd2a56 100644 --- a/src/comp.c +++ b/src/comp.c @@ -712,6 +712,12 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) p[n] = 0x...; */ + snprintf (tmp_str, sizeof (tmp_str), "calling %s", f_name); + + gcc_jit_block_add_comment (comp.bblock->gcc_bb, + NULL, + tmp_str); + gcc_jit_lvalue *p = gcc_jit_function_new_local(comp.func, NULL, From b661d47434e54926f9612e9637d1feb763f653ef Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Jun 2019 17:13:31 +0200 Subject: [PATCH 0088/1452] better emit_lisp_obj_from_ptr --- src/comp.c | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2b439fd2a56..74102c5536d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -671,22 +671,31 @@ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; - char ptr_var_name[40]; + char scratch[256]; - int res = snprintf (ptr_var_name, sizeof (ptr_var_name), + int res = snprintf (scratch, sizeof (scratch), "lisp_obj_from_ptr_%u", i++); - if (res >= sizeof (ptr_var_name)) + if (res >= sizeof (scratch)) error ("Internal error, truncating temporary variable"); gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - ptr_var_name); + scratch); gcc_jit_rvalue *void_ptr = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, p); + if (SYMBOLP (p)) + { + snprintf (scratch, sizeof (scratch), + "Symbol %s", (char *) SDATA (SYMBOL_NAME (p))); + gcc_jit_block_add_comment (bblock->gcc_bb, + NULL, + scratch); + } + gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, emit_lval_XLP (lisp_obj), @@ -697,6 +706,8 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) static gcc_jit_rvalue * emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { + char tmp_str[256]; + /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ From 11ca831f996e1a0a732f811de75008b714f3836a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Jun 2019 17:36:18 +0200 Subject: [PATCH 0089/1452] pushhandler --- src/comp.c | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index 74102c5536d..8563ff0b8f0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1311,6 +1311,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t pc = 0; gcc_jit_rvalue *args[4]; unsigned op; + char scratch_name[256]; + unsigned pushhandler_n = 0; /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ @@ -1345,14 +1347,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); - char local_name[256]; for (int i = 0; i < stack_depth; ++i) { - snprintf (local_name, sizeof (local_name), "local_%d", i); + snprintf (scratch_name, sizeof (scratch_name), "local_%d", i); stack[i] = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - local_name); + scratch_name); } gcc_jit_block *prologue_bb = @@ -1557,27 +1558,41 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* struct handler *c = push_handler (POP, type); */ int handler_pc = FETCH2; - gcc_jit_rvalue *c; + snprintf (scratch_name, sizeof (scratch_name), "c_%u", + pushhandler_n); + gcc_jit_lvalue *c = + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + scratch_name); POP1; args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, type); - c = emit_call ("push_handler", comp.handler_ptr_type, 2, args); + gcc_jit_block_add_assignment ( + comp.bblock->gcc_bb, + NULL, + c, + emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + args[0] = gcc_jit_lvalue_get_address ( - gcc_jit_rvalue_dereference_field (c, - NULL, - comp.handler_jmp_field), - NULL); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_jmp_field), + NULL); #ifdef HAVE__SETJMP res = emit_call ("_setjmp", comp.int_type, 1, args); #else res = emit_call ("setjmp", comp.int_type, 1, args); #endif + snprintf (scratch_name, sizeof (scratch_name), "push_h_val_%u", + pushhandler_n); gcc_jit_block *push_h_val_block = - gcc_jit_function_new_block (comp.func, "push_h_val"); + gcc_jit_function_new_block (comp.func, scratch_name); emit_cond_jump ( - /* This negation is just to move to bool. */ + /* This negation is just to have a bool. */ gcc_jit_context_new_unary_op (comp.ctxt, NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, @@ -1598,18 +1613,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, m_handlerlist, gcc_jit_lvalue_as_rvalue( gcc_jit_rvalue_dereference_field ( - c, + gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_next_field))); /* PUSH (c->val); */ PUSH_LVAL ( - gcc_jit_rvalue_dereference_field (c, + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_val_field)); *comp.bblock = bb_orig; gcc_jit_block_end_with_jump (push_h_val_block, NULL, bb_map[handler_pc].gcc_bb); + ++pushhandler_n; } break; From 1d46302e725fabf7ccb2cfbe76c2b175039ac0f0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Jun 2019 18:04:16 +0200 Subject: [PATCH 0090/1452] dump all ops as comments --- src/comp.c | 288 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 168 insertions(+), 120 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8563ff0b8f0..e0688b626ae 100644 --- a/src/comp.c +++ b/src/comp.c @@ -122,6 +122,13 @@ along with GNU Emacs. If not, see . */ /* With most of the ops we need to do the same stuff so this macros are meant to save some typing. */ +#define CASE(op) \ + case op : \ + if (COMP_DEBUG) \ + gcc_jit_block_add_comment (comp.bblock->gcc_bb, \ + NULL, \ + "Opcode " STR(op)); + /* Pop from the meta-stack, emit the call and push the result */ #define EMIT_CALL_N(name, nargs) \ @@ -134,7 +141,7 @@ along with GNU Emacs. If not, see . */ /* Generate appropriate case and emit call to function. */ #define CASE_CALL_NARGS(name, nargs) \ - case B##name: \ + CASE (B##name) \ EMIT_CALL_N (STR(F##name), nargs); \ break @@ -1386,36 +1393,47 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, switch (op) { - case Bstack_ref1: - case Bstack_ref2: - case Bstack_ref3: - case Bstack_ref4: - case Bstack_ref5: + CASE (Bstack_ref1) + goto stack_ref; + CASE (Bstack_ref2) + goto stack_ref; + CASE (Bstack_ref3) + goto stack_ref; + CASE (Bstack_ref4) + goto stack_ref; + CASE (Bstack_ref5) + stack_ref: PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); break; - case Bstack_ref6: + CASE (Bstack_ref6) PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); break; - case Bstack_ref7: + CASE (Bstack_ref7) PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); break; - case Bvarref7: + CASE (Bvarref7) op = FETCH2; goto varref; - case Bvarref: - case Bvarref1: - case Bvarref2: - case Bvarref3: - case Bvarref4: - case Bvarref5: + CASE (Bvarref) + goto varref_count; + CASE (Bvarref1) + goto varref_count; + CASE (Bvarref2) + goto varref_count; + CASE (Bvarref3) + goto varref_count; + CASE (Bvarref4) + goto varref_count; + CASE (Bvarref5) + varref_count: op -= Bvarref; goto varref; - case Bvarref6: + CASE (Bvarref6) op = FETCH; varref: { @@ -1425,20 +1443,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bvarset: - case Bvarset1: - case Bvarset2: - case Bvarset3: - case Bvarset4: - case Bvarset5: + CASE (Bvarset) + goto varset_count; + CASE (Bvarset1) + goto varset_count; + CASE (Bvarset2) + goto varset_count; + CASE (Bvarset3) + goto varset_count; + CASE (Bvarset4) + goto varset_count; + CASE (Bvarset5) + varset_count: op -= Bvarset; goto varset; - case Bvarset7: + CASE (Bvarset7) op = FETCH2; goto varset; - case Bvarset6: + CASE (Bvarset6) op = FETCH; varset: { @@ -1454,20 +1478,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Bvarbind6: + CASE (Bvarbind6) op = FETCH; goto varbind; - case Bvarbind7: + CASE (Bvarbind7) op = FETCH2; goto varbind; - case Bvarbind: - case Bvarbind1: - case Bvarbind2: - case Bvarbind3: - case Bvarbind4: - case Bvarbind5: + CASE (Bvarbind) + goto varbind_count; + CASE (Bvarbind1) + goto varbind_count; + CASE (Bvarbind2) + goto varbind_count; + CASE (Bvarbind3) + goto varbind_count; + CASE (Bvarbind4) + goto varbind_count; + CASE (Bvarbind5) + varbind_count: op -= Bvarbind; varbind: { @@ -1478,20 +1508,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bcall6: + CASE (Bcall6) op = FETCH; goto docall; - case Bcall7: + CASE (Bcall7) op = FETCH2; goto docall; - case Bcall: - case Bcall1: - case Bcall2: - case Bcall3: - case Bcall4: - case Bcall5: + CASE (Bcall) + goto docall_count; + CASE (Bcall1) + goto docall_count; + CASE (Bcall2) + goto docall_count; + CASE (Bcall3) + goto docall_count; + CASE (Bcall4) + goto docall_count; + CASE (Bcall5) + docall_count: op -= Bcall; docall: { @@ -1502,20 +1538,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bunbind6: + CASE (Bunbind6) op = FETCH; goto dounbind; - case Bunbind7: + CASE (Bunbind7) op = FETCH2; goto dounbind; - case Bunbind: - case Bunbind1: - case Bunbind2: - case Bunbind3: - case Bunbind4: - case Bunbind5: + CASE (Bunbind) + goto dounbind_count; + CASE (Bunbind1) + goto dounbind_count; + CASE (Bunbind2) + goto dounbind_count; + CASE (Bunbind3) + goto dounbind_count; + CASE (Bunbind4) + goto dounbind_count; + CASE (Bunbind5) + dounbind_count: op -= Bunbind; dounbind: { @@ -1527,7 +1569,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Bpophandler: + CASE (Bpophandler) { /* current_thread->m_handlerlist = current_thread->m_handlerlist->next; */ @@ -1548,11 +1590,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bpushconditioncase: /* New in 24.4. */ + CASE (Bpushconditioncase) /* New in 24.4. */ type = CATCHER; goto pushhandler; - case Bpushcatch: /* New in 24.4. */ + CASE (Bpushcatch) /* New in 24.4. */ type = CONDITION_CASE;; pushhandler: { @@ -1632,7 +1674,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (nth, 2); CASE_CALL_NARGS (symbolp, 1); - case Bconsp: + CASE (Bconsp) POP1; res = emit_cast (comp.bool_type, emit_CONSP (args[0])); @@ -1652,14 +1694,18 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (cdr, 1); CASE_CALL_NARGS (cons, 2); - case BlistN: + CASE (BlistN) op = FETCH; goto make_list; - case Blist1: - case Blist2: - case Blist3: - case Blist4: + CASE (Blist1) + goto make_list_count; + CASE (Blist2) + goto make_list_count; + CASE (Blist3) + goto make_list_count; + CASE (Blist4) + make_list_count: op = op - Blist1; make_list: { @@ -1686,21 +1732,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (get, 2); CASE_CALL_NARGS (substring, 3); - case Bconcat2: + CASE (Bconcat2) EMIT_SCRATCH_CALL_N ("Fconcat", 2); break; - case Bconcat3: + CASE (Bconcat3) EMIT_SCRATCH_CALL_N ("Fconcat", 3); break; - case Bconcat4: + CASE (Bconcat4) EMIT_SCRATCH_CALL_N ("Fconcat", 4); break; - case BconcatN: + CASE (BconcatN) op = FETCH; EMIT_SCRATCH_CALL_N ("Fconcat", op); break; - case Bsub1: + CASE (Bsub1) { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -1760,7 +1806,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Badd1: + CASE (Badd1) { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM @@ -1820,31 +1866,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Beqlsign: + CASE (Beqlsign) EMIT_ARITHCOMPARE (ARITH_EQUAL); break; - case Bgtr: + CASE (Bgtr) EMIT_ARITHCOMPARE (ARITH_GRTR); break; - case Blss: + CASE (Blss) EMIT_ARITHCOMPARE (ARITH_LESS); break; - case Bleq: + CASE (Bleq) EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); break; - case Bgeq: + CASE (Bgeq) EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); break; - case Bdiff: + CASE (Bdiff) EMIT_SCRATCH_CALL_N ("Fminus", 2); break; - case Bnegate: + CASE (Bnegate) { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -1899,19 +1945,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb); } break; - case Bplus: + CASE (Bplus) EMIT_SCRATCH_CALL_N ("Fplus", 2); break; - case Bmax: + CASE (Bmax) EMIT_SCRATCH_CALL_N ("Fmax", 2); break; - case Bmin: + CASE (Bmin) EMIT_SCRATCH_CALL_N ("Fmin", 2); break; - case Bmult: + CASE (Bmult) EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; - case Bpoint: + CASE (Bpoint) args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1925,11 +1971,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (goto_char, 1); - case Binsert: + CASE (Binsert) EMIT_SCRATCH_CALL_N ("Finsert", 1); break; - case Bpoint_max: + CASE (Bpoint_max) args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1941,7 +1987,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - case Bpoint_min: + CASE (Bpoint_min) args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1956,14 +2002,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (char_after, 1); CASE_CALL_NARGS (following_char, 0); - case Bpreceding_char: + CASE (Bpreceding_char) res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_RVAL (res); break; CASE_CALL_NARGS (current_column, 0); - case Bindent_to: + CASE (Bindent_to) POP1; args[1] = nil; res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); @@ -1977,13 +2023,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (current_buffer, 0); CASE_CALL_NARGS (set_buffer, 1); - case Bsave_current_buffer: /* Obsolete since ??. */ - case Bsave_current_buffer_1: + CASE (Bsave_current_buffer) /* Obsolete since ??. */ + goto save_current; + CASE (Bsave_current_buffer_1) + save_current: emit_call ("record_unwind_current_buffer", comp.void_type, 0, NULL); break; - case Binteractive_p: /* Obsolete since 24.1. */ + CASE (Binteractive_p) /* Obsolete since 24.1. */ PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); @@ -2002,11 +2050,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (widen, 0); CASE_CALL_NARGS (end_of_line, 1); - case Bconstant2: + CASE (Bconstant2) goto do_constant; break; - case Bgoto: + CASE (Bgoto) op = FETCH2; gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, @@ -2014,21 +2062,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; break; - case Bgotoifnil: + CASE (Bgotoifnil) op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case Bgotoifnonnil: + CASE (Bgotoifnonnil) op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case Bgotoifnilelsepop: + CASE (Bgotoifnilelsepop) op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), @@ -2037,7 +2085,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case Bgotoifnonnilelsepop: + CASE (Bgotoifnonnilelsepop) op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), @@ -2046,7 +2094,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case Breturn: + CASE (Breturn) POP1; gcc_jit_block_end_with_return(comp.bblock->gcc_bb, NULL, @@ -2054,24 +2102,24 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; break; - case Bdiscard: + CASE (Bdiscard) POP1; break; - case Bdup: + CASE (Bdup) PUSH_LVAL (TOS); break; - case Bsave_excursion: + CASE (Bsave_excursion) res = emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; - case Bsave_window_excursion: /* Obsolete since 24.1. */ + CASE (Bsave_window_excursion) /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_save_window_excursion", 1); break; - case Bsave_restriction: + CASE (Bsave_restriction) args[0] = emit_lisp_obj_from_ptr (comp.bblock, save_restriction_restore); args[1] = emit_call ("save_restriction_save", @@ -2081,29 +2129,29 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - case Bcatch: /* Obsolete since 24.4. */ + CASE (Bcatch) /* Obsolete since 24.4. */ POP2; args[2] = args[1]; args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; - case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ + CASE (Bunwind_protect) /* FIXME: avoid closure for lexbind. */ POP1; emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - case Bcondition_case: /* Obsolete since 24.4. */ + CASE (Bcondition_case) /* Obsolete since 24.4. */ POP3; emit_call ("internal_lisp_condition_case", comp.lisp_obj_type, 3, args); break; - case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_setup) /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; - case Btemp_output_buffer_show: /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_show) /* Obsolete since 24.1. */ POP2; emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); @@ -2111,7 +2159,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; - case Bunbind_all: /* Obsolete. Never used. */ + CASE (Bunbind_all) /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); @@ -2123,11 +2171,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (upcase, 1); CASE_CALL_NARGS (downcase, 1); - case Bstringeqlsign: + CASE (Bstringeqlsign) EMIT_CALL_N ("Fstring_equal", 2); break; - case Bstringlss: + CASE (Bstringlss) EMIT_CALL_N ("Fstring_lessp", 2); break; @@ -2139,25 +2187,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (setcar, 2); CASE_CALL_NARGS (setcdr, 2); - case Bcar_safe: + CASE (Bcar_safe) EMIT_CALL_N ("CAR_SAFE", 1); break; - case Bcdr_safe: + CASE (Bcdr_safe) EMIT_CALL_N ("CDR_SAFE", 1); break; - case Bnconc: + CASE (Bnconc) EMIT_SCRATCH_CALL_N ("Fnconc", 2); break; - case Bquo: + CASE (Bquo) EMIT_SCRATCH_CALL_N ("Fquo", 2); break; CASE_CALL_NARGS (rem, 2); - case Bnumberp: + CASE (Bnumberp) POP1; res = emit_NUMBERP (args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2167,7 +2215,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - case Bintegerp: + CASE (Bintegerp) POP1; res = emit_INTEGERP(args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2177,7 +2225,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - case BRgoto: + CASE (BRgoto) op = FETCH - 128; op += pc; gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, @@ -2186,7 +2234,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; break; - case BRgotoifnil: + CASE (BRgotoifnil) op = FETCH - 128; op += pc; POP1; @@ -2194,7 +2242,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case BRgotoifnonnil: + CASE (BRgotoifnonnil) op = FETCH - 128; op += pc; POP1; @@ -2202,7 +2250,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case BRgotoifnilelsepop: + CASE (BRgotoifnilelsepop) op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, @@ -2212,7 +2260,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case BRgotoifnonnilelsepop: + CASE (BRgotoifnonnilelsepop) op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_NE, @@ -2222,12 +2270,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case BinsertN: + CASE (BinsertN) op = FETCH; EMIT_SCRATCH_CALL_N ("Finsert", op); break; - case Bstack_set: + CASE (Bstack_set) /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ op = FETCH; POP1; @@ -2238,7 +2286,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - case Bstack_set2: + CASE (Bstack_set2) op = FETCH2; POP1; gcc_jit_block_add_assignment (comp.bblock->gcc_bb, @@ -2247,7 +2295,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - case BdiscardN: + CASE (BdiscardN) op = FETCH; if (op & 0x80) { @@ -2261,7 +2309,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, stack -= op; break; - case Bswitch: + CASE (Bswitch) error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done @@ -2272,7 +2320,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; default: - case Bconstant: + CASE (Bconstant) { if (op < Bconstant || op > Bconstant + vector_size) goto fail; From cc78d4c34e5b5701c893bac88e86af6791e204e2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 10:18:35 +0200 Subject: [PATCH 0091/1452] fix pushhandler --- src/comp.c | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index e0688b626ae..61809a01227 100644 --- a/src/comp.c +++ b/src/comp.c @@ -167,6 +167,8 @@ along with GNU Emacs. If not, see . */ typedef struct { gcc_jit_block *gcc_bb; + /* When non zero indicates a stack pointer restart. */ + gcc_jit_lvalue **top; bool terminated; } basic_block_t; @@ -1060,6 +1062,8 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) case Bgotoifnonnil: case Bgotoifnilelsepop: case Bgotoifnonnilelsepop: + case Bpushcatch: + case Bpushconditioncase: op = FETCH2; bb_start_pc[bb_n++] = op; new_bb = true; @@ -1075,8 +1079,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) new_bb = true; break; /* Other ops changing bb */ - case Bpushcatch: - case Bpushconditioncase: case Bsub1: case Badd1: case Bnegate: @@ -1107,6 +1109,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) ++i; snprintf (block_name, sizeof (block_name), "bb_%d", i); curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, block_name); + curr_bb.top = NULL; curr_bb.terminated = false; } bb_map[pc] = curr_bb; @@ -1389,6 +1392,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; } comp.bblock = &bb_map[pc]; + if (bb_map[pc].top) + stack = bb_map[pc].top; op = FETCH; switch (op) @@ -1591,11 +1596,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } CASE (Bpushconditioncase) /* New in 24.4. */ - type = CATCHER; + type = CONDITION_CASE; goto pushhandler; CASE (Bpushcatch) /* New in 24.4. */ - type = CONDITION_CASE;; + type = CATCHER; pushhandler: { /* struct handler *c = push_handler (POP, type); */ @@ -1643,6 +1648,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb, push_h_val_block); + gcc_jit_lvalue **stack_to_restore = stack; + /* This emit the handler part. */ + basic_block_t bb_orig = *comp.bblock; comp.bblock->gcc_bb = push_h_val_block; /* current_thread->m_handlerlist = c->next; */ @@ -1663,10 +1671,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_val_field)); + bb_map[handler_pc].top = stack; *comp.bblock = bb_orig; gcc_jit_block_end_with_jump (push_h_val_block, NULL, bb_map[handler_pc].gcc_bb); + + stack = stack_to_restore; ++pushhandler_n; } break; From 39390edcf95f3fe21dbb68e0e35f1d8b5b93588e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 11:44:30 +0200 Subject: [PATCH 0092/1452] jmp_buf as struct + offset workaround --- src/comp.c | 42 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 61809a01227..aee7ca99463 100644 --- a/src/comp.c +++ b/src/comp.c @@ -186,11 +186,12 @@ typedef struct { gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; - gcc_jit_type *jmp_buf_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* struct jmp_buf. */ + gcc_jit_struct *jmp_buf; /* struct handler. */ gcc_jit_struct *handler; gcc_jit_field *handler_jmp_field; @@ -773,18 +774,40 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +/* opaque jmp_buf definition */ + +static void +define_jmp_buf (void) +{ + gcc_jit_field *field = + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (jmp_buf)), + "stuff"); + comp.jmp_buf = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_jmp_buf", + 1, &field); +} + /* struct handler definition */ static void define_handler_struct (void) { - comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "handler"); + comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); comp.handler_ptr_type = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler)); comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, NULL, - comp.jmp_buf_type, + gcc_jit_struct_as_type ( + comp.jmp_buf), "jmp"); comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -821,6 +844,13 @@ define_handler_struct (void) NULL, comp.int_type, "bytecode_dest"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + 4), + "pad"), comp.handler_jmp_field, gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1273,11 +1303,6 @@ init_comp (int opt_level) comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); - /* Opaque definition for jmp_buf. */ - comp.jmp_buf_type = gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - sizeof (jmp_buf)); comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, @@ -1288,6 +1313,7 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); comp.current_thread = From 3f96f72b59a627944040228984ec48cf0f74ecec Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 12:08:59 +0200 Subject: [PATCH 0093/1452] add non locals tests --- test/src/comp-tests.el | 55 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6a643df9d3e..6a7370a880c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -345,6 +345,61 @@ (buffer-string)) "abcd"))) +(ert-deftest comp-tests-non-locals () + "Test non locals." + (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)) + + (byte-compile #'comp-tests-condition-case-0-f) + (native-compile #'comp-tests-condition-case-0-f) + (byte-compile #'comp-tests-condition-case-1-f) + (native-compile #'comp-tests-condition-case-1-f) + (byte-compile #'comp-tests-catch-f) + (native-compile #'comp-tests-catch-f) + (byte-compile #'comp-tests-throw-f) + (native-compile #'comp-tests-throw-f) + + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched")) + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3))))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) From 0406c74b6083e0ddf08e386d935c07f6493e41d4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 16:41:04 +0200 Subject: [PATCH 0094/1452] fix awful pad hack in define_handler_struct --- src/comp.c | 75 ++++++++++++++++++++---------------------------------- 1 file changed, 28 insertions(+), 47 deletions(-) diff --git a/src/comp.c b/src/comp.c index aee7ca99463..fe3fac606d9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -818,56 +818,37 @@ define_handler_struct (void) comp.handler_ptr_type, "next"); gcc_jit_field *fields[] = - { gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "type"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "tag_or_ch"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "nonlocal_exit"), + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, val)), + "pad0"), comp.handler_val_field, comp.handler_next_field, - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.handler_ptr_type, - "nextfree"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "bytecode_top"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "bytecode_dest"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - 4), - "pad"), + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, jmp) + - offsetof (struct handler, next) + - sizeof (((struct handler *) 0)->next)), + "pad1"), comp.handler_jmp_field, - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.emacs_int_type, - "f_lisp_eval_depth"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.ptrdiff_type, - "pdlcount"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "poll_suppress_count"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "interrupt_input_blocked") }; + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct handler) + - offsetof (struct handler, jmp) + - sizeof (((struct handler *) 0)->jmp)), + "pad2") }; gcc_jit_struct_set_fields (comp.handler, NULL, sizeof (fields) / sizeof (*fields), From a328ce70ea6499239c47551f62b4428e556f52d3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 16:54:06 +0200 Subject: [PATCH 0095/1452] fix struct thread_state definition --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index fe3fac606d9..b2a16d84e12 100644 --- a/src/comp.c +++ b/src/comp.c @@ -887,13 +887,13 @@ define_thread_state_struct (void) sizeof (struct thread_state) - offsetof (struct thread_state, m_handlerlist) - - sizeof (struct handler *)), + - sizeof (((struct thread_state *) 0)->m_handlerlist)), "pad1") }; comp.thread_state = gcc_jit_context_new_struct_type (comp.ctxt, NULL, - "thread_state", + "comp_thread_state", sizeof (fields) / sizeof (*fields), fields); comp.thread_state_ptr_type = From 175d932b95ac918da6b9d0e4341a5e7715f04a39 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 17:20:42 +0200 Subject: [PATCH 0096/1452] set target stacks for safety --- src/comp.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/comp.c b/src/comp.c index b2a16d84e12..63318c5a58c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2078,6 +2078,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, bb_map[op].gcc_bb); comp.bblock->terminated = true; + bb_map[op].top = stack; break; CASE (Bgotoifnil) @@ -2085,6 +2086,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (Bgotoifnonnil) @@ -2092,6 +2094,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (Bgotoifnilelsepop) @@ -2100,6 +2103,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; @@ -2109,6 +2113,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; @@ -2250,6 +2255,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, bb_map[op].gcc_bb); comp.bblock->terminated = true; + bb_map[op].top = stack; break; CASE (BRgotoifnil) @@ -2258,6 +2264,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (BRgotoifnonnil) @@ -2266,6 +2273,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (BRgotoifnilelsepop) @@ -2275,6 +2283,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; @@ -2285,6 +2294,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; From ee38ed1e7de2415b54cdfbd59a6f06d09b01779f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 17:30:00 +0200 Subject: [PATCH 0097/1452] add discard macro --- src/comp.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 63318c5a58c..31088f23323 100644 --- a/src/comp.c +++ b/src/comp.c @@ -79,6 +79,8 @@ along with GNU Emacs. If not, see . */ #define TOS (*(stack - 1)) +#define DISCARD(n) (stack -= (n)) + #define POP0 #define POP1 \ @@ -2104,7 +2106,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (Bgotoifnonnilelsepop) @@ -2114,7 +2116,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (Breturn) @@ -2126,7 +2128,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bdiscard) - POP1; + DISCARD (1); break; CASE (Bdup) @@ -2135,7 +2137,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bsave_excursion) res = emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); + comp.void_type, 0, args); break; CASE (Bsave_window_excursion) /* Obsolete since 24.1. */ @@ -2284,7 +2286,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (BRgotoifnonnilelsepop) @@ -2295,7 +2297,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (BinsertN) @@ -2335,7 +2337,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); } - stack -= op; + DISCARD (op); break; CASE (Bswitch) error ("Bswitch not supported"); From d9e125793c36a06f0aca984473a911a92d1bbd7f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 17:34:40 +0200 Subject: [PATCH 0098/1452] postfix struct with _s --- src/comp.c | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 31088f23323..0261cccc381 100644 --- a/src/comp.c +++ b/src/comp.c @@ -193,15 +193,15 @@ typedef struct { gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; /* struct jmp_buf. */ - gcc_jit_struct *jmp_buf; + gcc_jit_struct *jmp_buf_s; /* struct handler. */ - gcc_jit_struct *handler; + gcc_jit_struct *handler_s; gcc_jit_field *handler_jmp_field; gcc_jit_field *handler_val_field; gcc_jit_field *handler_next_field; gcc_jit_type *handler_ptr_type; /* struct thread_state. */ - gcc_jit_struct *thread_state; + gcc_jit_struct *thread_state_s; gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread; @@ -790,7 +790,7 @@ define_jmp_buf (void) comp.char_type, sizeof (jmp_buf)), "stuff"); - comp.jmp_buf = + comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_jmp_buf", @@ -802,14 +802,15 @@ define_jmp_buf (void) static void define_handler_struct (void) { - comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); + comp.handler_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); comp.handler_ptr_type = - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler)); + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s)); comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, NULL, gcc_jit_struct_as_type ( - comp.jmp_buf), + comp.jmp_buf_s), "jmp"); comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -851,7 +852,7 @@ define_handler_struct (void) - offsetof (struct handler, jmp) - sizeof (((struct handler *) 0)->jmp)), "pad2") }; - gcc_jit_struct_set_fields (comp.handler, + gcc_jit_struct_set_fields (comp.handler_s, NULL, sizeof (fields) / sizeof (*fields), fields); @@ -892,14 +893,14 @@ define_thread_state_struct (void) - sizeof (((struct thread_state *) 0)->m_handlerlist)), "pad1") }; - comp.thread_state = + comp.thread_state_s = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_thread_state", sizeof (fields) / sizeof (*fields), fields); comp.thread_state_ptr_type = - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state)); + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); } /* Declare a substitute for PSEUDOVECTORP as inline function. */ From dbf05d0d22b1274898a9c545962abeef465d4119 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 18:18:57 +0200 Subject: [PATCH 0099/1452] add format_string --- src/comp.c | 74 ++++++++++++++++++++++++++---------------------------- 1 file changed, 35 insertions(+), 39 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0261cccc381..f2e7c2d1021 100644 --- a/src/comp.c +++ b/src/comp.c @@ -243,6 +243,19 @@ void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); +static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) +format_string (const char *format, ...) +{ + static char scratch_area[512]; + va_list va; + va_start (va, format); + int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va); + if (res >= sizeof (scratch_area)) + error ("Truncating string"); + va_end (va); + return scratch_area; +} + static void bcall0 (Lisp_Object f) { @@ -683,30 +696,23 @@ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; - char scratch[256]; - int res = snprintf (scratch, sizeof (scratch), - "lisp_obj_from_ptr_%u", i++); - if (res >= sizeof (scratch)) - error ("Internal error, truncating temporary variable"); - - gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - scratch); + gcc_jit_lvalue *lisp_obj = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("lisp_obj_from_ptr_%u", i++)); gcc_jit_rvalue *void_ptr = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, p); if (SYMBOLP (p)) - { - snprintf (scratch, sizeof (scratch), - "Symbol %s", (char *) SDATA (SYMBOL_NAME (p))); - gcc_jit_block_add_comment (bblock->gcc_bb, - NULL, - scratch); - } + gcc_jit_block_add_comment ( + bblock->gcc_bb, + NULL, + format_string ("Symbol %s", + (char *) SDATA (SYMBOL_NAME (p)))); gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, @@ -718,8 +724,6 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) static gcc_jit_rvalue * emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { - char tmp_str[256]; - /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -735,11 +739,9 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) p[n] = 0x...; */ - snprintf (tmp_str, sizeof (tmp_str), "calling %s", f_name); - gcc_jit_block_add_comment (comp.bblock->gcc_bb, NULL, - tmp_str); + format_string ("calling %s", f_name)); gcc_jit_lvalue *p = gcc_jit_function_new_local(comp.func, @@ -1115,14 +1117,13 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) } basic_block_t curr_bb; - char block_name[256]; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { if (i < bb_n && pc == bb_start_pc[i]) { ++i; - snprintf (block_name, sizeof (block_name), "bb_%d", i); - curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, block_name); + curr_bb.gcc_bb = + gcc_jit_function_new_block (comp.func, format_string ("bb_%d", i)); curr_bb.top = NULL; curr_bb.terminated = false; } @@ -1331,7 +1332,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t pc = 0; gcc_jit_rvalue *args[4]; unsigned op; - char scratch_name[256]; unsigned pushhandler_n = 0; /* Meta-stack we use to flat the bytecode written for push and pop @@ -1368,13 +1368,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, GCC_JIT_FUNCTION_EXPORTED, false); for (int i = 0; i < stack_depth; ++i) - { - snprintf (scratch_name, sizeof (scratch_name), "local_%d", i); - stack[i] = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - scratch_name); - } + stack[i] = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("local_%d", i)); gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); @@ -1615,13 +1612,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* struct handler *c = push_handler (POP, type); */ int handler_pc = FETCH2; - snprintf (scratch_name, sizeof (scratch_name), "c_%u", - pushhandler_n); gcc_jit_lvalue *c = gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, - scratch_name); + format_string ("c_%u", + pushhandler_n)); POP1; args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1644,10 +1640,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, #else res = emit_call ("setjmp", comp.int_type, 1, args); #endif - snprintf (scratch_name, sizeof (scratch_name), "push_h_val_%u", - pushhandler_n); gcc_jit_block *push_h_val_block = - gcc_jit_function_new_block (comp.func, scratch_name); + gcc_jit_function_new_block (comp.func, + format_string ("push_h_val_%u", + pushhandler_n)); emit_cond_jump ( /* This negation is just to have a bool. */ gcc_jit_context_new_unary_op (comp.ctxt, From 3a64ec8021fee9694ead7b551d4ecbe7ef8ea869 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 18:29:27 +0200 Subject: [PATCH 0100/1452] bblock -> block --- src/comp.c | 124 ++++++++++++++++++++++++++--------------------------- 1 file changed, 62 insertions(+), 62 deletions(-) diff --git a/src/comp.c b/src/comp.c index f2e7c2d1021..1bbf1a0136e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -48,7 +48,7 @@ along with GNU Emacs. If not, see . */ #define PUSH_LVAL(obj) \ do { \ CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ *stack, \ gcc_jit_lvalue_as_rvalue(obj)); \ @@ -58,7 +58,7 @@ along with GNU Emacs. If not, see . */ #define PUSH_RVAL(obj) \ do { \ CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ *stack, \ (obj)); \ @@ -127,7 +127,7 @@ along with GNU Emacs. If not, see . */ #define CASE(op) \ case op : \ if (COMP_DEBUG) \ - gcc_jit_block_add_comment (comp.bblock->gcc_bb, \ + gcc_jit_block_add_comment (comp.block->gcc_bb, \ NULL, \ "Opcode " STR(op)); @@ -222,7 +222,7 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; - basic_block_t *bblock; /* Current basic block */ + basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -412,12 +412,12 @@ INLINE static void emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { - gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, + gcc_jit_block_end_with_conditional (comp.block->gcc_bb, NULL, test, then_target, else_target); - comp.bblock->terminated = true; + comp.block->terminated = true; } /* Close current basic block emitting a comparison between two rval. */ @@ -449,7 +449,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) NULL, comp.cast_union_type, "union_cast"); - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, gcc_jit_lvalue_access_field (tmp_u, NULL, @@ -693,7 +693,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ /* TODO should we pass the bb? */ static gcc_jit_rvalue * -emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) +emit_lisp_obj_from_ptr (basic_block_t *block, void *p) { static unsigned i; @@ -709,12 +709,12 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) if (SYMBOLP (p)) gcc_jit_block_add_comment ( - bblock->gcc_bb, + block->gcc_bb, NULL, format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); - gcc_jit_block_add_assignment (bblock->gcc_bb, + gcc_jit_block_add_assignment (block->gcc_bb, NULL, emit_lval_XLP (lisp_obj), void_ptr); @@ -739,7 +739,7 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) p[n] = 0x...; */ - gcc_jit_block_add_comment (comp.bblock->gcc_bb, + gcc_jit_block_add_comment (comp.block->gcc_bb, NULL, format_string ("calling %s", f_name)); @@ -749,7 +749,7 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, + gcc_jit_block_add_assignment(comp.block->gcc_bb, NULL, p, comp.scratch); @@ -761,7 +761,7 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) GCC_JIT_TYPE_UNSIGNED_INT), i); gcc_jit_block_add_assignment ( - comp.bblock->gcc_bb, + comp.block->gcc_bb, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, @@ -939,9 +939,9 @@ define_PSEUDOVECTORP (void) gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); /* Set current context as needed */ - basic_block_t bblock = { .gcc_bb = initial_block, + basic_block_t block = { .gcc_bb = initial_block, .terminated = false }; - comp.bblock = &bblock; + comp.block = █ comp.func = comp.pseudovectorp; emit_cond_jump ( @@ -950,7 +950,7 @@ define_PSEUDOVECTORP (void) call_pseudovector_typep_b, ret_false_b); - comp.bblock->gcc_bb = ret_false_b; + comp.block->gcc_bb = ret_false_b; gcc_jit_block_end_with_return (ret_false_b, NULL, gcc_jit_context_new_rvalue_from_int( @@ -961,7 +961,7 @@ define_PSEUDOVECTORP (void) gcc_jit_rvalue *args[2] = { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; - comp.bblock->gcc_bb = call_pseudovector_typep_b; + comp.block->gcc_bb = call_pseudovector_typep_b; /* FIXME XUNTAG missing here. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, @@ -999,22 +999,22 @@ define_bool_to_lisp_obj (void) gcc_jit_function_new_block (comp.bool_to_lisp_obj, "ret_nil"); /* Set current context as needed */ - basic_block_t bblock = { .gcc_bb = initial_block, + basic_block_t block = { .gcc_bb = initial_block, .terminated = false }; - comp.bblock = &bblock; + comp.block = █ comp.func = comp.bool_to_lisp_obj; emit_cond_jump (gcc_jit_param_as_rvalue (param), ret_t_block, ret_nil_block); - bblock.gcc_bb = ret_t_block; + block.gcc_bb = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_lisp_obj_from_ptr (&bblock, Qt)); - bblock.gcc_bb = ret_nil_block; + emit_lisp_obj_from_ptr (&block, Qt)); + block.gcc_bb = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_lisp_obj_from_ptr (&bblock, Qnil)); + emit_lisp_obj_from_ptr (&block, Qnil)); } static int @@ -1027,7 +1027,7 @@ ucmp(const void *a, const void *b) /* Compute and initialize all basic blocks. */ static basic_block_t * -compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) +compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) { ptrdiff_t pc = 0; unsigned op; @@ -1376,7 +1376,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); - basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); + basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); @@ -1384,7 +1384,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (&bb_map[0], Qnil); - comp.bblock = NULL; + comp.block = NULL; while (pc < bytestr_length) { @@ -1392,13 +1392,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* If we are changing BB and the last was one wasn't terminated terminate it with a fall through. */ - if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb && - !comp.bblock->terminated) + if (comp.block && comp.block->gcc_bb != bb_map[pc].gcc_bb && + !comp.block->terminated) { - gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, bb_map[pc].gcc_bb); - comp.bblock->terminated = true; + gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[pc].gcc_bb); + comp.block->terminated = true; } - comp.bblock = &bb_map[pc]; + comp.block = &bb_map[pc]; if (bb_map[pc].top) stack = bb_map[pc].top; op = FETCH; @@ -1449,7 +1449,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); break; @@ -1480,7 +1480,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1513,7 +1513,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); pop (1, &stack, &args[1]); res = emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_RVAL (res); @@ -1591,7 +1591,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.m_handlerlist); gcc_jit_block_add_assignment( - comp.bblock->gcc_bb, + comp.block->gcc_bb, NULL, m_handlerlist, gcc_jit_lvalue_as_rvalue ( @@ -1623,7 +1623,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.int_type, type); gcc_jit_block_add_assignment ( - comp.bblock->gcc_bb, + comp.block->gcc_bb, NULL, c, emit_call ("push_handler", comp.handler_ptr_type, 2, args)); @@ -1657,14 +1657,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue **stack_to_restore = stack; /* This emit the handler part. */ - basic_block_t bb_orig = *comp.bblock; - comp.bblock->gcc_bb = push_h_val_block; + basic_block_t bb_orig = *comp.block; + comp.block->gcc_bb = push_h_val_block; /* current_thread->m_handlerlist = c->next; */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field (comp.current_thread, NULL, comp.m_handlerlist); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, + gcc_jit_block_add_assignment(comp.block->gcc_bb, NULL, m_handlerlist, gcc_jit_lvalue_as_rvalue( @@ -1678,7 +1678,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, comp.handler_val_field)); bb_map[handler_pc].top = stack; - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (push_h_val_block, NULL, bb_map[handler_pc].gcc_bb); @@ -1807,14 +1807,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, TOS, emit_make_fixnum (sub1_inline_block, sub1_inline_res)); - basic_block_t bb_orig = *comp.bblock; + basic_block_t bb_orig = *comp.block; - comp.bblock->gcc_bb = sub1_fcall_block; + comp.block->gcc_bb = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (sub1_inline_block, NULL, bb_map[pc].gcc_bb); @@ -1867,14 +1867,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, TOS, emit_make_fixnum (add1_inline_block, add1_inline_res)); - basic_block_t bb_orig = *comp.bblock; + basic_block_t bb_orig = *comp.block; - comp.bblock->gcc_bb = add1_fcall_block; + comp.block->gcc_bb = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (add1_inline_block, NULL, bb_map[pc].gcc_bb); @@ -1950,11 +1950,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, TOS, emit_make_fixnum (negate_inline_block, negate_inline_res)); - basic_block_t bb_orig = *comp.bblock; + basic_block_t bb_orig = *comp.block; - comp.bblock->gcc_bb = negate_fcall_block; + comp.block->gcc_bb = negate_fcall_block; EMIT_SCRATCH_CALL_N ("Fminus", 1); - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (negate_inline_block, NULL, bb_map[pc].gcc_bb); @@ -2049,7 +2049,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Binteractive_p) /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, + PUSH_RVAL (emit_lisp_obj_from_ptr (comp.block, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); @@ -2073,10 +2073,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bgoto) op = FETCH2; - gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[op].gcc_bb); - comp.bblock->terminated = true; + comp.block->terminated = true; bb_map[op].top = stack; break; @@ -2118,10 +2118,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Breturn) POP1; - gcc_jit_block_end_with_return(comp.bblock->gcc_bb, + gcc_jit_block_end_with_return(comp.block->gcc_bb, NULL, args[0]); - comp.bblock->terminated = true; + comp.block->terminated = true; break; CASE (Bdiscard) @@ -2142,7 +2142,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bsave_restriction) - args[0] = emit_lisp_obj_from_ptr (comp.bblock, + args[0] = emit_lisp_obj_from_ptr (comp.block, save_restriction_restore); args[1] = emit_call ("save_restriction_save", comp.lisp_obj_type, @@ -2154,7 +2154,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bcatch) /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); + args[1] = emit_lisp_obj_from_ptr (comp.block, eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -2250,10 +2250,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (BRgoto) op = FETCH - 128; op += pc; - gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[op].gcc_bb); - comp.bblock->terminated = true; + comp.block->terminated = true; bb_map[op].top = stack; break; @@ -2307,7 +2307,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; POP1; if (op > 0) - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, *(stack - op), args[0]); @@ -2316,7 +2316,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bstack_set2) op = FETCH2; POP1; - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, *(stack - op), args[0]); @@ -2328,7 +2328,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { op &= 0x7F; POP1; - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, *(stack - op - 1), args[0]); @@ -2359,7 +2359,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + emit_lisp_obj_from_ptr (comp.block, vectorp[op]); PUSH_RVAL (c); break; } From 5637eae4a4a1be757f5f203c7e08ec5cf1a69c03 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 18:50:21 +0200 Subject: [PATCH 0101/1452] locals to array --- src/comp.c | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1bbf1a0136e..296f215cd27 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1367,11 +1367,24 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); + gcc_jit_lvalue *meta_stack_array = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + stack_depth), + "local"); + for (int i = 0; i < stack_depth; ++i) - stack[i] = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("local_%d", i)); + stack[i] = gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); From 97b39deeeaa55c7cfed05cfb2ae57e2323a7c69c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 19:16:10 +0200 Subject: [PATCH 0102/1452] remove scratch call mechanism --- src/comp.c | 118 ++++++++++++++--------------------------------------- 1 file changed, 30 insertions(+), 88 deletions(-) diff --git a/src/comp.c b/src/comp.c index 296f215cd27..154a1a9028e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -36,10 +36,6 @@ along with GNU Emacs. If not, see . */ #define MAX_FUN_NAME 256 -/* Max number of args we are able to handle while emitting function calls. */ - -#define MAX_ARGS 16 - #define DISASS_FILE_NAME "emacs-asm.s" #define CHECK_STACK \ @@ -147,13 +143,15 @@ along with GNU Emacs. If not, see . */ EMIT_CALL_N (STR(F##name), nargs); \ break -/* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) - This is done aggregating args into the scratch_call_area. */ +/* + Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args). + This is done by passing a reference to the first obj involved on the stack. +*/ -#define EMIT_SCRATCH_CALL_N(name, nargs) \ +#define EMIT_CALL_N_REF(name, nargs) \ do { \ - pop (nargs, &stack, args); \ - res = emit_scratch_callN (name, nargs, args); \ + DISCARD (nargs); \ + res = emit_call_n_ref (name, nargs, *stack); \ PUSH_RVAL (res); \ } while (0) @@ -214,7 +212,6 @@ typedef struct { gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; gcc_jit_function *func; /* Current function being compiled */ - gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -228,8 +225,6 @@ typedef struct { static comp_t comp; -Lisp_Object scratch_call_area[MAX_ARGS]; - FILE *logfile = NULL; /* The result of one function compilation. */ @@ -722,60 +717,15 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) } static gcc_jit_rvalue * -emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +emit_call_n_ref (const char *f_name, unsigned nargs, + gcc_jit_lvalue *base_arg) { - /* Here we set all the pointers into the scratch call area. */ - /* TODO: distinguish primitives for faster calling convention. */ - - /* - Lisp_Object *p; - p = scratch_call_area; - - p[0] = nargs; - p[1] = 0x...; - . - . - . - p[n] = 0x...; - */ - - gcc_jit_block_add_comment (comp.block->gcc_bb, - NULL, - format_string ("calling %s", f_name)); - - gcc_jit_lvalue *p = - gcc_jit_function_new_local(comp.func, - NULL, - gcc_jit_type_get_pointer (comp.lisp_obj_type), - "p"); - - gcc_jit_block_add_assignment(comp.block->gcc_bb, NULL, - p, - comp.scratch); - - for (int i = 0; i < nargs; i++) { - gcc_jit_rvalue *idx = - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - gcc_jit_context_get_type(comp.ctxt, - GCC_JIT_TYPE_UNSIGNED_INT), - i); - gcc_jit_block_add_assignment ( - comp.block->gcc_bb, - NULL, - gcc_jit_context_new_array_access (comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue(p), - idx), - args[i]); - } - - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + gcc_jit_rvalue *arguments[2] = + { gcc_jit_context_new_rvalue_from_int(comp.ctxt, comp.ptrdiff_type, - nargs); - args[1] = comp.scratch; - - return emit_call (f_name, comp.lisp_obj_type, 2, args); + nargs), + gcc_jit_lvalue_get_address (base_arg, NULL) }; + return emit_call (f_name, comp.lisp_obj_type, 2, arguments); } /* opaque jmp_buf definition */ @@ -1288,14 +1238,6 @@ init_comp (int opt_level) comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); - comp.scratch = - gcc_jit_lvalue_get_address( - gcc_jit_context_new_global (comp.ctxt, NULL, - GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj_type, - "scratch_call_area"), - NULL); - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); define_jmp_buf (); @@ -1557,8 +1499,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, docall: { ptrdiff_t nargs = op + 1; - pop (nargs, &stack, args); - res = emit_scratch_callN ("Ffuncall", nargs, args); + DISCARD (nargs); + res = emit_call_n_ref ("Ffuncall", nargs, *stack); PUSH_RVAL (res); break; } @@ -1763,17 +1705,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (substring, 3); CASE (Bconcat2) - EMIT_SCRATCH_CALL_N ("Fconcat", 2); + EMIT_CALL_N_REF ("Fconcat", 2); break; CASE (Bconcat3) - EMIT_SCRATCH_CALL_N ("Fconcat", 3); + EMIT_CALL_N_REF ("Fconcat", 3); break; CASE (Bconcat4) - EMIT_SCRATCH_CALL_N ("Fconcat", 4); + EMIT_CALL_N_REF ("Fconcat", 4); break; CASE (BconcatN) op = FETCH; - EMIT_SCRATCH_CALL_N ("Fconcat", op); + EMIT_CALL_N_REF ("Fconcat", op); break; CASE (Bsub1) @@ -1917,7 +1859,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bdiff) - EMIT_SCRATCH_CALL_N ("Fminus", 2); + EMIT_CALL_N_REF ("Fminus", 2); break; CASE (Bnegate) @@ -1966,7 +1908,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, basic_block_t bb_orig = *comp.block; comp.block->gcc_bb = negate_fcall_block; - EMIT_SCRATCH_CALL_N ("Fminus", 1); + EMIT_CALL_N_REF ("Fminus", 1); *comp.block = bb_orig; gcc_jit_block_end_with_jump (negate_inline_block, NULL, @@ -1976,16 +1918,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; CASE (Bplus) - EMIT_SCRATCH_CALL_N ("Fplus", 2); + EMIT_CALL_N_REF ("Fplus", 2); break; CASE (Bmax) - EMIT_SCRATCH_CALL_N ("Fmax", 2); + EMIT_CALL_N_REF ("Fmax", 2); break; CASE (Bmin) - EMIT_SCRATCH_CALL_N ("Fmin", 2); + EMIT_CALL_N_REF ("Fmin", 2); break; CASE (Bmult) - EMIT_SCRATCH_CALL_N ("Ftimes", 2); + EMIT_CALL_N_REF ("Ftimes", 2); break; CASE (Bpoint) args[0] = @@ -2002,7 +1944,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (goto_char, 1); CASE (Binsert) - EMIT_SCRATCH_CALL_N ("Finsert", 1); + EMIT_CALL_N_REF ("Finsert", 1); break; CASE (Bpoint_max) @@ -2231,11 +2173,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bnconc) - EMIT_SCRATCH_CALL_N ("Fnconc", 2); + EMIT_CALL_N_REF ("Fnconc", 2); break; CASE (Bquo) - EMIT_SCRATCH_CALL_N ("Fquo", 2); + EMIT_CALL_N_REF ("Fquo", 2); break; CASE_CALL_NARGS (rem, 2); @@ -2312,7 +2254,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (BinsertN) op = FETCH; - EMIT_SCRATCH_CALL_N ("Finsert", op); + EMIT_CALL_N_REF ("Finsert", op); break; CASE (Bstack_set) From 1f26e751043c3c15a8c94a344428066e22e9e625 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 19:17:22 +0200 Subject: [PATCH 0103/1452] CASE_CALL_NARGS -> CASE_CALL_N --- src/comp.c | 108 ++++++++++++++++++++++++++--------------------------- 1 file changed, 54 insertions(+), 54 deletions(-) diff --git a/src/comp.c b/src/comp.c index 154a1a9028e..ca78d9317da 100644 --- a/src/comp.c +++ b/src/comp.c @@ -138,7 +138,7 @@ along with GNU Emacs. If not, see . */ /* Generate appropriate case and emit call to function. */ -#define CASE_CALL_NARGS(name, nargs) \ +#define CASE_CALL_N(name, nargs) \ CASE (B##name) \ EMIT_CALL_N (STR(F##name), nargs); \ break @@ -1643,8 +1643,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE_CALL_NARGS (nth, 2); - CASE_CALL_NARGS (symbolp, 1); + CASE_CALL_N (nth, 2); + CASE_CALL_N (symbolp, 1); CASE (Bconsp) POP1; @@ -1657,14 +1657,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (stringp, 1); - CASE_CALL_NARGS (listp, 1); - CASE_CALL_NARGS (eq, 2); - CASE_CALL_NARGS (memq, 1); - CASE_CALL_NARGS (not, 1); - CASE_CALL_NARGS (car, 1); - CASE_CALL_NARGS (cdr, 1); - CASE_CALL_NARGS (cons, 2); + CASE_CALL_N (stringp, 1); + CASE_CALL_N (listp, 1); + CASE_CALL_N (eq, 2); + CASE_CALL_N (memq, 1); + CASE_CALL_N (not, 1); + CASE_CALL_N (car, 1); + CASE_CALL_N (cdr, 1); + CASE_CALL_N (cons, 2); CASE (BlistN) op = FETCH; @@ -1694,15 +1694,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE_CALL_NARGS (length, 1); - CASE_CALL_NARGS (aref, 2); - CASE_CALL_NARGS (aset, 3); - CASE_CALL_NARGS (symbol_value, 1); - CASE_CALL_NARGS (symbol_function, 1); - CASE_CALL_NARGS (set, 2); - CASE_CALL_NARGS (fset, 2); - CASE_CALL_NARGS (get, 2); - CASE_CALL_NARGS (substring, 3); + CASE_CALL_N (length, 1); + CASE_CALL_N (aref, 2); + CASE_CALL_N (aset, 3); + CASE_CALL_N (symbol_value, 1); + CASE_CALL_N (symbol_function, 1); + CASE_CALL_N (set, 2); + CASE_CALL_N (fset, 2); + CASE_CALL_N (get, 2); + CASE_CALL_N (substring, 3); CASE (Bconcat2) EMIT_CALL_N_REF ("Fconcat", 2); @@ -1941,7 +1941,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (goto_char, 1); + CASE_CALL_N (goto_char, 1); CASE (Binsert) EMIT_CALL_N_REF ("Finsert", 1); @@ -1971,15 +1971,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (char_after, 1); - CASE_CALL_NARGS (following_char, 0); + CASE_CALL_N (char_after, 1); + CASE_CALL_N (following_char, 0); CASE (Bpreceding_char) res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_RVAL (res); break; - CASE_CALL_NARGS (current_column, 0); + CASE_CALL_N (current_column, 0); CASE (Bindent_to) POP1; @@ -1988,12 +1988,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (eolp, 0); - CASE_CALL_NARGS (eobp, 0); - CASE_CALL_NARGS (bolp, 0); - CASE_CALL_NARGS (bobp, 0); - CASE_CALL_NARGS (current_buffer, 0); - CASE_CALL_NARGS (set_buffer, 1); + CASE_CALL_N (eolp, 0); + CASE_CALL_N (eobp, 0); + CASE_CALL_N (bolp, 0); + CASE_CALL_N (bobp, 0); + CASE_CALL_N (current_buffer, 0); + CASE_CALL_N (set_buffer, 1); CASE (Bsave_current_buffer) /* Obsolete since ??. */ goto save_current; @@ -2010,17 +2010,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (forward_char, 1); - CASE_CALL_NARGS (forward_word, 1); - CASE_CALL_NARGS (skip_chars_forward, 2); - CASE_CALL_NARGS (skip_chars_backward, 2); - CASE_CALL_NARGS (forward_line, 1); - CASE_CALL_NARGS (char_syntax, 1); - CASE_CALL_NARGS (buffer_substring, 2); - CASE_CALL_NARGS (delete_region, 2); - CASE_CALL_NARGS (narrow_to_region, 2); - CASE_CALL_NARGS (widen, 0); - CASE_CALL_NARGS (end_of_line, 1); + CASE_CALL_N (forward_char, 1); + CASE_CALL_N (forward_word, 1); + CASE_CALL_N (skip_chars_forward, 2); + CASE_CALL_N (skip_chars_backward, 2); + CASE_CALL_N (forward_line, 1); + CASE_CALL_N (char_syntax, 1); + CASE_CALL_N (buffer_substring, 2); + CASE_CALL_N (delete_region, 2); + CASE_CALL_N (narrow_to_region, 2); + CASE_CALL_N (widen, 0); + CASE_CALL_N (end_of_line, 1); CASE (Bconstant2) goto do_constant; @@ -2142,11 +2142,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Bunbind_all not supported"); break; - CASE_CALL_NARGS (set_marker, 3); - CASE_CALL_NARGS (match_beginning, 1); - CASE_CALL_NARGS (match_end, 1); - CASE_CALL_NARGS (upcase, 1); - CASE_CALL_NARGS (downcase, 1); + CASE_CALL_N (set_marker, 3); + CASE_CALL_N (match_beginning, 1); + CASE_CALL_N (match_end, 1); + CASE_CALL_N (upcase, 1); + CASE_CALL_N (downcase, 1); CASE (Bstringeqlsign) EMIT_CALL_N ("Fstring_equal", 2); @@ -2156,13 +2156,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_CALL_N ("Fstring_lessp", 2); break; - CASE_CALL_NARGS (equal, 2); - CASE_CALL_NARGS (nthcdr, 2); - CASE_CALL_NARGS (elt, 2); - CASE_CALL_NARGS (member, 2); - CASE_CALL_NARGS (assq, 2); - CASE_CALL_NARGS (setcar, 2); - CASE_CALL_NARGS (setcdr, 2); + CASE_CALL_N (equal, 2); + CASE_CALL_N (nthcdr, 2); + CASE_CALL_N (elt, 2); + CASE_CALL_N (member, 2); + CASE_CALL_N (assq, 2); + CASE_CALL_N (setcar, 2); + CASE_CALL_N (setcdr, 2); CASE (Bcar_safe) EMIT_CALL_N ("CAR_SAFE", 1); @@ -2180,7 +2180,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_CALL_N_REF ("Fquo", 2); break; - CASE_CALL_NARGS (rem, 2); + CASE_CALL_N (rem, 2); CASE (Bnumberp) POP1; From fdc8de36c3b6c5c294bbf4be61f4239ac822aa11 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Jun 2019 20:50:05 +0200 Subject: [PATCH 0104/1452] add cons definition --- src/comp.c | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 112 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index ca78d9317da..b4bcd511905 100644 --- a/src/comp.c +++ b/src/comp.c @@ -190,6 +190,10 @@ typedef struct { gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* struct Lisp_Cons */ + gcc_jit_struct *lisp_cons_s; + gcc_jit_field *lisp_cons_u; + gcc_jit_type *lisp_cons_ptr; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -728,7 +732,112 @@ emit_call_n_ref (const char *f_name, unsigned nargs, return emit_call (f_name, comp.lisp_obj_type, 2, arguments); } -/* opaque jmp_buf definition */ +/* struct Lisp_Cons definition. */ + +static void +define_lisp_cons (void) +{ + /* + union cdr_u + { + Lisp_Object cdr; + struct Lisp_Cons *chain; + }; + + struct cons_s + { + Lisp_Object car; + union cdr_u u; + }; + + union cons_u + { + struct cons_s s; + char align_pad[sizeof (struct Lisp_Cons)]; + }; + + struct Lisp_Cons + { + union cons_u u; + }; + */ + + comp.lisp_cons_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "comp_Lisp_Cons"); + comp.lisp_cons_ptr = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.lisp_cons_s)); + + gcc_jit_field *cdr_u_fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cdr"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr, + "chain") }; + + gcc_jit_type *cdr_u = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cdr_u", + sizeof (cdr_u_fields) + / sizeof (*cdr_u_fields), + cdr_u_fields); + + gcc_jit_field *cons_s_fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "car"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + cdr_u, + "u") }; + + gcc_jit_struct *cons_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_cons_s", + sizeof (cons_s_fields) + / sizeof (*cons_s_fields), + cons_s_fields); + + gcc_jit_field *cons_u_fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type (cons_s), + "s"), + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct Lisp_Cons)), + "align_pad") }; + + gcc_jit_type *cons_u = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cons_u", + sizeof (cons_u_fields) + / sizeof (*cons_u_fields), + cons_u_fields); + + comp.lisp_cons_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + cons_u, + "u"); + gcc_jit_struct_set_fields (comp.lisp_cons_s, + NULL, 1, &comp.lisp_cons_u); + +} + +/* opaque jmp_buf definition. */ static void define_jmp_buf (void) @@ -1159,7 +1268,7 @@ init_comp (int opt_level) comp.lisp_obj_as_num }; comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, - "LispObj", + "comp_Lisp_Object", sizeof (lisp_obj_fields) / sizeof (*lisp_obj_fields), lisp_obj_fields); @@ -1240,6 +1349,7 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + define_lisp_cons (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); From 4577eeedf620a739a66e69204b40da8cdbbd77e0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 10:05:22 +0200 Subject: [PATCH 0105/1452] better options --- src/comp.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index b4bcd511905..e1a7b25bb26 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1205,9 +1205,6 @@ init_comp (int opt_level) gcc_jit_context_set_logfile (comp.ctxt, logfile, 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, 1); @@ -1217,6 +1214,9 @@ init_comp (int opt_level) gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_INITIAL_GIMPLE, + 1); gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); @@ -1226,6 +1226,10 @@ init_comp (int opt_level) GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, opt_level); + /* Do not inline within a compilation unit. */ + gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); + + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); From f2dd0cb80fc283293ef64e07d79b06609058e216 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 11:32:11 +0200 Subject: [PATCH 0106/1452] add char * type support --- src/comp.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index e1a7b25bb26..2bffba08334 100644 --- a/src/comp.c +++ b/src/comp.c @@ -185,6 +185,7 @@ typedef struct { gcc_jit_type *long_long_type; gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; + gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; @@ -215,6 +216,7 @@ typedef struct { gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; + gcc_jit_field *cast_union_as_c_p; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -293,6 +295,8 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_i; else if (type == comp.bool_type) field = comp.cast_union_as_b; + else if (type == comp.char_ptr_type) + field = comp.cast_union_as_c_p; else error ("unsopported cast\n"); @@ -1234,6 +1238,7 @@ init_comp (int opt_level) comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); + comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT); @@ -1303,13 +1308,19 @@ init_comp (int opt_level) NULL, comp.bool_type, "b"); + comp.cast_union_as_c_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "c_p"); gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, comp.cast_union_as_l, comp.cast_union_as_u, comp.cast_union_as_i, - comp.cast_union_as_b,}; + comp.cast_union_as_b, + comp.cast_union_as_c_p, }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, From 483a2d39df48ef17f446f4c41171654a10ce62b2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 11:33:44 +0200 Subject: [PATCH 0107/1452] add XUNTAG --- src/comp.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/comp.c b/src/comp.c index 2bffba08334..f754778468b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -496,6 +496,24 @@ emit_lval_XLP (gcc_jit_lvalue *obj) comp.lisp_obj_as_ptr); } +static gcc_jit_rvalue * +emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) +{ + /* #define XUNTAG(a, type, ctype) ((ctype *) + ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + + return emit_cast (type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.emacs_int_type, + emit_rval_XLI (a), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + lisp_word_tag))); +} + static gcc_jit_rvalue * emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) { From fc2e2818edc0eaa4b86124d102eb12b7a24fa486 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 11:34:27 +0200 Subject: [PATCH 0108/1452] reindent define_thread_state_struct --- src/comp.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index f754778468b..9ef1a99b0f5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -967,13 +967,14 @@ define_thread_state_struct (void) gcc_jit_context_new_field ( comp.ctxt, NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - sizeof (struct thread_state) - - offsetof (struct thread_state, - m_handlerlist) - - sizeof (((struct thread_state *) 0)->m_handlerlist)), + gcc_jit_context_new_array_type ( + comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (((struct thread_state *) 0)->m_handlerlist)), "pad1") }; comp.thread_state_s = From c4bebcb38fe426780fc9c460474592d12bc15deb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 12:24:50 +0200 Subject: [PATCH 0109/1452] define cast union into dedicated function --- src/comp.c | 176 ++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 128 insertions(+), 48 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9ef1a99b0f5..38183a64e20 100644 --- a/src/comp.c +++ b/src/comp.c @@ -987,7 +987,128 @@ define_thread_state_struct (void) gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); } -/* Declare a substitute for PSEUDOVECTORP as inline function. */ +static void +define_cast_union (void) +{ + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "ll"); + comp.cast_union_as_l = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_type, + "l"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + comp.cast_union_as_c_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.char_ptr_type, + "c_p"); + comp.cast_union_as_lisp_cons_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr_type, + "cons_ptr"); + + gcc_jit_field *cast_union_fields[] = + { comp.cast_union_as_ll, + comp.cast_union_as_l, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b, + comp.cast_union_as_c_p, + comp.cast_union_as_lisp_cons_ptr, }; + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + sizeof (cast_union_fields) + / sizeof (*cast_union_fields), + cast_union_fields); +} + +/* Declare a substitute for CAR as always inlined function. */ + +static void +define_CAR (void) +{ + gcc_jit_param *param = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"); + comp.car = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "CAR", + 1, + ¶m, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.car, "CAR_initial_block"); + + /* gcc_jit_block *is_cons_b = */ + /* gcc_jit_function_new_block (comp.pseudovectorp, "is_cons"); */ + + /* gcc_jit_block *not_a_cons_b = */ + /* gcc_jit_function_new_block (comp.pseudovectorp, "not_a_cons"); */ + + + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.car; + + /* emit_cond_jump ( */ + /* emit_cast (comp.bool_type, */ + /* emit_CONSP (gcc_jit_param_as_rvalue (param))), */ + /* is_cons_b, */ + /* not_a_cons_b); */ + + /* comp.block->gcc_bb = is_cons_b; */ + + gcc_jit_rvalue *res_car = + /* c->u.s.car */ + gcc_jit_rvalue_access_field ( + /* c->u.s */ + gcc_jit_rvalue_access_field ( + /* c->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_rval_XCONS (gcc_jit_param_as_rvalue (param)), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); + + gcc_jit_block_end_with_return (initial_block, + NULL, + res_car); + +} + +/* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) @@ -1022,7 +1143,7 @@ define_PSEUDOVECTORP (void) /* Set current context as needed */ basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; + .terminated = false }; comp.block = █ comp.func = comp.pseudovectorp; @@ -1044,7 +1165,7 @@ define_PSEUDOVECTORP (void) { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; comp.block->gcc_bb = call_pseudovector_typep_b; - /* FIXME XUNTAG missing here. */ + /* FIXME use XUNTAG now that's available. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", @@ -1302,51 +1423,6 @@ init_comp (int opt_level) lisp_obj_fields); comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); - comp.cast_union_as_ll = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "ll"); - comp.cast_union_as_l = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_type, - "l"); - comp.cast_union_as_u = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_type, - "u"); - comp.cast_union_as_i = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "i"); - comp.cast_union_as_b = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "b"); - comp.cast_union_as_c_p = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "c_p"); - - gcc_jit_field *cast_union_fields[] = - { comp.cast_union_as_ll, - comp.cast_union_as_l, - comp.cast_union_as_u, - comp.cast_union_as_i, - comp.cast_union_as_b, - comp.cast_union_as_c_p, }; - comp.cast_union_type = - gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "cast_union", - sizeof (cast_union_fields) - / sizeof (*cast_union_fields), - cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.emacs_int_type, @@ -1383,10 +1459,14 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + /* Define data structures. */ + define_lisp_cons (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); + define_cast_union (); + comp.current_thread = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.thread_state_ptr_type, From 4f5881bc0ce56ef6d11506508e69451031e378b8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 12:25:15 +0200 Subject: [PATCH 0110/1452] better emit_cast --- src/comp.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 38183a64e20..c24017ce68b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -443,6 +443,8 @@ emit_comparison_jump (enum gcc_jit_comparison op, /* TODO add basick block as pa static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { + static unsigned i; + gcc_jit_field *orig_field = type_to_cast_field (gcc_jit_rvalue_get_type (obj)); gcc_jit_field *dest_field = type_to_cast_field (new_type); @@ -451,7 +453,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_function_new_local (comp.func, NULL, comp.cast_union_type, - "union_cast"); + format_string ("union_cast_%u", i++)); gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, gcc_jit_lvalue_access_field (tmp_u, From 6955ca3d2a0a2269bd0f4578b560c58ca62efeb1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 13:43:58 +0200 Subject: [PATCH 0111/1452] add emit_rval_XCONS --- src/comp.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/comp.c b/src/comp.c index c24017ce68b..e1fb7316318 100644 --- a/src/comp.c +++ b/src/comp.c @@ -514,6 +514,14 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, lisp_word_tag))); +static gcc_jit_rvalue * +emit_rval_XCONS (gcc_jit_rvalue *a) +{ + return emit_rval_XUNTAG (a, + gcc_jit_struct_as_type (comp.lisp_cons_s), + LISP_WORD_TAG (Lisp_Cons)); +} + } static gcc_jit_rvalue * From 2dc6ff917607f5444417884662126ad0d4037402 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 13:44:25 +0200 Subject: [PATCH 0112/1452] add emit_NILP --- src/comp.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/comp.c b/src/comp.c index e1fb7316318..4f3a80572d1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -753,6 +753,10 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) } static gcc_jit_rvalue * +emit_NILP (gcc_jit_rvalue *x) +{ + return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); +} emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { From 4d4f2a4efc8fb58d8b3375578b763aee33b6e91a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 13:45:08 +0200 Subject: [PATCH 0113/1452] add emit_EQ --- src/comp.c | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/comp.c b/src/comp.c index 4f3a80572d1..6f5ca5f4ecd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -522,6 +522,15 @@ emit_rval_XCONS (gcc_jit_rvalue *a) LISP_WORD_TAG (Lisp_Cons)); } +static gcc_jit_rvalue * +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_EQ, + emit_rval_XLI (x), + emit_rval_XLI (y)); } static gcc_jit_rvalue * From a8c60ea884b835b7a109b735ee82600c7c785c5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 13:45:44 +0200 Subject: [PATCH 0114/1452] fix XUNTAG --- src/comp.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6f5ca5f4ecd..599f8f158b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -504,7 +504,7 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ - return emit_cast (type, + return emit_cast (gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, NULL, @@ -512,8 +512,10 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) comp.emacs_int_type, emit_rval_XLI (a), gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - lisp_word_tag))); + comp.emacs_int_type, + lisp_word_tag))); +} + static gcc_jit_rvalue * emit_rval_XCONS (gcc_jit_rvalue *a) { From df93780efe61cea82463a96dbac3792fd3eed737 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 13:47:08 +0200 Subject: [PATCH 0115/1452] full inline car --- src/comp.c | 109 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 82 insertions(+), 27 deletions(-) diff --git a/src/comp.c b/src/comp.c index 599f8f158b7..e3ec34d5545 100644 --- a/src/comp.c +++ b/src/comp.c @@ -194,7 +194,10 @@ typedef struct { /* struct Lisp_Cons */ gcc_jit_struct *lisp_cons_s; gcc_jit_field *lisp_cons_u; - gcc_jit_type *lisp_cons_ptr; + gcc_jit_field *lisp_cons_u_s; + gcc_jit_field *lisp_cons_u_s_car; + gcc_jit_type *lisp_cons_type; + gcc_jit_type *lisp_cons_ptr_type; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -217,6 +220,7 @@ typedef struct { gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; gcc_jit_field *cast_union_as_c_p; + gcc_jit_field *cast_union_as_lisp_cons_ptr; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -225,6 +229,7 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; + gcc_jit_function *car; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -297,6 +302,8 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_b; else if (type == comp.char_ptr_type) field = comp.cast_union_as_c_p; + else if (type == comp.lisp_cons_ptr_type) + field = comp.cast_union_as_lisp_cons_ptr; else error ("unsopported cast\n"); @@ -768,6 +775,8 @@ emit_NILP (gcc_jit_rvalue *x) { return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); } + +static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { @@ -813,8 +822,10 @@ define_lisp_cons (void) gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_Lisp_Cons"); - comp.lisp_cons_ptr = - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.lisp_cons_s)); + comp.lisp_cons_type = + gcc_jit_struct_as_type (comp.lisp_cons_s); + comp.lisp_cons_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_cons_type); gcc_jit_field *cdr_u_fields[] = { gcc_jit_context_new_field (comp.ctxt, @@ -823,7 +834,7 @@ define_lisp_cons (void) "cdr"), gcc_jit_context_new_field (comp.ctxt, NULL, - comp.lisp_cons_ptr, + comp.lisp_cons_ptr_type, "chain") }; gcc_jit_type *cdr_u = @@ -834,11 +845,12 @@ define_lisp_cons (void) / sizeof (*cdr_u_fields), cdr_u_fields); + comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "car"); gcc_jit_field *cons_s_fields[] = - { gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "car"), + { comp.lisp_cons_u_s_car, gcc_jit_context_new_field (comp.ctxt, NULL, cdr_u, @@ -852,11 +864,13 @@ define_lisp_cons (void) / sizeof (*cons_s_fields), cons_s_fields); - gcc_jit_field *cons_u_fields[] = - { gcc_jit_context_new_field (comp.ctxt, + comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt, NULL, gcc_jit_struct_as_type (cons_s), - "s"), + "s"); + + gcc_jit_field *cons_u_fields[] = + { comp.lisp_cons_u_s, gcc_jit_context_new_field ( comp.ctxt, NULL, @@ -866,7 +880,7 @@ define_lisp_cons (void) sizeof (struct Lisp_Cons)), "align_pad") }; - gcc_jit_type *cons_u = + gcc_jit_type *lisp_cons_u_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, "comp_cons_u", @@ -877,7 +891,7 @@ define_lisp_cons (void) comp.lisp_cons_u = gcc_jit_context_new_field (comp.ctxt, NULL, - cons_u, + lisp_cons_u_type, "u"); gcc_jit_struct_set_fields (comp.lisp_cons_s, NULL, 1, &comp.lisp_cons_u); @@ -1087,29 +1101,30 @@ define_CAR (void) 1, ¶m, 0); + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); gcc_jit_block *initial_block = gcc_jit_function_new_block (comp.car, "CAR_initial_block"); - /* gcc_jit_block *is_cons_b = */ - /* gcc_jit_function_new_block (comp.pseudovectorp, "is_cons"); */ + gcc_jit_block *is_cons_b = + gcc_jit_function_new_block (comp.car, "is_cons"); - /* gcc_jit_block *not_a_cons_b = */ - /* gcc_jit_function_new_block (comp.pseudovectorp, "not_a_cons"); */ + gcc_jit_block *not_a_cons_b = + gcc_jit_function_new_block (comp.car, "not_a_cons"); /* Set current context as needed */ basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; + .terminated = false }; comp.block = █ comp.func = comp.car; - /* emit_cond_jump ( */ - /* emit_cast (comp.bool_type, */ - /* emit_CONSP (gcc_jit_param_as_rvalue (param))), */ - /* is_cons_b, */ - /* not_a_cons_b); */ + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); - /* comp.block->gcc_bb = is_cons_b; */ + comp.block->gcc_bb = is_cons_b; gcc_jit_rvalue *res_car = /* c->u.s.car */ @@ -1119,7 +1134,7 @@ define_CAR (void) /* c->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (gcc_jit_param_as_rvalue (param)), + emit_rval_XCONS (c), NULL, comp.lisp_cons_u)), NULL, @@ -1127,10 +1142,37 @@ define_CAR (void) NULL, comp.lisp_cons_u_s_car); - gcc_jit_block_end_with_return (initial_block, + gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, res_car); + comp.block->gcc_bb = not_a_cons_b; + + gcc_jit_block *is_nil_b = + gcc_jit_function_new_block (comp.car, "is_nil"); + gcc_jit_block *not_nil_b = + gcc_jit_function_new_block (comp.car, "not_nil"); + + emit_cond_jump (emit_NILP (c), + is_nil_b, + not_nil_b); + + comp.block->gcc_bb = is_nil_b; + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); + + comp.block->gcc_bb = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("wrong_type_argument", + comp.lisp_obj_type, 2, wrong_type_args)); + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ @@ -1496,6 +1538,10 @@ init_comp (int opt_level) gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.thread_state_ptr_type, current_thread); + + /* Define inline functions. */ + + define_CAR(); define_PSEUDOVECTORP (); define_bool_to_lisp_obj (); } @@ -1911,7 +1957,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (eq, 2); CASE_CALL_N (memq, 1); CASE_CALL_N (not, 1); - CASE_CALL_N (car, 1); + + case Bcar: + POP1; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.car, + 1, args); + PUSH_RVAL (res); + break; + CASE_CALL_N (cdr, 1); CASE_CALL_N (cons, 2); From 57ac14e3e27adb09629b5547101295fae44f8847 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 14:07:59 +0200 Subject: [PATCH 0116/1452] add car cdr tests --- test/src/comp-tests.el | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6a7370a880c..31b2f0f001e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -32,7 +32,7 @@ (defvar comp-tests-var1 3) (ert-deftest comp-tests-varref () - "Testing cons car cdr." + "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) @@ -45,6 +45,12 @@ "Testing cons car cdr." (defun comp-tests-list-f () (list 1 2 3)) + (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)) @@ -54,12 +60,28 @@ (byte-compile #'comp-tests-list-f) (native-compile #'comp-tests-list-f) + (byte-compile #'comp-tests-car-f) + (native-compile #'comp-tests-car-f) + (byte-compile #'comp-tests-cdr-f) + (native-compile #'comp-tests-cdr-f) (byte-compile #'comp-tests-car-safe-f) (native-compile #'comp-tests-car-safe-f) (byte-compile #'comp-tests-cdr-safe-f) (native-compile #'comp-tests-cdr-safe-f) (should (equal (comp-tests-list-f) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) + (should (= (condition-case err + (comp-tests-car-f 3) + (error 10)) + 10)) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) + (should (= (condition-case err + (comp-tests-cdr-f 3) + (error 10)) + 10)) (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) (should (null (comp-tests-car-safe-f 'a))) (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) From 09b89741d038b0f60aa0623f8263a0d2d89c7174 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 14:13:01 +0200 Subject: [PATCH 0117/1452] split XCAR --- src/comp.c | 40 ++++++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index e3ec34d5545..ab8b4984bef 100644 --- a/src/comp.c +++ b/src/comp.c @@ -776,6 +776,26 @@ emit_NILP (gcc_jit_rvalue *x) return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); } +static gcc_jit_rvalue * +emit_XCAR (gcc_jit_rvalue *c) +{ + /* XCONS (c)->u.s.car */ + return + gcc_jit_rvalue_access_field ( + /* c->u.s */ + gcc_jit_rvalue_access_field ( + /* c->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_rval_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) @@ -1103,7 +1123,7 @@ define_CAR (void) 0); gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.car, "CAR_initial_block"); + gcc_jit_function_new_block (comp.car, "initial_block"); gcc_jit_block *is_cons_b = gcc_jit_function_new_block (comp.car, "is_cons"); @@ -1126,25 +1146,9 @@ define_CAR (void) comp.block->gcc_bb = is_cons_b; - gcc_jit_rvalue *res_car = - /* c->u.s.car */ - gcc_jit_rvalue_access_field ( - /* c->u.s */ - gcc_jit_rvalue_access_field ( - /* c->u */ - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (c), - NULL, - comp.lisp_cons_u)), - NULL, - comp.lisp_cons_u_s), - NULL, - comp.lisp_cons_u_s_car); - gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, - res_car); + emit_XCAR (c)); comp.block->gcc_bb = not_a_cons_b; From 7ca1835309e5aff1fd2454010ee92b3e38069065 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 14:43:50 +0200 Subject: [PATCH 0118/1452] inline cdr --- src/comp.c | 191 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 128 insertions(+), 63 deletions(-) diff --git a/src/comp.c b/src/comp.c index ab8b4984bef..b6b470c20df 100644 --- a/src/comp.c +++ b/src/comp.c @@ -196,6 +196,8 @@ typedef struct { gcc_jit_field *lisp_cons_u; gcc_jit_field *lisp_cons_u_s; gcc_jit_field *lisp_cons_u_s_car; + gcc_jit_field *lisp_cons_u_s_u; + gcc_jit_field *lisp_cons_u_s_u_cdr; gcc_jit_type *lisp_cons_type; gcc_jit_type *lisp_cons_ptr_type; /* struct jmp_buf. */ @@ -230,6 +232,7 @@ typedef struct { gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *car; + gcc_jit_function *cdr; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -779,12 +782,12 @@ emit_NILP (gcc_jit_rvalue *x) static gcc_jit_rvalue * emit_XCAR (gcc_jit_rvalue *c) { - /* XCONS (c)->u.s.car */ + /* XCONS (c)->u.s.car */ return gcc_jit_rvalue_access_field ( - /* c->u.s */ + /* XCONS (c)->u.s */ gcc_jit_rvalue_access_field ( - /* c->u */ + /* XCONS (c)->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( emit_rval_XCONS (c), @@ -796,6 +799,30 @@ emit_XCAR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_car); } +static gcc_jit_rvalue * +emit_XCDR (gcc_jit_rvalue *c) +{ + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_rval_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) @@ -847,11 +874,14 @@ define_lisp_cons (void) comp.lisp_cons_ptr_type = gcc_jit_type_get_pointer (comp.lisp_cons_type); + comp.lisp_cons_u_s_u_cdr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cdr"); + gcc_jit_field *cdr_u_fields[] = - { gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "cdr"), + { comp.lisp_cons_u_s_u_cdr, gcc_jit_context_new_field (comp.ctxt, NULL, comp.lisp_cons_ptr_type, @@ -869,12 +899,13 @@ define_lisp_cons (void) NULL, comp.lisp_obj_type, "car"); + comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt, + NULL, + cdr_u, + "u"); gcc_jit_field *cons_s_fields[] = { comp.lisp_cons_u_s_car, - gcc_jit_context_new_field (comp.ctxt, - NULL, - cdr_u, - "u") }; + comp.lisp_cons_u_s_u }; gcc_jit_struct *cons_s = gcc_jit_context_new_struct_type (comp.ctxt, @@ -1106,77 +1137,103 @@ define_cast_union (void) /* Declare a substitute for CAR as always inlined function. */ static void -define_CAR (void) +define_CAR_CDR (void) { - gcc_jit_param *param = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "c"); + gcc_jit_param *car_param = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"); comp.car = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, "CAR", 1, - ¶m, + &car_param, + 0); + gcc_jit_param *cdr_param = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"); + comp.cdr = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "CDR", + 1, + &cdr_param, 0); - gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.car, "initial_block"); - gcc_jit_block *is_cons_b = - gcc_jit_function_new_block (comp.car, "is_cons"); + gcc_jit_function *f = comp.car; + gcc_jit_param *param = car_param; - gcc_jit_block *not_a_cons_b = - gcc_jit_function_new_block (comp.car, "not_a_cons"); + for (int i = 0; i < 2; i++) + { + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (f, "initial_block"); + + gcc_jit_block *is_cons_b = + gcc_jit_function_new_block (f, "is_cons"); + + gcc_jit_block *not_a_cons_b = + gcc_jit_function_new_block (f, "not_a_cons"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ - comp.func = comp.car; + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = f; - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_CONSP (c)), - is_cons_b, - not_a_cons_b); + emit_cond_jump (emit_cast (comp.bool_type, + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); - comp.block->gcc_bb = is_cons_b; + comp.block->gcc_bb = is_cons_b; - gcc_jit_block_end_with_return (comp.block->gcc_bb, - NULL, - emit_XCAR (c)); + if (f == comp.car) + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_XCAR (c)); + else + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_XCDR (c)); - comp.block->gcc_bb = not_a_cons_b; + comp.block->gcc_bb = not_a_cons_b; - gcc_jit_block *is_nil_b = - gcc_jit_function_new_block (comp.car, "is_nil"); - gcc_jit_block *not_nil_b = - gcc_jit_function_new_block (comp.car, "not_nil"); + gcc_jit_block *is_nil_b = + gcc_jit_function_new_block (f, "is_nil"); + gcc_jit_block *not_nil_b = + gcc_jit_function_new_block (f, "not_nil"); - emit_cond_jump (emit_NILP (c), - is_nil_b, - not_nil_b); + emit_cond_jump (emit_NILP (c), + is_nil_b, + not_nil_b); - comp.block->gcc_bb = is_nil_b; - gcc_jit_block_end_with_return (comp.block->gcc_bb, - NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + comp.block->gcc_bb = is_nil_b; + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); - comp.block->gcc_bb = not_nil_b; - gcc_jit_rvalue *wrong_type_args[] = - { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + comp.block->gcc_bb = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; - gcc_jit_block_add_eval (comp.block->gcc_bb, - NULL, - emit_call ("wrong_type_argument", - comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_return (comp.block->gcc_bb, - NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("wrong_type_argument", + comp.lisp_obj_type, 2, wrong_type_args)); + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); + f = comp.cdr; + param = cdr_param; + } } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ @@ -1545,7 +1602,7 @@ init_comp (int opt_level) /* Define inline functions. */ - define_CAR(); + define_CAR_CDR(); define_PSEUDOVECTORP (); define_bool_to_lisp_obj (); } @@ -1971,7 +2028,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_N (cdr, 1); + case Bcdr: + POP1; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cdr, + 1, args); + PUSH_RVAL (res); + break; + CASE_CALL_N (cons, 2); CASE (BlistN) From 0b7ea165471091d4f998f7bc8cdcda9e27bde531 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Jun 2019 20:23:49 +0200 Subject: [PATCH 0119/1452] add define_check_type --- src/comp.c | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 69 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index b6b470c20df..203d476df15 100644 --- a/src/comp.c +++ b/src/comp.c @@ -233,6 +233,7 @@ typedef struct { gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *car; gcc_jit_function *cdr; + gcc_jit_function *check_type; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -823,6 +824,12 @@ emit_XCDR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_u_cdr); } +static gcc_jit_rvalue * +emit_CHECK_CONS (gcc_jit_rvalue *x) +{ + return NULL; +} + static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) @@ -1134,6 +1141,66 @@ define_cast_union (void) cast_union_fields); } +static void +define_check_type (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "ok"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "predicate"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "x") }; + comp.check_type = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.void_type, + "CHECK_TYPE", + 3, + param, + 0); + gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); + gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); + + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.check_type, "initial_block"); + gcc_jit_block *ok_block = + gcc_jit_function_new_block (comp.check_type, "ok_block"); + gcc_jit_block *not_ok_block = + gcc_jit_function_new_block (comp.check_type, "not_ok_block"); + + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.check_type; + + emit_cond_jump (emit_cast (comp.bool_type, ok), + ok_block, + not_ok_block); + + gcc_jit_block_end_with_void_return (ok_block, NULL); + + comp.block->gcc_bb = not_ok_block; + + gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; + + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("wrong_type_argument", + comp.lisp_obj_type, 2, wrong_type_args)); + + gcc_jit_block_end_with_void_return (not_ok_block, NULL); +} + + /* Declare a substitute for CAR as always inlined function. */ static void @@ -1261,7 +1328,7 @@ define_PSEUDOVECTORP (void) 0); gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); + gcc_jit_function_new_block (comp.pseudovectorp, "initial_block"); gcc_jit_block *ret_false_b = gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); @@ -1594,6 +1661,7 @@ init_comp (int opt_level) define_handler_struct (); define_thread_state_struct (); define_cast_union (); + define_check_type (); comp.current_thread = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, From 5e3b3e95a9e5b9f269f123fc41f43f411d4c19d9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 26 Jun 2019 22:28:56 +0200 Subject: [PATCH 0120/1452] add uintptr_type --- src/comp.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 203d476df15..5df67fe55f7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -187,6 +187,7 @@ typedef struct { gcc_jit_type *void_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; + gcc_jit_type *uintptr_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; @@ -1649,9 +1650,19 @@ init_comp (int opt_level) ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; else eassert ("ptrdiff_t size not handled."); - comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); + enum gcc_jit_types uintptr_t_gcc; + if (sizeof (uintptr_t) == sizeof (unsigned)) + uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_INT; + else if (sizeof (uintptr_t) == sizeof (unsigned long)) + uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG; + else if (sizeof (uintptr_t) == sizeof (unsigned long long)) + uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG_LONG; + else + eassert ("uintptr_t size not handled."); + comp.uintptr_type = gcc_jit_context_get_type (comp.ctxt, uintptr_t_gcc); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); /* Define data structures. */ From c4ec8270ac8694a3ac812a6d1d2bddb6b8fd4c95 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 26 Jun 2019 22:29:39 +0200 Subject: [PATCH 0121/1452] rework emit_call_n_ref --- src/comp.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5df67fe55f7..309271b8e87 100644 --- a/src/comp.c +++ b/src/comp.c @@ -835,12 +835,12 @@ static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { - gcc_jit_rvalue *arguments[2] = + gcc_jit_rvalue *args[] = { gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs), + comp.ptrdiff_type, + nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (f_name, comp.lisp_obj_type, 2, arguments); + return emit_call (f_name, comp.lisp_obj_type, 2, args); } /* struct Lisp_Cons definition. */ From 98612a85a50938892b64e1386ec83eeac0fcc2a1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 28 Jun 2019 00:06:24 +0200 Subject: [PATCH 0122/1452] adding more types --- src/comp.c | 54 ++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 48 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 309271b8e87..dc378c0da09 100644 --- a/src/comp.c +++ b/src/comp.c @@ -182,7 +182,9 @@ typedef struct { gcc_jit_type *int_type; gcc_jit_type *unsigned_type; gcc_jit_type *long_type; + gcc_jit_type *unsigned_long_type; gcc_jit_type *long_long_type; + gcc_jit_type *unsigned_long_long_type; gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *char_ptr_type; @@ -218,12 +220,16 @@ typedef struct { be used for the scope. */ gcc_jit_type *cast_union_type; gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_ull; gcc_jit_field *cast_union_as_l; + gcc_jit_field *cast_union_as_ul; gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; gcc_jit_field *cast_union_as_c_p; + gcc_jit_field *cast_union_as_v_p; gcc_jit_field *cast_union_as_lisp_cons_ptr; + gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -297,20 +303,28 @@ type_to_cast_field (gcc_jit_type *type) if (type == comp.long_long_type) field = comp.cast_union_as_ll; + else if (type == comp.unsigned_long_long_type) + field = comp.cast_union_as_ull; else if (type == comp.long_type) field = comp.cast_union_as_l; + else if (type == comp.unsigned_long_type) + field = comp.cast_union_as_ul; else if (type == comp.unsigned_type) field = comp.cast_union_as_u; else if (type == comp.int_type) field = comp.cast_union_as_i; else if (type == comp.bool_type) field = comp.cast_union_as_b; + else if (type == comp.void_ptr_type) + field = comp.cast_union_as_v_p; else if (type == comp.char_ptr_type) field = comp.cast_union_as_c_p; else if (type == comp.lisp_cons_ptr_type) field = comp.cast_union_as_lisp_cons_ptr; + else if (type == comp.lisp_obj_type) + field = comp.cast_union_as_lisp_obj; else - error ("unsopported cast\n"); + error ("unsupported cast\n"); return field; } @@ -1094,11 +1108,21 @@ define_cast_union (void) NULL, comp.long_long_type, "ll"); + comp.cast_union_as_ull = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_long_type, + "ull"); comp.cast_union_as_l = gcc_jit_context_new_field (comp.ctxt, NULL, comp.long_type, "l"); + comp.cast_union_as_ul = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_type, + "ul"); comp.cast_union_as_u = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1119,20 +1143,34 @@ define_cast_union (void) NULL, comp.char_ptr_type, "c_p"); + comp.cast_union_as_v_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "v_p"); comp.cast_union_as_lisp_cons_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, comp.lisp_cons_ptr_type, "cons_ptr"); + comp.cast_union_as_lisp_obj = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "lisp_obj"); gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, + comp.cast_union_as_ull, comp.cast_union_as_l, + comp.cast_union_as_ul, comp.cast_union_as_u, comp.cast_union_as_i, comp.cast_union_as_b, comp.cast_union_as_c_p, - comp.cast_union_as_lisp_cons_ptr, }; + comp.cast_union_as_v_p, + comp.cast_union_as_lisp_cons_ptr, + comp.cast_union_as_lisp_obj}; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, @@ -1573,15 +1611,19 @@ init_comp (int opt_level) comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); - comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT); - comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); - comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, - GCC_JIT_TYPE_LONG_LONG); + comp.unsigned_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG); + comp.long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.unsigned_long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); + comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ From a65545c8905091d90685686f72d7471b61e933e7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 28 Jun 2019 00:06:57 +0200 Subject: [PATCH 0123/1452] make use of gcc_jit_context_get_int_type --- src/comp.c | 35 +++++++++-------------------------- 1 file changed, 9 insertions(+), 26 deletions(-) diff --git a/src/comp.c b/src/comp.c index dc378c0da09..f21e293de6d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1639,12 +1639,9 @@ init_comp (int opt_level) "obj"); #endif - if (sizeof (EMACS_INT) == sizeof (long)) - comp.emacs_int_type = comp.long_type; - else if (sizeof (EMACS_INT) == sizeof (long long)) - comp.emacs_int_type = comp.long_long_type; - else - error ("Unexpected EMACS_INT size."); + comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_INT), + true); comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1683,27 +1680,13 @@ init_comp (int opt_level) comp.emacs_int_type, Lisp_Int0); - enum gcc_jit_types ptrdiff_t_gcc; - if (sizeof (ptrdiff_t) == sizeof (int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_INT; - else if (sizeof (ptrdiff_t) == sizeof (long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; - else if (sizeof (ptrdiff_t) == sizeof (long long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; - else - eassert ("ptrdiff_t size not handled."); - comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); + comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + true); - enum gcc_jit_types uintptr_t_gcc; - if (sizeof (uintptr_t) == sizeof (unsigned)) - uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_INT; - else if (sizeof (uintptr_t) == sizeof (unsigned long)) - uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG; - else if (sizeof (uintptr_t) == sizeof (unsigned long long)) - uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG_LONG; - else - eassert ("uintptr_t size not handled."); - comp.uintptr_type = gcc_jit_context_get_type (comp.ctxt, uintptr_t_gcc); + comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + false); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); From 87ad88622b67ace1e9773a9beb48116d04384c0c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 28 Jun 2019 00:08:23 +0200 Subject: [PATCH 0124/1452] add define_CHECK_IMPURE --- src/comp.c | 102 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 98 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index f21e293de6d..07b6984acf6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" +#include "puresize.h" #include "buffer.h" #include "bytecode.h" #include "atimer.h" @@ -216,6 +217,8 @@ typedef struct { gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread; + /* other globals */ + gcc_jit_rvalue *pure; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -241,6 +244,7 @@ typedef struct { gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *check_type; + gcc_jit_function *check_impure; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -839,10 +843,40 @@ emit_XCDR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_u_cdr); } -static gcc_jit_rvalue * +static void emit_CHECK_CONS (gcc_jit_rvalue *x) { - return NULL; + gcc_jit_rvalue *args[] = + { emit_CONSP (x), + emit_lisp_obj_from_ptr (comp.block, Qconsp), + x }; + + + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args); +} + +static gcc_jit_rvalue * +emit_PURE_P (gcc_jit_rvalue *ptr) +{ + return + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + emit_cast (comp.uintptr_type, comp.pure)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + PURESIZE)); } static gcc_jit_rvalue * @@ -1181,7 +1215,7 @@ define_cast_union (void) } static void -define_check_type (void) +define_CHECK_TYPE (void) { gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, @@ -1408,6 +1442,61 @@ define_PSEUDOVECTORP (void) args)); } +static void +define_CHECK_IMPURE (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "obj"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.void_ptr_type, + "ptr") }; + comp.check_impure = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.void_type, + "CHECK_IMPURE", + 2, + param, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.check_impure, + "initial_block"); + gcc_jit_block *err_block = + gcc_jit_function_new_block (comp.check_impure, + "err_block"); + gcc_jit_block *ok_block = + gcc_jit_function_new_block (comp.check_impure, + "ok_block"); + + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.check_impure; + + emit_cond_jump (emit_cast (comp.bool_type, + emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ + err_block, + ok_block); + gcc_jit_block_end_with_void_return (ok_block, NULL); + + gcc_jit_rvalue *pure_write_error_arg = + gcc_jit_param_as_rvalue (param[0]); + + comp.block->gcc_bb = err_block; + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("pure_write_error", + comp.void_type, 1, + &pure_write_error_arg)); + + gcc_jit_block_end_with_void_return (err_block, NULL); +} + /* Declare a function to convert boolean into t or nil */ static void @@ -1697,17 +1786,22 @@ init_comp (int opt_level) define_handler_struct (); define_thread_state_struct (); define_cast_union (); - define_check_type (); comp.current_thread = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.thread_state_ptr_type, current_thread); + comp.pure = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + pure); /* Define inline functions. */ define_CAR_CDR(); define_PSEUDOVECTORP (); + define_CHECK_TYPE (); + define_CHECK_IMPURE (); define_bool_to_lisp_obj (); } From 34b3dac89ed681aa09b4d6b0e381504aa3adeb58 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Jun 2019 11:17:36 +0200 Subject: [PATCH 0125/1452] homogeneous emit names --- src/comp.c | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index 07b6984acf6..e5c98a84c34 100644 --- a/src/comp.c +++ b/src/comp.c @@ -497,7 +497,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } INLINE static gcc_jit_rvalue * -emit_rval_XLI (gcc_jit_rvalue *obj) +emit_XLI (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -513,7 +513,7 @@ emit_lval_XLI (gcc_jit_lvalue *obj) } INLINE static gcc_jit_rvalue * -emit_rval_XLP (gcc_jit_rvalue *obj) +emit_XLP (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -529,7 +529,7 @@ emit_lval_XLP (gcc_jit_lvalue *obj) } static gcc_jit_rvalue * -emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ @@ -540,18 +540,18 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) NULL, GCC_JIT_BINARY_OP_MINUS, comp.emacs_int_type, - emit_rval_XLI (a), + emit_XLI (a), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, lisp_word_tag))); } static gcc_jit_rvalue * -emit_rval_XCONS (gcc_jit_rvalue *a) +emit_XCONS (gcc_jit_rvalue *a) { - return emit_rval_XUNTAG (a, - gcc_jit_struct_as_type (comp.lisp_cons_s), - LISP_WORD_TAG (Lisp_Cons)); + return emit_XUNTAG (a, + gcc_jit_struct_as_type (comp.lisp_cons_s), + LISP_WORD_TAG (Lisp_Cons)); } static gcc_jit_rvalue * @@ -561,8 +561,8 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) comp.ctxt, NULL, GCC_JIT_COMPARISON_EQ, - emit_rval_XLI (x), - emit_rval_XLI (y)); + emit_XLI (x), + emit_XLI (y)); } static gcc_jit_rvalue * @@ -578,7 +578,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, - emit_rval_XLI (obj), + emit_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, (USE_LSB_TAG ? 0 : VALBITS))); @@ -661,7 +661,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, - emit_rval_XLI (obj), + emit_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); @@ -703,7 +703,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, - emit_rval_XLI (obj), + emit_XLI (obj), comp.inttypebits); } @@ -810,7 +810,7 @@ emit_XCAR (gcc_jit_rvalue *c) /* XCONS (c)->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (c), + emit_XCONS (c), NULL, comp.lisp_cons_u)), NULL, @@ -832,7 +832,7 @@ emit_XCDR (gcc_jit_rvalue *c) /* XCONS (c)->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (c), + emit_XCONS (c), NULL, comp.lisp_cons_u)), NULL, From 5202f742b0f5f0a5c317d66a8ce6a8e84e86dffc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Jun 2019 12:08:24 +0200 Subject: [PATCH 0126/1452] add setcar --- src/comp.c | 94 +++++++++++++++++++++++++++++++++++++++++- test/src/comp-tests.el | 10 ++++- 2 files changed, 101 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index e5c98a84c34..87303ab3ef0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -243,6 +243,7 @@ typedef struct { gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *car; gcc_jit_function *cdr; + gcc_jit_function *setcar; gcc_jit_function *check_type; gcc_jit_function *check_impure; basic_block_t *block; /* Current basic block */ @@ -819,6 +820,25 @@ emit_XCAR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_car); } +static gcc_jit_lvalue * +emit_lval_XCAR (gcc_jit_rvalue *c) +{ + /* XCONS (c)->u.s.car */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + static gcc_jit_rvalue * emit_XCDR (gcc_jit_rvalue *c) { @@ -859,6 +879,24 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) args); } +static gcc_jit_rvalue * +emit_car_addr (gcc_jit_rvalue *c) +{ + return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); +} + +static void +emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + gcc_jit_block_add_assignment( + comp.block->gcc_bb, + NULL, + gcc_jit_rvalue_dereference ( + emit_car_addr (c), + NULL), + n); +} + static gcc_jit_rvalue * emit_PURE_P (gcc_jit_rvalue *ptr) { @@ -1376,12 +1414,54 @@ define_CAR_CDR (void) } } +static void +define_setcar (void) +{ + + gcc_jit_param *cell = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cell"); + gcc_jit_param *new_car = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "new_car"); + + gcc_jit_param *param[] = { cell, new_car }; + comp.setcar = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "setcar", + 2, + param, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.setcar, "initial_block"); + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.setcar; + + emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + + emit_XSETCAR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_car)); + + gcc_jit_block_end_with_return (initial_block, + NULL, + gcc_jit_param_as_rvalue (new_car)); + +} /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) { - gcc_jit_param *param[2] = + gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, comp.lisp_obj_type, @@ -1803,6 +1883,7 @@ init_comp (int opt_level) define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); + define_setcar(); } static void @@ -2732,7 +2813,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (elt, 2); CASE_CALL_N (member, 2); CASE_CALL_N (assq, 2); - CASE_CALL_N (setcar, 2); + + case Bsetcar: + POP2; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcar, + 2, args); + PUSH_RVAL (res); + break; + CASE_CALL_N (setcdr, 2); CASE (Bcar_safe) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 31b2f0f001e..8fd3ca2e197 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -313,12 +313,20 @@ (defun comp-tests-consp-f (x) ;; Bconsp (consp x)) + (defun comp-tests-car-f (x) + ;; Bsetcar + (setcar x 3)) (byte-compile #'comp-tests-consp-f) (native-compile #'comp-tests-consp-f) + (byte-compile #'comp-tests-car-f) + (native-compile #'comp-tests-car-f) (should (eq (comp-tests-consp-f '(1)) t)) - (should (eq (comp-tests-consp-f 1) nil))) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-car-f x) 3)) + (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () "Test some inlined number functions." From ecf40f95a65d3232a1295be2361f07abede48b23 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Jun 2019 15:42:27 +0200 Subject: [PATCH 0127/1452] emit comments for inlined functions --- src/comp.c | 310 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 182 insertions(+), 128 deletions(-) diff --git a/src/comp.c b/src/comp.c index 87303ab3ef0..5be5fa51d36 100644 --- a/src/comp.c +++ b/src/comp.c @@ -123,10 +123,7 @@ along with GNU Emacs. If not, see . */ #define CASE(op) \ case op : \ - if (COMP_DEBUG) \ - gcc_jit_block_add_comment (comp.block->gcc_bb, \ - NULL, \ - "Opcode " STR(op)); + emit_comment (STR(op)) /* Pop from the meta-stack, emit the call and push the result */ @@ -140,7 +137,7 @@ along with GNU Emacs. If not, see . */ /* Generate appropriate case and emit call to function. */ #define CASE_CALL_N(name, nargs) \ - CASE (B##name) \ + CASE (B##name); \ EMIT_CALL_N (STR(F##name), nargs); \ break @@ -334,6 +331,15 @@ type_to_cast_field (gcc_jit_type *type) return field; } +INLINE static void +emit_comment (const char *str) +{ + if (COMP_DEBUG) + gcc_jit_block_add_comment (comp.block->gcc_bb, + NULL, + str); +} + static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, @@ -500,6 +506,8 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { + emit_comment ("XLI"); + return gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_as_num); @@ -508,6 +516,8 @@ emit_XLI (gcc_jit_rvalue *obj) INLINE static gcc_jit_lvalue * emit_lval_XLI (gcc_jit_lvalue *obj) { + emit_comment ("lval_XLI"); + return gcc_jit_lvalue_access_field (obj, NULL, comp.lisp_obj_as_num); @@ -516,6 +526,8 @@ emit_lval_XLI (gcc_jit_lvalue *obj) INLINE static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { + emit_comment ("XLP"); + return gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_as_ptr); @@ -524,6 +536,8 @@ emit_XLP (gcc_jit_rvalue *obj) INLINE static gcc_jit_lvalue * emit_lval_XLP (gcc_jit_lvalue *obj) { + emit_comment ("lval_XLP"); + return gcc_jit_lvalue_access_field (obj, NULL, comp.lisp_obj_as_ptr); @@ -534,6 +548,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + emit_comment ("XUNTAG"); return emit_cast (gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( @@ -550,6 +565,8 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) static gcc_jit_rvalue * emit_XCONS (gcc_jit_rvalue *a) { + emit_comment ("XCONS"); + return emit_XUNTAG (a, gcc_jit_struct_as_type (comp.lisp_cons_s), LISP_WORD_TAG (Lisp_Cons)); @@ -558,6 +575,8 @@ emit_XCONS (gcc_jit_rvalue *a) static gcc_jit_rvalue * emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) { + emit_comment ("EQ"); + return gcc_jit_context_new_comparison ( comp.ctxt, NULL, @@ -572,6 +591,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ & ((1 << GCTYPEBITS) - 1))) */ + emit_comment ("TAGGEDP"); gcc_jit_rvalue *sh_res = gcc_jit_context_new_binary_op ( @@ -617,18 +637,24 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) static gcc_jit_rvalue * emit_VECTORLIKEP (gcc_jit_rvalue *obj) { + emit_comment ("VECTORLIKEP"); + return emit_TAGGEDP (obj, Lisp_Vectorlike); } static gcc_jit_rvalue * emit_CONSP (gcc_jit_rvalue *obj) { + emit_comment ("CONSP"); + return emit_TAGGEDP (obj, Lisp_Cons); } static gcc_jit_rvalue * emit_FLOATP (gcc_jit_rvalue *obj) { + emit_comment ("FLOATP"); + return emit_TAGGEDP (obj, Lisp_Float); } @@ -636,6 +662,8 @@ static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ + emit_comment ("BIGNUMP"); + gcc_jit_rvalue *args[2] = { obj, gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -655,6 +683,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) & ((1 << INTTYPEBITS) - 1))) */ + emit_comment ("FIXNUMP"); gcc_jit_rvalue *sh_res = gcc_jit_context_new_binary_op ( @@ -700,6 +729,8 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_XFIXNUM (gcc_jit_rvalue *obj) { + emit_comment ("XFIXNUM"); + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, @@ -711,6 +742,8 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_INTEGERP (gcc_jit_rvalue *obj) { + emit_comment ("INTEGERP"); + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, @@ -723,6 +756,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_NUMBERP (gcc_jit_rvalue *obj) { + emit_comment ("NUMBERP"); + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, @@ -735,6 +770,8 @@ emit_NUMBERP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { + emit_comment ("make_fixnum"); + gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, NULL, @@ -764,12 +801,15 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) } /* Construct fill and return a lisp object form a raw pointer. */ -/* TODO should we pass the bb? */ +/* FIXME do not pass bb */ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *block, void *p) { static unsigned i; + comp.block = block; + emit_comment ("lisp_obj_from_ptr"); + gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, @@ -781,9 +821,7 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) p); if (SYMBOLP (p)) - gcc_jit_block_add_comment ( - block->gcc_bb, - NULL, + emit_comment ( format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); @@ -797,12 +835,16 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { + emit_comment ("NILP"); + return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); } static gcc_jit_rvalue * emit_XCAR (gcc_jit_rvalue *c) { + emit_comment ("XCAR"); + /* XCONS (c)->u.s.car */ return gcc_jit_rvalue_access_field ( @@ -823,6 +865,8 @@ emit_XCAR (gcc_jit_rvalue *c) static gcc_jit_lvalue * emit_lval_XCAR (gcc_jit_rvalue *c) { + emit_comment ("lval_XCAR"); + /* XCONS (c)->u.s.car */ return gcc_jit_lvalue_access_field ( @@ -842,6 +886,7 @@ emit_lval_XCAR (gcc_jit_rvalue *c) static gcc_jit_rvalue * emit_XCDR (gcc_jit_rvalue *c) { + emit_comment ("XCDR"); /* XCONS (c)->u.s.u.cdr */ return gcc_jit_rvalue_access_field ( @@ -866,6 +911,8 @@ emit_XCDR (gcc_jit_rvalue *c) static void emit_CHECK_CONS (gcc_jit_rvalue *x) { + emit_comment ("CHECK_CONS"); + gcc_jit_rvalue *args[] = { emit_CONSP (x), emit_lisp_obj_from_ptr (comp.block, Qconsp), @@ -882,12 +929,16 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) static gcc_jit_rvalue * emit_car_addr (gcc_jit_rvalue *c) { + emit_comment ("car_addr"); + return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); } static void emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { + emit_comment ("XSETCAR"); + gcc_jit_block_add_assignment( comp.block->gcc_bb, NULL, @@ -900,6 +951,9 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) static gcc_jit_rvalue * emit_PURE_P (gcc_jit_rvalue *ptr) { + + emit_comment ("PURE_P"); + return gcc_jit_context_new_comparison ( comp.ctxt, @@ -1995,47 +2049,47 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, switch (op) { - CASE (Bstack_ref1) + CASE (Bstack_ref1); goto stack_ref; - CASE (Bstack_ref2) + CASE (Bstack_ref2); goto stack_ref; - CASE (Bstack_ref3) + CASE (Bstack_ref3); goto stack_ref; - CASE (Bstack_ref4) + CASE (Bstack_ref4); goto stack_ref; - CASE (Bstack_ref5) + CASE (Bstack_ref5); stack_ref: PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); break; - CASE (Bstack_ref6) + CASE (Bstack_ref6); PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); break; - CASE (Bstack_ref7) + CASE (Bstack_ref7); PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); break; - CASE (Bvarref7) + CASE (Bvarref7); op = FETCH2; goto varref; - CASE (Bvarref) + CASE (Bvarref); goto varref_count; - CASE (Bvarref1) + CASE (Bvarref1); goto varref_count; - CASE (Bvarref2) + CASE (Bvarref2); goto varref_count; - CASE (Bvarref3) + CASE (Bvarref3); goto varref_count; - CASE (Bvarref4) + CASE (Bvarref4); goto varref_count; - CASE (Bvarref5) + CASE (Bvarref5); varref_count: op -= Bvarref; goto varref; - CASE (Bvarref6) + CASE (Bvarref6); op = FETCH; varref: { @@ -2045,26 +2099,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bvarset) + CASE (Bvarset); goto varset_count; - CASE (Bvarset1) + CASE (Bvarset1); goto varset_count; - CASE (Bvarset2) + CASE (Bvarset2); goto varset_count; - CASE (Bvarset3) + CASE (Bvarset3); goto varset_count; - CASE (Bvarset4) + CASE (Bvarset4); goto varset_count; - CASE (Bvarset5) + CASE (Bvarset5); varset_count: op -= Bvarset; goto varset; - CASE (Bvarset7) + CASE (Bvarset7); op = FETCH2; goto varset; - CASE (Bvarset6) + CASE (Bvarset6); op = FETCH; varset: { @@ -2080,25 +2134,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Bvarbind6) + CASE (Bvarbind6); op = FETCH; goto varbind; - CASE (Bvarbind7) + CASE (Bvarbind7); op = FETCH2; goto varbind; - CASE (Bvarbind) + CASE (Bvarbind); goto varbind_count; - CASE (Bvarbind1) + CASE (Bvarbind1); goto varbind_count; - CASE (Bvarbind2) + CASE (Bvarbind2); goto varbind_count; - CASE (Bvarbind3) + CASE (Bvarbind3); goto varbind_count; - CASE (Bvarbind4) + CASE (Bvarbind4); goto varbind_count; - CASE (Bvarbind5) + CASE (Bvarbind5); varbind_count: op -= Bvarbind; varbind: @@ -2110,25 +2164,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bcall6) + CASE (Bcall6); op = FETCH; goto docall; - CASE (Bcall7) + CASE (Bcall7); op = FETCH2; goto docall; - CASE (Bcall) + CASE (Bcall); goto docall_count; - CASE (Bcall1) + CASE (Bcall1); goto docall_count; - CASE (Bcall2) + CASE (Bcall2); goto docall_count; - CASE (Bcall3) + CASE (Bcall3); goto docall_count; - CASE (Bcall4) + CASE (Bcall4); goto docall_count; - CASE (Bcall5) + CASE (Bcall5); docall_count: op -= Bcall; docall: @@ -2140,25 +2194,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bunbind6) + CASE (Bunbind6); op = FETCH; goto dounbind; - CASE (Bunbind7) + CASE (Bunbind7); op = FETCH2; goto dounbind; - CASE (Bunbind) + CASE (Bunbind); goto dounbind_count; - CASE (Bunbind1) + CASE (Bunbind1); goto dounbind_count; - CASE (Bunbind2) + CASE (Bunbind2); goto dounbind_count; - CASE (Bunbind3) + CASE (Bunbind3); goto dounbind_count; - CASE (Bunbind4) + CASE (Bunbind4); goto dounbind_count; - CASE (Bunbind5) + CASE (Bunbind5); dounbind_count: op -= Bunbind; dounbind: @@ -2171,7 +2225,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Bpophandler) + CASE (Bpophandler); { /* current_thread->m_handlerlist = current_thread->m_handlerlist->next; */ @@ -2192,11 +2246,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bpushconditioncase) /* New in 24.4. */ + CASE (Bpushconditioncase); /* New in 24.4. */ type = CONDITION_CASE; goto pushhandler; - CASE (Bpushcatch) /* New in 24.4. */ + CASE (Bpushcatch); /* New in 24.4. */ type = CATCHER; pushhandler: { @@ -2281,7 +2335,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (nth, 2); CASE_CALL_N (symbolp, 1); - CASE (Bconsp) + CASE (Bconsp); POP1; res = emit_cast (comp.bool_type, emit_CONSP (args[0])); @@ -2318,17 +2372,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (cons, 2); - CASE (BlistN) + CASE (BlistN); op = FETCH; goto make_list; - CASE (Blist1) + CASE (Blist1); goto make_list_count; - CASE (Blist2) + CASE (Blist2); goto make_list_count; - CASE (Blist3) + CASE (Blist3); goto make_list_count; - CASE (Blist4) + CASE (Blist4); make_list_count: op = op - Blist1; make_list: @@ -2356,21 +2410,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (get, 2); CASE_CALL_N (substring, 3); - CASE (Bconcat2) + CASE (Bconcat2); EMIT_CALL_N_REF ("Fconcat", 2); break; - CASE (Bconcat3) + CASE (Bconcat3); EMIT_CALL_N_REF ("Fconcat", 3); break; - CASE (Bconcat4) + CASE (Bconcat4); EMIT_CALL_N_REF ("Fconcat", 4); break; - CASE (BconcatN) + CASE (BconcatN); op = FETCH; EMIT_CALL_N_REF ("Fconcat", op); break; - CASE (Bsub1) + CASE (Bsub1); { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -2430,7 +2484,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Badd1) + CASE (Badd1); { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM @@ -2490,31 +2544,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Beqlsign) + CASE (Beqlsign); EMIT_ARITHCOMPARE (ARITH_EQUAL); break; - CASE (Bgtr) + CASE (Bgtr); EMIT_ARITHCOMPARE (ARITH_GRTR); break; - CASE (Blss) + CASE (Blss); EMIT_ARITHCOMPARE (ARITH_LESS); break; - CASE (Bleq) + CASE (Bleq); EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); break; - CASE (Bgeq) + CASE (Bgeq); EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); break; - CASE (Bdiff) + CASE (Bdiff); EMIT_CALL_N_REF ("Fminus", 2); break; - CASE (Bnegate) + CASE (Bnegate); { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -2569,19 +2623,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb); } break; - CASE (Bplus) + CASE (Bplus); EMIT_CALL_N_REF ("Fplus", 2); break; - CASE (Bmax) + CASE (Bmax); EMIT_CALL_N_REF ("Fmax", 2); break; - CASE (Bmin) + CASE (Bmin); EMIT_CALL_N_REF ("Fmin", 2); break; - CASE (Bmult) + CASE (Bmult); EMIT_CALL_N_REF ("Ftimes", 2); break; - CASE (Bpoint) + CASE (Bpoint); args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2595,11 +2649,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (goto_char, 1); - CASE (Binsert) + CASE (Binsert); EMIT_CALL_N_REF ("Finsert", 1); break; - CASE (Bpoint_max) + CASE (Bpoint_max); args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2611,7 +2665,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE (Bpoint_min) + CASE (Bpoint_min); args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2626,14 +2680,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (char_after, 1); CASE_CALL_N (following_char, 0); - CASE (Bpreceding_char) + CASE (Bpreceding_char); res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_RVAL (res); break; CASE_CALL_N (current_column, 0); - CASE (Bindent_to) + CASE (Bindent_to); POP1; args[1] = nil; res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); @@ -2647,15 +2701,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (current_buffer, 0); CASE_CALL_N (set_buffer, 1); - CASE (Bsave_current_buffer) /* Obsolete since ??. */ + CASE (Bsave_current_buffer); /* Obsolete since ??. */ goto save_current; - CASE (Bsave_current_buffer_1) + CASE (Bsave_current_buffer_1); save_current: emit_call ("record_unwind_current_buffer", comp.void_type, 0, NULL); break; - CASE (Binteractive_p) /* Obsolete since 24.1. */ + CASE (Binteractive_p); /* Obsolete since 24.1. */ PUSH_RVAL (emit_lisp_obj_from_ptr (comp.block, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); @@ -2674,11 +2728,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (widen, 0); CASE_CALL_N (end_of_line, 1); - CASE (Bconstant2) + CASE (Bconstant2); goto do_constant; break; - CASE (Bgoto) + CASE (Bgoto); op = FETCH2; gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, @@ -2687,7 +2741,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (Bgotoifnil) + CASE (Bgotoifnil); op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, @@ -2695,7 +2749,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (Bgotoifnonnil) + CASE (Bgotoifnonnil); op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, @@ -2703,7 +2757,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (Bgotoifnilelsepop) + CASE (Bgotoifnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), @@ -2713,7 +2767,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (Bgotoifnonnilelsepop) + CASE (Bgotoifnonnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), @@ -2723,7 +2777,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (Breturn) + CASE (Breturn); POP1; gcc_jit_block_end_with_return(comp.block->gcc_bb, NULL, @@ -2731,24 +2785,24 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.block->terminated = true; break; - CASE (Bdiscard) + CASE (Bdiscard); DISCARD (1); break; - CASE (Bdup) + CASE (Bdup); PUSH_LVAL (TOS); break; - CASE (Bsave_excursion) + CASE (Bsave_excursion); res = emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; - CASE (Bsave_window_excursion) /* Obsolete since 24.1. */ + CASE (Bsave_window_excursion); /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_save_window_excursion", 1); break; - CASE (Bsave_restriction) + CASE (Bsave_restriction); args[0] = emit_lisp_obj_from_ptr (comp.block, save_restriction_restore); args[1] = emit_call ("save_restriction_save", @@ -2758,29 +2812,29 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - CASE (Bcatch) /* Obsolete since 24.4. */ + CASE (Bcatch); /* Obsolete since 24.4. */ POP2; args[2] = args[1]; args[1] = emit_lisp_obj_from_ptr (comp.block, eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; - CASE (Bunwind_protect) /* FIXME: avoid closure for lexbind. */ + CASE (Bunwind_protect); /* FIXME: avoid closure for lexbind. */ POP1; emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - CASE (Bcondition_case) /* Obsolete since 24.4. */ + CASE (Bcondition_case); /* Obsolete since 24.4. */ POP3; emit_call ("internal_lisp_condition_case", comp.lisp_obj_type, 3, args); break; - CASE (Btemp_output_buffer_setup) /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_setup); /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; - CASE (Btemp_output_buffer_show) /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_show); /* Obsolete since 24.1. */ POP2; emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); @@ -2788,7 +2842,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; - CASE (Bunbind_all) /* Obsolete. Never used. */ + CASE (Bunbind_all); /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); @@ -2800,11 +2854,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (upcase, 1); CASE_CALL_N (downcase, 1); - CASE (Bstringeqlsign) + CASE (Bstringeqlsign); EMIT_CALL_N ("Fstring_equal", 2); break; - CASE (Bstringlss) + CASE (Bstringlss); EMIT_CALL_N ("Fstring_lessp", 2); break; @@ -2825,25 +2879,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (setcdr, 2); - CASE (Bcar_safe) + CASE (Bcar_safe); EMIT_CALL_N ("CAR_SAFE", 1); break; - CASE (Bcdr_safe) + CASE (Bcdr_safe); EMIT_CALL_N ("CDR_SAFE", 1); break; - CASE (Bnconc) + CASE (Bnconc); EMIT_CALL_N_REF ("Fnconc", 2); break; - CASE (Bquo) + CASE (Bquo); EMIT_CALL_N_REF ("Fquo", 2); break; CASE_CALL_N (rem, 2); - CASE (Bnumberp) + CASE (Bnumberp); POP1; res = emit_NUMBERP (args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2853,7 +2907,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE (Bintegerp) + CASE (Bintegerp); POP1; res = emit_INTEGERP(args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2863,7 +2917,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE (BRgoto) + CASE (BRgoto); op = FETCH - 128; op += pc; gcc_jit_block_end_with_jump (comp.block->gcc_bb, @@ -2873,7 +2927,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (BRgotoifnil) + CASE (BRgotoifnil); op = FETCH - 128; op += pc; POP1; @@ -2882,7 +2936,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (BRgotoifnonnil) + CASE (BRgotoifnonnil); op = FETCH - 128; op += pc; POP1; @@ -2891,7 +2945,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (BRgotoifnilelsepop) + CASE (BRgotoifnilelsepop); op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, @@ -2902,7 +2956,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (BRgotoifnonnilelsepop) + CASE (BRgotoifnonnilelsepop); op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_NE, @@ -2913,12 +2967,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (BinsertN) + CASE (BinsertN); op = FETCH; EMIT_CALL_N_REF ("Finsert", op); break; - CASE (Bstack_set) + CASE (Bstack_set); /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ op = FETCH; POP1; @@ -2929,7 +2983,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - CASE (Bstack_set2) + CASE (Bstack_set2); op = FETCH2; POP1; gcc_jit_block_add_assignment (comp.block->gcc_bb, @@ -2938,7 +2992,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - CASE (BdiscardN) + CASE (BdiscardN); op = FETCH; if (op & 0x80) { @@ -2952,7 +3006,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (op); break; - CASE (Bswitch) + CASE (Bswitch); error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done @@ -2963,7 +3017,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; default: - CASE (Bconstant) + CASE (Bconstant); { if (op < Bconstant || op > Bconstant + vector_size) goto fail; From 58dfd08fed075df5b0e8b059716b3e3638eafce9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Jun 2019 16:44:06 +0200 Subject: [PATCH 0128/1452] reworking blocks --- src/comp.c | 369 ++++++++++++++++++++++++++--------------------------- 1 file changed, 180 insertions(+), 189 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5be5fa51d36..4973a517d6f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -130,7 +130,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_CALL_N(name, nargs) \ do { \ POP##nargs; \ - res = emit_call (name, comp.lisp_obj_type, nargs, args); \ + res = emit_call ((name), comp.lisp_obj_type, (nargs), args); \ PUSH_RVAL (res); \ } while (0) @@ -149,7 +149,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_CALL_N_REF(name, nargs) \ do { \ DISCARD (nargs); \ - res = emit_call_n_ref (name, nargs, *stack); \ + res = emit_call_n_ref ((name), (nargs), *stack); \ PUSH_RVAL (res); \ } while (0) @@ -158,11 +158,24 @@ along with GNU Emacs. If not, see . */ POP2; \ args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ comp.int_type, \ - comparison); \ + (comparison)); \ res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ PUSH_RVAL (res); \ } while (0) + +#define SAFE_ALLOCA_BLOCK(ptr, func, name) \ +do { \ + (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ + (ptr)->gcc_bb = gcc_jit_function_new_block ((func), (name)); \ + (ptr)->terminated = false; \ + (ptr)->top = NULL; \ + } while (0) + +#define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ + basic_block_t *(name); \ + SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) + typedef struct { gcc_jit_block *gcc_bb; /* When non zero indicates a stack pointer restart. */ @@ -261,7 +274,6 @@ typedef struct { void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); - static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) { @@ -450,22 +462,22 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, INLINE static void emit_cond_jump (gcc_jit_rvalue *test, - gcc_jit_block *then_target, gcc_jit_block *else_target) + basic_block_t *then_target, basic_block_t *else_target) { gcc_jit_block_end_with_conditional (comp.block->gcc_bb, NULL, test, - then_target, - else_target); + then_target->gcc_bb, + else_target->gcc_bb); comp.block->terminated = true; } /* Close current basic block emitting a comparison between two rval. */ static gcc_jit_rvalue * -emit_comparison_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ +emit_comparison_jump (enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) + basic_block_t *then_target, basic_block_t *else_target) { gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, NULL, @@ -768,7 +780,7 @@ emit_NUMBERP (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) +emit_make_fixnum (gcc_jit_rvalue *obj) { emit_comment ("make_fixnum"); @@ -792,7 +804,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) comp.lisp_obj_type, "lisp_obj_fixnum"); - gcc_jit_block_add_assignment (block, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, emit_lval_XLI (res), tmp); @@ -801,13 +813,10 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) } /* Construct fill and return a lisp object form a raw pointer. */ -/* FIXME do not pass bb */ static gcc_jit_rvalue * -emit_lisp_obj_from_ptr (basic_block_t *block, void *p) +emit_lisp_obj_from_ptr (void *p) { static unsigned i; - - comp.block = block; emit_comment ("lisp_obj_from_ptr"); gcc_jit_lvalue *lisp_obj = @@ -825,10 +834,11 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); - gcc_jit_block_add_assignment (block->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, emit_lval_XLP (lisp_obj), void_ptr); + return gcc_jit_lvalue_as_rvalue (lisp_obj); } @@ -837,7 +847,7 @@ emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); + return emit_EQ (x, emit_lisp_obj_from_ptr (Qnil)); } static gcc_jit_rvalue * @@ -915,10 +925,9 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_lisp_obj_from_ptr (comp.block, Qconsp), + emit_lisp_obj_from_ptr (Qconsp), x }; - gcc_jit_context_new_call (comp.ctxt, NULL, comp.check_type, @@ -1309,6 +1318,7 @@ define_cast_union (void) static void define_CHECK_TYPE (void) { + USE_SAFE_ALLOCA; gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1334,26 +1344,20 @@ define_CHECK_TYPE (void) gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.check_type, "initial_block"); - gcc_jit_block *ok_block = - gcc_jit_function_new_block (comp.check_type, "ok_block"); - gcc_jit_block *not_ok_block = - gcc_jit_function_new_block (comp.check_type, "not_ok_block"); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_type); + DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_type); + DECL_AND_SAFE_ALLOCA_BLOCK (not_ok_block, comp.check_type); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + comp.block = init_block; comp.func = comp.check_type; emit_cond_jump (emit_cast (comp.bool_type, ok), ok_block, not_ok_block); - gcc_jit_block_end_with_void_return (ok_block, NULL); + gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); - comp.block->gcc_bb = not_ok_block; + comp.block = not_ok_block; gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; @@ -1362,7 +1366,9 @@ define_CHECK_TYPE (void) emit_call ("wrong_type_argument", comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_void_return (not_ok_block, NULL); + gcc_jit_block_end_with_void_return (not_ok_block->gcc_bb, NULL); + + SAFE_FREE (); } @@ -1371,6 +1377,8 @@ define_CHECK_TYPE (void) static void define_CAR_CDR (void) { + USE_SAFE_ALLOCA; + gcc_jit_param *car_param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1404,20 +1412,11 @@ define_CAR_CDR (void) for (int i = 0; i < 2; i++) { gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (f, "initial_block"); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, f); + DECL_AND_SAFE_ALLOCA_BLOCK (is_cons_b, f); + DECL_AND_SAFE_ALLOCA_BLOCK (not_a_cons_b, f); - gcc_jit_block *is_cons_b = - gcc_jit_function_new_block (f, "is_cons"); - - gcc_jit_block *not_a_cons_b = - gcc_jit_function_new_block (f, "not_a_cons"); - - - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + comp.block = init_block; comp.func = f; emit_cond_jump (emit_cast (comp.bool_type, @@ -1425,7 +1424,7 @@ define_CAR_CDR (void) is_cons_b, not_a_cons_b); - comp.block->gcc_bb = is_cons_b; + comp.block = is_cons_b; if (f == comp.car) gcc_jit_block_end_with_return (comp.block->gcc_bb, @@ -1436,25 +1435,23 @@ define_CAR_CDR (void) NULL, emit_XCDR (c)); - comp.block->gcc_bb = not_a_cons_b; + comp.block = not_a_cons_b; - gcc_jit_block *is_nil_b = - gcc_jit_function_new_block (f, "is_nil"); - gcc_jit_block *not_nil_b = - gcc_jit_function_new_block (f, "not_nil"); + DECL_AND_SAFE_ALLOCA_BLOCK (is_nil_b, f); + DECL_AND_SAFE_ALLOCA_BLOCK (not_nil_b, f); emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); - comp.block->gcc_bb = is_nil_b; + comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + emit_lisp_obj_from_ptr (Qnil)); - comp.block->gcc_bb = not_nil_b; + comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + { emit_lisp_obj_from_ptr (Qlistp), c }; gcc_jit_block_add_eval (comp.block->gcc_bb, NULL, @@ -1462,15 +1459,18 @@ define_CAR_CDR (void) comp.lisp_obj_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + emit_lisp_obj_from_ptr (Qnil)); f = comp.cdr; param = cdr_param; } + + SAFE_FREE (); } static void define_setcar (void) { + USE_SAFE_ALLOCA; gcc_jit_param *cell = gcc_jit_context_new_param (comp.ctxt, @@ -1492,12 +1492,9 @@ define_setcar (void) 2, param, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.setcar, "initial_block"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.setcar); + comp.block = init_block; comp.func = comp.setcar; emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); @@ -1505,16 +1502,18 @@ define_setcar (void) emit_XSETCAR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_car)); - gcc_jit_block_end_with_return (initial_block, + gcc_jit_block_end_with_return (init_block->gcc_bb, NULL, gcc_jit_param_as_rvalue (new_car)); - + SAFE_FREE (); } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) { + USE_SAFE_ALLOCA; + gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1534,19 +1533,11 @@ define_PSEUDOVECTORP (void) param, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.pseudovectorp, "initial_block"); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.pseudovectorp); + DECL_AND_SAFE_ALLOCA_BLOCK (ret_false_b, comp.pseudovectorp); + DECL_AND_SAFE_ALLOCA_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); - gcc_jit_block *ret_false_b = - gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); - - gcc_jit_block *call_pseudovector_typep_b = - gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); - - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + comp.block = init_block; comp.func = comp.pseudovectorp; emit_cond_jump ( @@ -1555,8 +1546,9 @@ define_PSEUDOVECTORP (void) call_pseudovector_typep_b, ret_false_b); - comp.block->gcc_bb = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b, + comp.block = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b->gcc_bb + , NULL, gcc_jit_context_new_rvalue_from_int( comp.ctxt, @@ -1566,19 +1558,23 @@ define_PSEUDOVECTORP (void) gcc_jit_rvalue *args[2] = { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; - comp.block->gcc_bb = call_pseudovector_typep_b; + comp.block = call_pseudovector_typep_b; /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b, + gcc_jit_block_end_with_return (call_pseudovector_typep_b->gcc_bb + , NULL, emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args)); + SAFE_FREE (); } static void define_CHECK_IMPURE (void) { + USE_SAFE_ALLOCA; + gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1596,46 +1592,42 @@ define_CHECK_IMPURE (void) 2, param, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.check_impure, - "initial_block"); - gcc_jit_block *err_block = - gcc_jit_function_new_block (comp.check_impure, - "err_block"); - gcc_jit_block *ok_block = - gcc_jit_function_new_block (comp.check_impure, - "ok_block"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_impure); + DECL_AND_SAFE_ALLOCA_BLOCK (err_block, comp.check_impure); + DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_impure); + + comp.block = init_block; comp.func = comp.check_impure; - emit_cond_jump (emit_cast (comp.bool_type, - emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ - err_block, - ok_block); - gcc_jit_block_end_with_void_return (ok_block, NULL); + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ + err_block, + ok_block); + gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); gcc_jit_rvalue *pure_write_error_arg = gcc_jit_param_as_rvalue (param[0]); - comp.block->gcc_bb = err_block; + comp.block = err_block; gcc_jit_block_add_eval (comp.block->gcc_bb, NULL, emit_call ("pure_write_error", comp.void_type, 1, &pure_write_error_arg)); - gcc_jit_block_end_with_void_return (err_block, NULL); -} + gcc_jit_block_end_with_void_return (err_block->gcc_bb, NULL); + + SAFE_FREE ();} /* Declare a function to convert boolean into t or nil */ static void define_bool_to_lisp_obj (void) { + USE_SAFE_ALLOCA; + /* x ? Qt : Qnil */ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1649,32 +1641,27 @@ define_bool_to_lisp_obj (void) 1, ¶m, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.bool_to_lisp_obj, - "bool_to_lisp_obj_initial_block"); - gcc_jit_block *ret_t_block = - gcc_jit_function_new_block (comp.bool_to_lisp_obj, - "ret_t"); - gcc_jit_block *ret_nil_block = - gcc_jit_function_new_block (comp.bool_to_lisp_obj, - "ret_nil"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.bool_to_lisp_obj); + DECL_AND_SAFE_ALLOCA_BLOCK (ret_t_block, comp.bool_to_lisp_obj); + DECL_AND_SAFE_ALLOCA_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); + comp.block = init_block; comp.func = comp.bool_to_lisp_obj; emit_cond_jump (gcc_jit_param_as_rvalue (param), ret_t_block, ret_nil_block); - block.gcc_bb = ret_t_block; - gcc_jit_block_end_with_return (ret_t_block, + + comp.block = ret_t_block; + gcc_jit_block_end_with_return (ret_t_block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (&block, Qt)); - block.gcc_bb = ret_nil_block; - gcc_jit_block_end_with_return (ret_nil_block, + emit_lisp_obj_from_ptr (Qt)); + + comp.block = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (&block, Qnil)); + emit_lisp_obj_from_ptr (Qnil)); + + SAFE_FREE (); } static int @@ -1965,6 +1952,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned op; unsigned pushhandler_n = 0; + USE_SAFE_ALLOCA; + /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ gcc_jit_lvalue **stack_base, **stack, **stack_over; @@ -2026,7 +2015,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); - gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (&bb_map[0], Qnil); + comp.block = &bb_map[0]; + gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); comp.block = NULL; @@ -2093,7 +2083,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (vectorp[op]); res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); break; @@ -2124,7 +2114,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -2157,7 +2147,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (vectorp[op]); pop (1, &stack, &args[1]); res = emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_RVAL (res); @@ -2284,10 +2274,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, #else res = emit_call ("setjmp", comp.int_type, 1, args); #endif - gcc_jit_block *push_h_val_block = - gcc_jit_function_new_block (comp.func, - format_string ("push_h_val_%u", - pushhandler_n)); + basic_block_t *push_h_val_block; + SAFE_ALLOCA_BLOCK (push_h_val_block, + comp.func, + format_string ("push_h_val_%u", + pushhandler_n)); emit_cond_jump ( /* This negation is just to have a bool. */ gcc_jit_context_new_unary_op (comp.ctxt, @@ -2295,14 +2286,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.bool_type, res), - bb_map[pc].gcc_bb, + &bb_map[pc], push_h_val_block); gcc_jit_lvalue **stack_to_restore = stack; /* This emit the handler part. */ - basic_block_t bb_orig = *comp.block; - comp.block->gcc_bb = push_h_val_block; + basic_block_t *bb_orig = comp.block; + comp.block = push_h_val_block; /* current_thread->m_handlerlist = c->next; */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field (comp.current_thread, @@ -2322,9 +2313,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, comp.handler_val_field)); bb_map[handler_pc].top = stack; - *comp.block = bb_orig; + comp.block = bb_orig; - gcc_jit_block_end_with_jump (push_h_val_block, NULL, + gcc_jit_block_end_with_jump (push_h_val_block->gcc_bb, NULL, bb_map[handler_pc].gcc_bb); stack = stack_to_restore; @@ -2426,15 +2417,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bsub1); { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM ? make_fixnum (XFIXNUM (TOP) - 1) : Fsub1 (TOP)) */ - gcc_jit_block *sub1_inline_block = - gcc_jit_function_new_block (comp.func, "inline_sub1"); - gcc_jit_block *sub1_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall_sub1"); + DECL_AND_SAFE_ALLOCA_BLOCK (sub1_inline_block, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -2463,38 +2451,38 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, tos_as_num, comp.one); - gcc_jit_block_add_assignment (sub1_inline_block, + basic_block_t *bb_orig = comp.block; + + comp.block = sub1_inline_block; + gcc_jit_block_add_assignment (sub1_inline_block->gcc_bb, NULL, TOS, - emit_make_fixnum (sub1_inline_block, - sub1_inline_res)); - basic_block_t bb_orig = *comp.block; + emit_make_fixnum (sub1_inline_res)); - comp.block->gcc_bb = sub1_fcall_block; + comp.block = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.block = bb_orig; - - gcc_jit_block_end_with_jump (sub1_inline_block, NULL, + gcc_jit_block_end_with_jump (sub1_inline_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall_block, NULL, + gcc_jit_block_end_with_jump (sub1_fcall_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); + comp.block = bb_orig; + SAFE_FREE (); } break; CASE (Badd1); { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM ? make_fixnum (XFIXNUM (TOP) + 1) : Fadd (TOP)) */ - gcc_jit_block *add1_inline_block = - gcc_jit_function_new_block (comp.func, "inline_add1"); - gcc_jit_block *add1_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall_add1"); + DECL_AND_SAFE_ALLOCA_BLOCK (add1_inline_block, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -2523,24 +2511,27 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, tos_as_num, comp.one); - gcc_jit_block_add_assignment (add1_inline_block, + basic_block_t *bb_orig = comp.block; + comp.block = add1_inline_block; + + gcc_jit_block_add_assignment (add1_inline_block->gcc_bb + , NULL, TOS, - emit_make_fixnum (add1_inline_block, - add1_inline_res)); - basic_block_t bb_orig = *comp.block; - - comp.block->gcc_bb = add1_fcall_block; + emit_make_fixnum (add1_inline_res)); + comp.block = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.block = bb_orig; - - gcc_jit_block_end_with_jump (add1_inline_block, NULL, + gcc_jit_block_end_with_jump (add1_inline_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (add1_fcall_block, NULL, + gcc_jit_block_end_with_jump (add1_fcall_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); + comp.block = bb_orig; + SAFE_FREE (); } break; @@ -2570,15 +2561,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bnegate); { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ - gcc_jit_block *negate_inline_block = - gcc_jit_function_new_block (comp.func, "inline_negate"); - gcc_jit_block *negate_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall_negate"); + DECL_AND_SAFE_ALLOCA_BLOCK (negate_inline_block, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -2606,21 +2594,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.emacs_int_type, tos_as_num); - gcc_jit_block_add_assignment (negate_inline_block, + basic_block_t *bb_orig = comp.block; + + comp.block = negate_inline_block; + gcc_jit_block_add_assignment (negate_inline_block->gcc_bb, NULL, TOS, - emit_make_fixnum (negate_inline_block, - negate_inline_res)); - basic_block_t bb_orig = *comp.block; + emit_make_fixnum (negate_inline_res)); - comp.block->gcc_bb = negate_fcall_block; + comp.block = negate_fcall_block; EMIT_CALL_N_REF ("Fminus", 1); - *comp.block = bb_orig; - gcc_jit_block_end_with_jump (negate_inline_block, NULL, + gcc_jit_block_end_with_jump (negate_inline_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (negate_fcall_block, NULL, + gcc_jit_block_end_with_jump (negate_fcall_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); + comp.block = bb_orig; + SAFE_FREE (); } break; CASE (Bplus); @@ -2710,8 +2702,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Binteractive_p); /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (comp.block, - intern ("interactive-p"))); + PUSH_RVAL (emit_lisp_obj_from_ptr (intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); break; @@ -2745,7 +2736,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2753,7 +2744,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2762,7 +2753,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -2772,7 +2763,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -2803,8 +2794,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bsave_restriction); - args[0] = emit_lisp_obj_from_ptr (comp.block, - save_restriction_restore); + args[0] = emit_lisp_obj_from_ptr (save_restriction_restore); args[1] = emit_call ("save_restriction_save", comp.lisp_obj_type, 0, @@ -2815,7 +2805,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bcatch); /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (comp.block, eval_sub); + args[1] = emit_lisp_obj_from_ptr (eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -2932,7 +2922,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2941,7 +2931,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2951,7 +2941,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -2962,7 +2952,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -3029,7 +3019,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + emit_lisp_obj_from_ptr (vectorp[op]); PUSH_RVAL (c); break; } @@ -3051,6 +3041,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, exit: xfree (stack_base); xfree (bb_map); + SAFE_FREE (); return comp_res; } From b5b0e63bbc23a6584e5aaa49861a37b832a0def3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 10:11:39 +0200 Subject: [PATCH 0129/1452] fix setcar --- src/comp.c | 36 +++++++++++++++++++++++++++--------- test/src/comp-tests.el | 7 ++++++- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4973a517d6f..538169c0b2a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -657,7 +657,7 @@ emit_VECTORLIKEP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_CONSP (gcc_jit_rvalue *obj) { - emit_comment ("CONSP"); + emit_comment ("CONSP"); return emit_TAGGEDP (obj, Lisp_Cons); } @@ -928,11 +928,14 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) emit_lisp_obj_from_ptr (Qconsp), x }; - gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.check_type, - 3, - args); + gcc_jit_block_add_eval ( + comp.block->gcc_bb, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); } static gcc_jit_rvalue * @@ -1497,11 +1500,28 @@ define_setcar (void) comp.block = init_block; comp.func = comp.setcar; + /* CHECK_CONS (cell); */ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + /* CHECK_IMPURE (cell, XCONS (cell)); */ + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (cell), + emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + + gcc_jit_block_add_eval ( + init_block->gcc_bb, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_impure, + 2, + args)); + + /* XSETCAR (cell, newcar); */ emit_XSETCAR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_car)); + /* return newcar; */ gcc_jit_block_end_with_return (init_block->gcc_bb, NULL, gcc_jit_param_as_rvalue (new_car)); @@ -1600,9 +1620,7 @@ define_CHECK_IMPURE (void) comp.block = init_block; comp.func = comp.check_impure; - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ + emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ err_block, ok_block); gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8fd3ca2e197..47c61c82bdd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -284,7 +284,12 @@ (native-compile #'comp-tests-setcdr-f) (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (condition-case + err + (comp-tests-setcar-f 3 10) + (error err)) + '(wrong-type-argument consp 3)))) (defun comp-bubble-sort () "Run bubble sort." From dc963cf0c8a6f009bc3f2ddbb8224b57ded53339 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 10:42:13 +0200 Subject: [PATCH 0130/1452] inline setcdr support --- src/comp.c | 156 +++++++++++++++++++++++++++++------------ test/src/comp-tests.el | 5 ++ 2 files changed, 116 insertions(+), 45 deletions(-) diff --git a/src/comp.c b/src/comp.c index 538169c0b2a..f31be0426f1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -254,6 +254,7 @@ typedef struct { gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *setcar; + gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; basic_block_t *block; /* Current basic block */ @@ -918,6 +919,31 @@ emit_XCDR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_u_cdr); } +static gcc_jit_lvalue * +emit_lval_XCDR (gcc_jit_rvalue *c) +{ + emit_comment ("lval_XCDR"); + + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + static void emit_CHECK_CONS (gcc_jit_rvalue *x) { @@ -946,6 +972,14 @@ emit_car_addr (gcc_jit_rvalue *c) return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); } +static gcc_jit_rvalue * +emit_cdr_addr (gcc_jit_rvalue *c) +{ + emit_comment ("cdr_addr"); + + return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL); +} + static void emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { @@ -960,6 +994,20 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) n); } +static void +emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + emit_comment ("XSETCDR"); + + gcc_jit_block_add_assignment( + comp.block->gcc_bb, + NULL, + gcc_jit_rvalue_dereference ( + emit_cdr_addr (c), + NULL), + n); +} + static gcc_jit_rvalue * emit_PURE_P (gcc_jit_rvalue *ptr) { @@ -1471,62 +1519,73 @@ define_CAR_CDR (void) } static void -define_setcar (void) +define_setcar_setcdr (void) { USE_SAFE_ALLOCA; - gcc_jit_param *cell = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "cell"); - gcc_jit_param *new_car = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "new_car"); + char const *f_name[] = {"setcar", "setcdr"}; + char const *par_name[] = {"new_car", "new_cdr"}; - gcc_jit_param *param[] = { cell, new_car }; - comp.setcar = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "setcar", - 2, - param, - 0); + for (int i = 0; i < 2; i++) + { + gcc_jit_param *cell = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cell"); + gcc_jit_param *new_el = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + par_name[i]); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.setcar); - comp.block = init_block; - comp.func = comp.setcar; + gcc_jit_param *param[] = { cell, new_el }; - /* CHECK_CONS (cell); */ - emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; + *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + f_name[i], + 2, + param, + 0); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, *f_ref); + comp.func = *f_ref; + comp.block = init_block; - /* CHECK_IMPURE (cell, XCONS (cell)); */ - gcc_jit_rvalue *args[] = - { gcc_jit_param_as_rvalue (cell), - emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + /* CHECK_CONS (cell); */ + emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); - gcc_jit_block_add_eval ( - init_block->gcc_bb, - NULL, - gcc_jit_context_new_call (comp.ctxt, + /* CHECK_IMPURE (cell, XCONS (cell)); */ + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (cell), + emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + + gcc_jit_block_add_eval ( + init_block->gcc_bb, NULL, - comp.check_impure, - 2, - args)); + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_impure, + 2, + args)); - /* XSETCAR (cell, newcar); */ - emit_XSETCAR (gcc_jit_param_as_rvalue (cell), - gcc_jit_param_as_rvalue (new_car)); + /* XSETCDR (cell, newel); */ + if (!i) + emit_XSETCAR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); + else + emit_XSETCDR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); - /* return newcar; */ - gcc_jit_block_end_with_return (init_block->gcc_bb, - NULL, - gcc_jit_param_as_rvalue (new_car)); + /* return newel; */ + gcc_jit_block_end_with_return (init_block->gcc_bb, + NULL, + gcc_jit_param_as_rvalue (new_el)); + } SAFE_FREE (); } + /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void @@ -1942,7 +2001,7 @@ init_comp (int opt_level) define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); - define_setcar(); + define_setcar_setcdr(); } static void @@ -2885,7 +2944,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_N (setcdr, 2); + case Bsetcdr: + POP2; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcdr, + 2, args); + PUSH_RVAL (res); + break; CASE (Bcar_safe); EMIT_CALL_N ("CAR_SAFE", 1); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 47c61c82bdd..d2b8f56d36f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -289,6 +289,11 @@ err (comp-tests-setcar-f 3 10) (error err)) + '(wrong-type-argument consp 3))) + (should (equal (condition-case + err + (comp-tests-setcdr-f 3 10) + (error err)) '(wrong-type-argument consp 3)))) (defun comp-bubble-sort () From 7363e5c24c13c586615c41d92f3fbdf9c207accd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 11:05:02 +0200 Subject: [PATCH 0131/1452] rework emit_cond_jump --- src/comp.c | 53 ++++++++++++++++++++++++++--------------------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/src/comp.c b/src/comp.c index f31be0426f1..3f4c0d8aaa3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -465,11 +465,26 @@ INLINE static void emit_cond_jump (gcc_jit_rvalue *test, basic_block_t *then_target, basic_block_t *else_target) { - gcc_jit_block_end_with_conditional (comp.block->gcc_bb, + if (gcc_jit_rvalue_get_type (test) == comp.bool_type) + gcc_jit_block_end_with_conditional (comp.block->gcc_bb, NULL, test, then_target->gcc_bb, else_target->gcc_bb); + else + /* In case test is not bool we do a logical negation to obtain a bool as + result. */ + gcc_jit_block_end_with_conditional ( + comp.block->gcc_bb, + NULL, + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.bool_type, + test), + else_target->gcc_bb, + then_target->gcc_bb); + comp.block->terminated = true; } @@ -1402,9 +1417,7 @@ define_CHECK_TYPE (void) comp.block = init_block; comp.func = comp.check_type; - emit_cond_jump (emit_cast (comp.bool_type, ok), - ok_block, - not_ok_block); + emit_cond_jump (ok, ok_block, not_ok_block); gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); @@ -1470,10 +1483,7 @@ define_CAR_CDR (void) comp.block = init_block; comp.func = f; - emit_cond_jump (emit_cast (comp.bool_type, - emit_CONSP (c)), - is_cons_b, - not_a_cons_b); + emit_cond_jump (emit_CONSP (c), is_cons_b, not_a_cons_b); comp.block = is_cons_b; @@ -1491,9 +1501,7 @@ define_CAR_CDR (void) DECL_AND_SAFE_ALLOCA_BLOCK (is_nil_b, f); DECL_AND_SAFE_ALLOCA_BLOCK (not_nil_b, f); - emit_cond_jump (emit_NILP (c), - is_nil_b, - not_nil_b); + emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block->gcc_bb, @@ -1619,11 +1627,9 @@ define_PSEUDOVECTORP (void) comp.block = init_block; comp.func = comp.pseudovectorp; - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), - call_pseudovector_typep_b, - ret_false_b); + emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])), + call_pseudovector_typep_b, + ret_false_b); comp.block = ret_false_b; gcc_jit_block_end_with_return (ret_false_b->gcc_bb @@ -1680,8 +1686,8 @@ define_CHECK_IMPURE (void) comp.func = comp.check_impure; emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ - err_block, - ok_block); + err_block, + ok_block); gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); gcc_jit_rvalue *pure_write_error_arg = @@ -2356,15 +2362,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func, format_string ("push_h_val_%u", pushhandler_n)); - emit_cond_jump ( - /* This negation is just to have a bool. */ - gcc_jit_context_new_unary_op (comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_LOGICAL_NEGATE, - comp.bool_type, - res), - &bb_map[pc], - push_h_val_block); + + emit_cond_jump (res, push_h_val_block, &bb_map[pc]); gcc_jit_lvalue **stack_to_restore = stack; /* This emit the handler part. */ From 45c1b64ce68ea4416141d66af07bb24f4fda9930 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 12:07:32 +0200 Subject: [PATCH 0132/1452] pass orig lisp f name into compile_f --- src/comp.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3f4c0d8aaa3..fa5b6217169 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2023,8 +2023,8 @@ release_comp (void) } static comp_f_res_t -compile_f (const char *f_name, ptrdiff_t bytestr_length, - unsigned char *bytestr_data, +compile_f (const char *lisp_f_name, const char *c_f_name, + ptrdiff_t bytestr_length, unsigned char *bytestr_data, EMACS_INT stack_depth, Lisp_Object *vectorp, ptrdiff_t vector_size, Lisp_Object args_template) { @@ -2067,7 +2067,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. */ - comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + comp.func = emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); gcc_jit_lvalue *meta_stack_array = @@ -3157,8 +3157,8 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, sigset_t oldset; block_atimers (&oldset); - comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), - XFIXNAT (maxdepth) + 1, + comp_f_res_t comp_res = compile_f (lisp_f_name, c_f_name, bytestr_length, + SDATA (bytestr), XFIXNAT (maxdepth) + 1, vectorp, ASIZE (vector), AREF (func, COMPILED_ARGLIST)); From 0bdbd4a6012be487e440521e331c6dfc330c2197 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 13:30:49 +0200 Subject: [PATCH 0133/1452] introduce stack_el_t --- src/comp.c | 145 +++++++++++++++++++++++++++-------------------------- 1 file changed, 75 insertions(+), 70 deletions(-) diff --git a/src/comp.c b/src/comp.c index fa5b6217169..027090dc6ee 100644 --- a/src/comp.c +++ b/src/comp.c @@ -47,7 +47,7 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - *stack, \ + (stack)->gcc_lval, \ gcc_jit_lvalue_as_rvalue(obj)); \ stack++; \ } while (0) @@ -57,7 +57,7 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - *stack, \ + (stack)->gcc_lval, \ (obj)); \ stack++; \ } while (0) @@ -69,7 +69,7 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (prologue_bb, \ NULL, \ - *stack, \ + (stack)->gcc_lval, \ gcc_jit_param_as_rvalue(obj)); \ stack++; \ } while (0) @@ -80,31 +80,31 @@ along with GNU Emacs. If not, see . */ #define POP0 -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ +#define POP1 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ } while (0) -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ +#define POP2 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ } while (0) -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue (*stack); \ - stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ +#define POP3 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[2] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + stack--; \ + args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ } while (0) /* Fetch the next byte from the bytecode stream. */ @@ -146,11 +146,11 @@ along with GNU Emacs. If not, see . */ This is done by passing a reference to the first obj involved on the stack. */ -#define EMIT_CALL_N_REF(name, nargs) \ - do { \ - DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), *stack); \ - PUSH_RVAL (res); \ +#define EMIT_CALL_N_REF(name, nargs) \ + do { \ + DISCARD (nargs); \ + res = emit_call_n_ref ((name), (nargs), (stack)->gcc_lval); \ + PUSH_RVAL (res); \ } while (0) #define EMIT_ARITHCOMPARE(comparison) \ @@ -176,10 +176,15 @@ do { \ basic_block_t *(name); \ SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) +/* Element of the meta stack. */ +typedef struct { + gcc_jit_lvalue *gcc_lval; +} stack_el_t; + typedef struct { gcc_jit_block *gcc_bb; /* When non zero indicates a stack pointer restart. */ - gcc_jit_lvalue **top; + stack_el_t *top; bool terminated; } basic_block_t; @@ -298,14 +303,14 @@ bcall0 (Lisp_Object f) order. */ INLINE static void -pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) +pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) { - gcc_jit_lvalue **stack = *stack_ref; + stack_el_t *stack = *stack_ref; while (n--) { stack--; - args[n] = gcc_jit_lvalue_as_rvalue (*stack); + args[n] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); } *stack_ref = stack; @@ -2039,9 +2044,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ - gcc_jit_lvalue **stack_base, **stack, **stack_over; - stack_base = stack = - (gcc_jit_lvalue **) xmalloc (stack_depth * sizeof (gcc_jit_lvalue *)); + stack_el_t *stack_base, *stack, *stack_over; + SAFE_NALLOCA (stack_base, sizeof (stack_el_t), stack_depth); + stack = stack_base; stack_over = stack_base + stack_depth; if (FIXNUMP (args_template)) @@ -2081,13 +2086,13 @@ compile_f (const char *lisp_f_name, const char *c_f_name, "local"); for (int i = 0; i < stack_depth; ++i) - stack[i] = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); + stack[i].gcc_lval = gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); @@ -2132,15 +2137,16 @@ compile_f (const char *lisp_f_name, const char *c_f_name, goto stack_ref; CASE (Bstack_ref5); stack_ref: - PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + PUSH_LVAL ( + stack_base[(stack - stack_base) - (op - Bstack_ref) - 1].gcc_lval); break; CASE (Bstack_ref6); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1].gcc_lval); break; CASE (Bstack_ref7); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1].gcc_lval); break; CASE (Bvarref7); @@ -2262,7 +2268,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, { ptrdiff_t nargs = op + 1; DISCARD (nargs); - res = emit_call_n_ref ("Ffuncall", nargs, *stack); + res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); PUSH_RVAL (res); break; } @@ -2365,7 +2371,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, emit_cond_jump (res, push_h_val_block, &bb_map[pc]); - gcc_jit_lvalue **stack_to_restore = stack; + stack_el_t *stack_to_restore = stack; /* This emit the handler part. */ basic_block_t *bb_orig = comp.block; @@ -2384,10 +2390,10 @@ compile_f (const char *lisp_f_name, const char *c_f_name, NULL, comp.handler_next_field))); /* PUSH (c->val); */ - PUSH_LVAL ( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field)); + PUSH_LVAL (gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field)); bb_map[handler_pc].top = stack; comp.block = bb_orig; @@ -2501,7 +2507,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2510,7 +2516,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2532,7 +2538,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.block = sub1_inline_block; gcc_jit_block_add_assignment (sub1_inline_block->gcc_bb, NULL, - TOS, + TOS.gcc_lval, emit_make_fixnum (sub1_inline_res)); comp.block = sub1_fcall_block; @@ -2561,7 +2567,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2570,7 +2576,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2593,7 +2599,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_block_add_assignment (add1_inline_block->gcc_bb , NULL, - TOS, + TOS.gcc_lval, emit_make_fixnum (add1_inline_res)); comp.block = add1_fcall_block; POP1; @@ -2645,7 +2651,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2654,7 +2660,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2675,7 +2681,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.block = negate_inline_block; gcc_jit_block_add_assignment (negate_inline_block->gcc_bb, NULL, - TOS, + TOS.gcc_lval, emit_make_fixnum (negate_inline_res)); comp.block = negate_fcall_block; @@ -2827,7 +2833,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, CASE (Bgotoifnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -2837,7 +2843,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, CASE (Bgotoifnonnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -2857,7 +2863,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, break; CASE (Bdup); - PUSH_LVAL (TOS); + PUSH_LVAL (TOS.gcc_lval); break; CASE (Bsave_excursion); @@ -3022,7 +3028,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -3033,7 +3039,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -3052,7 +3058,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, if (op > 0) gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, - *(stack - op), + (*(stack - op)).gcc_lval, args[0]); break; @@ -3061,7 +3067,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, POP1; gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, - *(stack - op), + (*(stack - op)).gcc_lval, args[0]); break; @@ -3073,7 +3079,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, POP1; gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, - *(stack - op - 1), + (*(stack - op - 1)).gcc_lval, args[0]); } @@ -3122,7 +3128,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, error ("Something went wrong"); exit: - xfree (stack_base); xfree (bb_map); SAFE_FREE (); return comp_res; From 5c47cb9600de25a1e8e8e975795480044b866042 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 14:35:41 +0200 Subject: [PATCH 0134/1452] propagate contant types and optimize self calls --- src/comp.c | 50 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 38 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 027090dc6ee..491fcefe454 100644 --- a/src/comp.c +++ b/src/comp.c @@ -47,8 +47,10 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - (stack)->gcc_lval, \ + stack->gcc_lval, \ gcc_jit_lvalue_as_rvalue(obj)); \ + stack->type = -1; \ + stack->sym_val = NULL; \ stack++; \ } while (0) @@ -57,8 +59,10 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - (stack)->gcc_lval, \ + stack->gcc_lval, \ (obj)); \ + stack->type = -1; \ + stack->sym_val = NULL; \ stack++; \ } while (0) @@ -69,8 +73,10 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (prologue_bb, \ NULL, \ - (stack)->gcc_lval, \ + stack->gcc_lval, \ gcc_jit_param_as_rvalue(obj)); \ + stack->type = -1; \ + stack->sym_val = NULL; \ stack++; \ } while (0) @@ -84,27 +90,27 @@ along with GNU Emacs. If not, see . */ do { \ stack--; \ CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ } while (0) #define POP2 \ do { \ stack--; \ CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ } while (0) #define POP3 \ do { \ stack--; \ CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[2] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ } while (0) /* Fetch the next byte from the bytecode stream. */ @@ -149,7 +155,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_CALL_N_REF(name, nargs) \ do { \ DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), (stack)->gcc_lval); \ + res = emit_call_n_ref ((name), (nargs), stack->gcc_lval); \ PUSH_RVAL (res); \ } while (0) @@ -179,6 +185,8 @@ do { \ /* Element of the meta stack. */ typedef struct { gcc_jit_lvalue *gcc_lval; + enum Lisp_Type type; /* -1 if not set. */ + char *sym_val; } stack_el_t; typedef struct { @@ -2267,8 +2275,21 @@ compile_f (const char *lisp_f_name, const char *c_f_name, docall: { ptrdiff_t nargs = op + 1; - DISCARD (nargs); - res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + pop (nargs, &stack, args); + if (stack->type == Lisp_Symbol && + !strcmp (stack->sym_val, lisp_f_name)) + { + /* Optimize self calls. */ + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.func, + nargs - 1, + args + 1); + } + else + { + res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + } PUSH_RVAL (res); break; } @@ -3110,6 +3131,11 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_rvalue *c = emit_lisp_obj_from_ptr (vectorp[op]); PUSH_RVAL (c); + TOS.type = XTYPE (vectorp[op]); + if (TOS.type == Lisp_Symbol) + /* Store the symbol value for later use is used while + optimizing native and self calls. */ + TOS.sym_val = (char *) SDATA (SYMBOL_NAME (vectorp[op])); break; } From 9e71843f6301cff6e3f0d06e46c47bc5a5c7b177 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 16:10:17 +0200 Subject: [PATCH 0135/1452] optimize primitve native call --- src/comp.c | 77 ++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 58 insertions(+), 19 deletions(-) diff --git a/src/comp.c b/src/comp.c index 491fcefe454..73a76ea8911 100644 --- a/src/comp.c +++ b/src/comp.c @@ -50,7 +50,7 @@ along with GNU Emacs. If not, see . */ stack->gcc_lval, \ gcc_jit_lvalue_as_rvalue(obj)); \ stack->type = -1; \ - stack->sym_val = NULL; \ + stack->const_set = false; \ stack++; \ } while (0) @@ -62,7 +62,7 @@ along with GNU Emacs. If not, see . */ stack->gcc_lval, \ (obj)); \ stack->type = -1; \ - stack->sym_val = NULL; \ + stack->const_set = false; \ stack++; \ } while (0) @@ -76,7 +76,7 @@ along with GNU Emacs. If not, see . */ stack->gcc_lval, \ gcc_jit_param_as_rvalue(obj)); \ stack->type = -1; \ - stack->sym_val = NULL; \ + stack->const_set = false; \ stack++; \ } while (0) @@ -186,7 +186,8 @@ do { \ typedef struct { gcc_jit_lvalue *gcc_lval; enum Lisp_Type type; /* -1 if not set. */ - char *sym_val; + Lisp_Object constant; /* This is used for constant propagation. */ + bool const_set; } stack_el_t; typedef struct { @@ -2274,22 +2275,57 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op -= Bcall; docall: { + res = NULL; ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - if (stack->type == Lisp_Symbol && - !strcmp (stack->sym_val, lisp_f_name)) + if (stack->const_set && + stack->type == Lisp_Symbol) { - /* Optimize self calls. */ - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - nargs - 1, - args + 1); - } - else - { - res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + ptrdiff_t native_nargs = nargs - 1; + char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); + if (!strcmp (sym_name, + lisp_f_name)) + { + /* Optimize self calls. */ + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.func, + native_nargs, + args + 1); + } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) + { + /* Optimize primitive native calls. */ + emit_comment (format_string ("Calling primitive %s", + sym_name)); + struct Lisp_Subr *subr = + XSUBR ((XSYMBOL (stack->constant)->u.s.function)); + gcc_jit_type *types[native_nargs]; + + for (int i = 0; i < native_nargs; i++) + types[i] = comp.lisp_obj_type; + + gcc_jit_type *fn_ptr_type = + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + native_nargs, + types, + 0); + res = + gcc_jit_context_new_call_through_ptr ( + comp.ctxt, + NULL, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + fn_ptr_type, + subr->function.a0), + native_nargs, + args + 1); + } } + /* Fall back to regular funcall dispatch. */ + if (!res) + res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + PUSH_RVAL (res); break; } @@ -3133,9 +3169,12 @@ compile_f (const char *lisp_f_name, const char *c_f_name, PUSH_RVAL (c); TOS.type = XTYPE (vectorp[op]); if (TOS.type == Lisp_Symbol) - /* Store the symbol value for later use is used while - optimizing native and self calls. */ - TOS.sym_val = (char *) SDATA (SYMBOL_NAME (vectorp[op])); + { + /* Store the symbol value for later use is used while + optimizing native and self calls. */ + TOS.constant = vectorp[op]; + TOS.const_set = true; + } break; } From c4b003f3c8d4a7e508b3f8d72e46829735ffbcbd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 17:23:14 +0200 Subject: [PATCH 0136/1452] add emit_assign_to_stack_slot --- src/comp.c | 133 ++++++++++++++++++++++++----------------------------- 1 file changed, 61 insertions(+), 72 deletions(-) diff --git a/src/comp.c b/src/comp.c index 73a76ea8911..3cd1c3c8dbb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -42,42 +42,31 @@ along with GNU Emacs. If not, see . */ #define CHECK_STACK \ eassert (stack >= stack_base && stack < stack_over) -#define PUSH_LVAL(obj) \ - do { \ - CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.block->gcc_bb, \ - NULL, \ - stack->gcc_lval, \ - gcc_jit_lvalue_as_rvalue(obj)); \ - stack->type = -1; \ - stack->const_set = false; \ - stack++; \ +#define PUSH_LVAL(obj) \ + do { \ + CHECK_STACK; \ + emit_assign_to_stack_slot (comp.block, \ + stack, \ + gcc_jit_lvalue_as_rvalue (obj)); \ + stack++; \ } while (0) -#define PUSH_RVAL(obj) \ - do { \ - CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.block->gcc_bb, \ - NULL, \ - stack->gcc_lval, \ - (obj)); \ - stack->type = -1; \ - stack->const_set = false; \ - stack++; \ +#define PUSH_RVAL(obj) \ + do { \ + CHECK_STACK; \ + emit_assign_to_stack_slot (comp.block, stack, (obj)); \ + stack++; \ } while (0) /* This always happens in the first basic block. */ -#define PUSH_PARAM(obj) \ - do { \ - CHECK_STACK; \ - gcc_jit_block_add_assignment (prologue_bb, \ - NULL, \ - stack->gcc_lval, \ - gcc_jit_param_as_rvalue(obj)); \ - stack->type = -1; \ - stack->const_set = false; \ - stack++; \ +#define PUSH_PARAM(obj) \ + do { \ + CHECK_STACK; \ + emit_assign_to_stack_slot (prologue, \ + stack, \ + gcc_jit_param_as_rvalue (obj)); \ + stack++; \ } while (0) #define TOS (*(stack - 1)) @@ -127,8 +116,8 @@ along with GNU Emacs. If not, see . */ /* With most of the ops we need to do the same stuff so this macros are meant to save some typing. */ -#define CASE(op) \ - case op : \ +#define CASE(op) \ + case op : \ emit_comment (STR(op)) /* Pop from the meta-stack, emit the call and push the result */ @@ -367,6 +356,23 @@ emit_comment (const char *str) str); } + +/* Assignments to the meta-stack slots should be emitted usign this to always */ +/* reset annotation fields. */ + +static void +emit_assign_to_stack_slot(basic_block_t *block, stack_el_t *slot, + gcc_jit_rvalue *val) +{ + gcc_jit_block_add_assignment (block->gcc_bb, + NULL, + slot->gcc_lval, + val); + slot->type = -1; + slot->const_set = false; +} + + static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, @@ -2103,14 +2109,13 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.int_type, i)); - gcc_jit_block *prologue_bb = - gcc_jit_function_new_block (comp.func, "prologue"); + DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); + gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); comp.block = &bb_map[0]; gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); @@ -2322,7 +2327,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, args + 1); } } - /* Fall back to regular funcall dispatch. */ + /* Fall back to regular funcall dispatch mechanism. */ if (!res) res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); @@ -2438,14 +2443,14 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_rvalue_dereference_field (comp.current_thread, NULL, comp.m_handlerlist); - gcc_jit_block_add_assignment(comp.block->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); + gcc_jit_block_add_assignment (comp.block->gcc_bb, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); /* PUSH (c->val); */ PUSH_LVAL (gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (c), @@ -2593,11 +2598,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, basic_block_t *bb_orig = comp.block; comp.block = sub1_inline_block; - gcc_jit_block_add_assignment (sub1_inline_block->gcc_bb, - NULL, - TOS.gcc_lval, - emit_make_fixnum (sub1_inline_res)); - + emit_assign_to_stack_slot (sub1_inline_block, + &TOS, + emit_make_fixnum (sub1_inline_res)); comp.block = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); @@ -2652,12 +2655,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, basic_block_t *bb_orig = comp.block; comp.block = add1_inline_block; - - gcc_jit_block_add_assignment (add1_inline_block->gcc_bb - , - NULL, - TOS.gcc_lval, - emit_make_fixnum (add1_inline_res)); + emit_assign_to_stack_slot(add1_inline_block, + &TOS, + emit_make_fixnum (add1_inline_res)); comp.block = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); @@ -2736,11 +2736,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, basic_block_t *bb_orig = comp.block; comp.block = negate_inline_block; - gcc_jit_block_add_assignment (negate_inline_block->gcc_bb, - NULL, - TOS.gcc_lval, - emit_make_fixnum (negate_inline_res)); - + emit_assign_to_stack_slot (negate_inline_block, + &TOS, + emit_make_fixnum (negate_inline_res)); comp.block = negate_fcall_block; EMIT_CALL_N_REF ("Fminus", 1); @@ -3113,19 +3111,13 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op = FETCH; POP1; if (op > 0) - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - (*(stack - op)).gcc_lval, - args[0]); + emit_assign_to_stack_slot (comp.block, stack - op, args[0]); break; CASE (Bstack_set2); op = FETCH2; POP1; - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - (*(stack - op)).gcc_lval, - args[0]); + emit_assign_to_stack_slot (comp.block, stack - op, args[0]); break; CASE (BdiscardN); @@ -3134,10 +3126,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, { op &= 0x7F; POP1; - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - (*(stack - op - 1)).gcc_lval, - args[0]); + emit_assign_to_stack_slot (comp.block, stack - op - 1, args[0]); } DISCARD (op); From aa312e07b7a9d3e952ccb59abfe9e03dc977217e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 17:42:30 +0200 Subject: [PATCH 0137/1452] add primitve call test --- test/src/comp-tests.el | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d2b8f56d36f..125af64b569 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -153,15 +153,25 @@ (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) (ert-deftest comp-tests-ffuncall () - "Testing varset." + "Test calling conventions." (defun comp-tests-ffuncall-callee-f (x y z) (list x y z)) (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) + (byte-compile #'comp-tests-ffuncall-caller-f) (native-compile #'comp-tests-ffuncall-caller-f) - (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))) + (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + (defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) + + (byte-compile #'comp-tests-ffuncall-native-f) + (native-compile #'comp-tests-ffuncall-native-f) + + (should (vectorp (comp-tests-ffuncall-native-f)))) (ert-deftest comp-tests-conditionals () "Testing conditionals." From edb0acf2aec0f41832f7ef7d8199ddedb2c3e9d7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 17:59:04 +0200 Subject: [PATCH 0138/1452] fix missing bubble sort test --- test/src/comp-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 125af64b569..afb2a663c0b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -306,7 +306,7 @@ (error err)) '(wrong-type-argument consp 3)))) -(defun comp-bubble-sort () +(ert-deftest comp-tests-bubble-sort () "Run bubble sort." (defun comp-bubble-sort-f (list) (let ((i (length list))) From 3fd19aecee00d8ac1b001ed7aebf9c4ff4f36001 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 20:53:59 +0200 Subject: [PATCH 0139/1452] fix native call to MANY func --- src/comp.c | 50 +++++++++++++++++++++++++----------------- test/src/comp-tests.el | 10 ++++++++- 2 files changed, 39 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3cd1c3c8dbb..d86bd1eb0c1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2286,7 +2286,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, if (stack->const_set && stack->type == Lisp_Symbol) { - ptrdiff_t native_nargs = nargs - 1; + ptrdiff_t native_nargs = op; char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); if (!strcmp (sym_name, lisp_f_name)) @@ -2304,29 +2304,39 @@ compile_f (const char *lisp_f_name, const char *c_f_name, sym_name)); struct Lisp_Subr *subr = XSUBR ((XSYMBOL (stack->constant)->u.s.function)); - gcc_jit_type *types[native_nargs]; + if (subr->max_args == MANY) + { + /* FIXME: do we want to optimize this case too? */ + goto dofuncall; + } else + { + gcc_jit_type *types[native_nargs]; - for (int i = 0; i < native_nargs; i++) - types[i] = comp.lisp_obj_type; + for (int i = 0; i < native_nargs; i++) + types[i] = comp.lisp_obj_type; - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - native_nargs, - types, - 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - fn_ptr_type, - subr->function.a0), - native_nargs, - args + 1); + gcc_jit_type *fn_ptr_type = + gcc_jit_context_new_function_ptr_type ( + comp.ctxt, + NULL, + comp.lisp_obj_type, + native_nargs, + types, + 0); + res = + gcc_jit_context_new_call_through_ptr ( + comp.ctxt, + NULL, + gcc_jit_context_new_rvalue_from_ptr ( + comp.ctxt, + fn_ptr_type, + subr->function.a0), + native_nargs, + args + 1); + } } } + dofuncall: /* Fall back to regular funcall dispatch mechanism. */ if (!res) res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index afb2a663c0b..42e10ba5114 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -171,7 +171,15 @@ (byte-compile #'comp-tests-ffuncall-native-f) (native-compile #'comp-tests-ffuncall-native-f) - (should (vectorp (comp-tests-ffuncall-native-f)))) + (should (vectorp (comp-tests-ffuncall-native-f))) + + (defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) + + (byte-compile #'comp-tests-ffuncall-apply-many-f) + (native-compile #'comp-tests-ffuncall-apply-many-f) + + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3)))) (ert-deftest comp-tests-conditionals () "Testing conditionals." From fac313889774e5e4867788d6f2c58595e8e1604b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Jun 2019 21:01:28 +0200 Subject: [PATCH 0140/1452] add comp-tests-ffuncall-lambda-f test --- test/src/comp-tests.el | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 42e10ba5114..7bd4ddf01ca 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -179,7 +179,17 @@ (byte-compile #'comp-tests-ffuncall-apply-many-f) (native-compile #'comp-tests-ffuncall-apply-many-f) - (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3)))) + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + + (defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) + + (byte-compile #'comp-tests-ffuncall-lambda-f) + (native-compile #'comp-tests-ffuncall-lambda-f) + + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) (ert-deftest comp-tests-conditionals () "Testing conditionals." From 4311d6e04a3131273197d58cedacd150b35c691a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 1 Jul 2019 21:27:52 +0200 Subject: [PATCH 0141/1452] introduce MAX_POP --- src/comp.c | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index d86bd1eb0c1..4d121dc7e66 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,6 +37,10 @@ along with GNU Emacs. If not, see . */ #define MAX_FUN_NAME 256 +/* Max number of entries of the meta-stack that can get poped. */ + +#define MAX_POP 64 + #define DISASS_FILE_NAME "emacs-asm.s" #define CHECK_STACK \ @@ -303,6 +307,7 @@ bcall0 (Lisp_Object f) INLINE static void pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) { + eassert (n <= MAX_POP); /* FIXME? */ stack_el_t *stack = *stack_ref; while (n--) @@ -2051,7 +2056,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_rvalue *res; comp_f_res_t comp_res = { NULL, 0, 0 }; ptrdiff_t pc = 0; - gcc_jit_rvalue *args[4]; + gcc_jit_rvalue *args[MAX_POP]; unsigned op; unsigned pushhandler_n = 0; @@ -3297,9 +3302,9 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, opt_level = XFIXNUM (speed); emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, - disassemble != Qnil); + !NILP (disassemble)); - if (disassemble) + if (!NILP (disassemble)) { FILE *fd; Lisp_Object str; From 481062f42e25ea2483593f112794c737698d3d6b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 1 Jul 2019 22:30:08 +0200 Subject: [PATCH 0142/1452] introduce parsearg --- src/comp.c | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4d121dc7e66..62ce25f63e3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2053,14 +2053,15 @@ compile_f (const char *lisp_f_name, const char *c_f_name, EMACS_INT stack_depth, Lisp_Object *vectorp, ptrdiff_t vector_size, Lisp_Object args_template) { + USE_SAFE_ALLOCA; gcc_jit_rvalue *res; comp_f_res_t comp_res = { NULL, 0, 0 }; ptrdiff_t pc = 0; gcc_jit_rvalue *args[MAX_POP]; unsigned op; - unsigned pushhandler_n = 0; - - USE_SAFE_ALLOCA; + unsigned pushhandler_n = 0; + comp_res.min_args = 0; + comp_res.max_args = MANY; /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ @@ -2069,6 +2070,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, stack = stack_base; stack_over = stack_base + stack_depth; + bool parse_args = true; if (FIXNUMP (args_template)) { ptrdiff_t at = XFIXNUM (args_template); @@ -2081,19 +2083,16 @@ compile_f (const char *lisp_f_name, const char *c_f_name, eassert (!rest); if (!rest && nonrest < SUBR_MAX_ARGS) - comp_res.max_args = nonrest; + { + comp_res.max_args = nonrest; + parse_args = false; + } } - else if (CONSP (args_template)) - /* FIXME */ - comp_res.min_args = comp_res.max_args = XFIXNUM (Flength (args_template)); - else - eassert (SYMBOLP (args_template) && args_template == Qnil); - - - /* Current function being compiled. */ - comp.func = emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); + eassert (!parse_args); + comp.func = + emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, NULL, + GCC_JIT_FUNCTION_EXPORTED, false); gcc_jit_lvalue *meta_stack_array = gcc_jit_function_new_local ( From 0dc882ee2e7e5595f7acfe727975682543354786 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Jul 2019 00:04:03 +0200 Subject: [PATCH 0143/1452] add &rest decription --- src/comp.c | 146 +++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 131 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index 62ce25f63e3..970019abe8b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -377,6 +377,8 @@ emit_assign_to_stack_slot(basic_block_t *block, stack_el_t *slot, slot->const_set = false; } +/* Declare a function with all args being Lisp_Object and returning a + Lisp_Object. */ static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, @@ -1657,8 +1659,7 @@ define_PSEUDOVECTORP (void) ret_false_b); comp.block = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b->gcc_bb - , + gcc_jit_block_end_with_return (ret_false_b->gcc_bb, NULL, gcc_jit_context_new_rvalue_from_int( comp.ctxt, @@ -2089,10 +2090,34 @@ compile_f (const char *lisp_f_name, const char *c_f_name, } } - eassert (!parse_args); - comp.func = - emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, NULL, - GCC_JIT_FUNCTION_EXPORTED, false); + if (!parse_args) + { + comp.func = + emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); + } + else + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + comp.func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_f_name, + 2, + param, + 0); + } + gcc_jit_lvalue *meta_stack_array = gcc_jit_function_new_local ( @@ -2106,20 +2131,111 @@ compile_f (const char *lisp_f_name, const char *c_f_name, for (int i = 0; i < stack_depth; ++i) stack[i].gcc_lval = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); - for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); + if (!parse_args) + { + for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) + PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + + gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); + } + else + { + /* + nargs will be known at runtime therfore we emit: + + prologue: + i = 0; + push_nargs_check: + if (i < nargs) goto push_args; else goto bb1; + push_nargs: + local[i] = *(args + sizeof (Lisp_Object) * i); + i = i + 1; + goto push_nargs_check; + bb_1: + . + . + . + */ + DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs_check, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs, comp.func); + + gcc_jit_lvalue *i = gcc_jit_function_new_local (comp.func, + NULL, + comp.ptrdiff_type, + "i"); + gcc_jit_block_add_assignment ( + prologue->gcc_bb, + NULL, + i, + gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + 0)); + + gcc_jit_block_end_with_jump (prologue->gcc_bb, + NULL, + push_nargs_check->gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_LE, + gcc_jit_lvalue_as_rvalue (i), + gcc_jit_param_as_rvalue ( + gcc_jit_function_get_param (comp.func, 0)), /* nargs */ + push_nargs, &bb_map[0]); + gcc_jit_lvalue *arg = + gcc_jit_rvalue_dereference ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.ptrdiff_type, + gcc_jit_param_as_rvalue ( + gcc_jit_function_get_param (comp.func, 1)), /* args */ + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.ptrdiff_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + sizeof (Lisp_Object)), + gcc_jit_lvalue_as_rvalue (i))), + NULL); + + /* FIXME check side stack values */ + gcc_jit_block_add_assignment ( + push_nargs->gcc_bb, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_lvalue_as_rvalue (i)), + gcc_jit_lvalue_as_rvalue (arg)); + + gcc_jit_block_add_assignment ( + push_nargs->gcc_bb, + NULL, + i, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (i), + comp.one)); + + gcc_jit_block_end_with_jump (push_nargs->gcc_bb, + NULL, + push_nargs_check->gcc_bb); + } comp.block = &bb_map[0]; gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); From 8c28758b43e16e68d3162b77c632744a6bad3617 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Jul 2019 22:46:23 +0200 Subject: [PATCH 0144/1452] extend cast capabilities --- src/comp.c | 38 +++++++++++++++++++++++++++++++++++--- 1 file changed, 35 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 970019abe8b..301ff83c8e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -246,10 +246,13 @@ typedef struct { gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; + gcc_jit_field *cast_union_as_uintptr; + gcc_jit_field *cast_union_as_ptrdiff; gcc_jit_field *cast_union_as_c_p; gcc_jit_field *cast_union_as_v_p; gcc_jit_field *cast_union_as_lisp_cons_ptr; gcc_jit_field *cast_union_as_lisp_obj; + gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -340,12 +343,18 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_b; else if (type == comp.void_ptr_type) field = comp.cast_union_as_v_p; + else if (type == comp.uintptr_type) + field = comp.cast_union_as_uintptr; + else if (type == comp.ptrdiff_type) + field = comp.cast_union_as_ptrdiff; else if (type == comp.char_ptr_type) field = comp.cast_union_as_c_p; else if (type == comp.lisp_cons_ptr_type) field = comp.cast_union_as_lisp_cons_ptr; else if (type == comp.lisp_obj_type) field = comp.cast_union_as_lisp_obj; + else if (type == comp.lisp_obj_ptr_type) + field = comp.cast_union_as_lisp_obj_ptr; else error ("unsupported cast\n"); @@ -366,8 +375,8 @@ emit_comment (const char *str) /* reset annotation fields. */ static void -emit_assign_to_stack_slot(basic_block_t *block, stack_el_t *slot, - gcc_jit_rvalue *val) +emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, + gcc_jit_rvalue *val) { gcc_jit_block_add_assignment (block->gcc_bb, NULL, @@ -1366,6 +1375,16 @@ define_cast_union (void) NULL, comp.bool_type, "b"); + comp.cast_union_as_uintptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.uintptr_type, + "uintptr"); + comp.cast_union_as_ptrdiff = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "ptrdiff"); comp.cast_union_as_c_p = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1386,6 +1405,12 @@ define_cast_union (void) NULL, comp.lisp_obj_type, "lisp_obj"); + comp.cast_union_as_lisp_obj_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "lisp_obj_ptr"); + gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, @@ -1395,10 +1420,13 @@ define_cast_union (void) comp.cast_union_as_u, comp.cast_union_as_i, comp.cast_union_as_b, + comp.cast_union_as_uintptr, + comp.cast_union_as_ptrdiff, comp.cast_union_as_c_p, comp.cast_union_as_v_p, comp.cast_union_as_lisp_cons_ptr, - comp.cast_union_as_lisp_obj}; + comp.cast_union_as_lisp_obj, + comp.cast_union_as_lisp_obj_ptr }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, @@ -2170,6 +2198,10 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs_check, comp.func); DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs, comp.func); + gcc_jit_rvalue *nargs = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_rvalue *args = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 1)); gcc_jit_lvalue *i = gcc_jit_function_new_local (comp.func, NULL, comp.ptrdiff_type, From 193688f2fc34c03a32b1e013d74fd6e5fac845c7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Jul 2019 23:14:36 +0200 Subject: [PATCH 0145/1452] add emit_ptr_arithmetic --- src/comp.c | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/src/comp.c b/src/comp.c index 301ff83c8e6..a9b46fc8605 100644 --- a/src/comp.c +++ b/src/comp.c @@ -567,6 +567,41 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) dest_field); } +/* + Emit the equivalent of + ptr[i] + ptr + size_of_ptr_ref * i +*/ + +static gcc_jit_rvalue * +emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, + int size_of_ptr_ref, gcc_jit_rvalue *i) +{ + emit_comment ("ptr_arithmetic"); + + gcc_jit_rvalue *offset = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.uintptr_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + size_of_ptr_ref), + emit_cast (comp.uintptr_type, i)); + + return + emit_cast ( + ptr_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + offset)); +} + INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { From 36c9295e41404f1f90a8500d46d79b0e2a53af1e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Jul 2019 23:15:11 +0200 Subject: [PATCH 0146/1452] basic &rest working --- src/comp.c | 177 +++++++++++++---------------------------- test/src/comp-tests.el | 18 +++++ 2 files changed, 73 insertions(+), 122 deletions(-) diff --git a/src/comp.c b/src/comp.c index a9b46fc8605..eefe8db2e2c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -394,53 +394,23 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { - gcc_jit_param *param[4]; - gcc_jit_type *type[4]; + gcc_jit_param *param[nargs]; + gcc_jit_type *type[nargs]; /* If args are passed types are extracted from that otherwise assume params */ /* are all lisp objs. */ if (args) - for (int i = 0; i < nargs; i++) + for (unsigned i = 0; i < nargs; i++) type[i] = gcc_jit_rvalue_get_type (args[i]); else - for (int i = 0; i < nargs; i++) + for (unsigned i = 0; i < nargs; i++) type[i] = comp.lisp_obj_type; - switch (nargs) { - case 4: - param[3] = gcc_jit_context_new_param(comp.ctxt, + for (int i = nargs - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param(comp.ctxt, NULL, - type[3], - "c"); - /* Fall through */ - FALLTHROUGH; - case 3: - param[2] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[2], - "c"); - /* Fall through */ - FALLTHROUGH; - case 2: - param[1] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[1], - "b"); - /* Fall through */ - FALLTHROUGH; - case 1: - param[0] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[0], - "a"); - /* Fall through */ - FALLTHROUGH; - case 0: - break; - default: - /* Argnum not supported */ - eassert (0); - } + type[i], + format_string ("par_%d", i)); gcc_jit_function *func = gcc_jit_context_new_function(comp.ctxt, NULL, @@ -569,8 +539,8 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) /* Emit the equivalent of - ptr[i] - ptr + size_of_ptr_ref * i + + (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ static gcc_jit_rvalue * @@ -2144,8 +2114,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp_res.min_args = mandatory; - eassert (!rest); - if (!rest && nonrest < SUBR_MAX_ARGS) { comp_res.max_args = nonrest; @@ -2179,7 +2147,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, 2, param, 0); - } + } gcc_jit_lvalue *meta_stack_array = @@ -2202,6 +2170,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, i)); DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); + comp.block = prologue; basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); @@ -2209,8 +2178,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, { for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); } else { @@ -2218,92 +2185,58 @@ compile_f (const char *lisp_f_name, const char *c_f_name, nargs will be known at runtime therfore we emit: prologue: - i = 0; - push_nargs_check: - if (i < nargs) goto push_args; else goto bb1; - push_nargs: - local[i] = *(args + sizeof (Lisp_Object) * i); - i = i + 1; - goto push_nargs_check; + local[0] = *args; + ++args; + . + . + . + local[min_args - 1] = *args; + ++args; + local[min_args] = list (nargs - min_args, args); bb_1: . . . */ - DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs_check, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs, comp.func); + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + gcc_jit_rvalue *min_args = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + comp_res.min_args); - gcc_jit_rvalue *nargs = - gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_rvalue *args = - gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_lvalue *i = gcc_jit_function_new_local (comp.func, - NULL, - comp.ptrdiff_type, - "i"); - gcc_jit_block_add_assignment ( - prologue->gcc_bb, - NULL, - i, - gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - 0)); + for (ptrdiff_t i = 0; i < comp_res.min_args; ++i) + { + PUSH_LVAL (gcc_jit_rvalue_dereference ( + gcc_jit_lvalue_as_rvalue (args), + NULL)); + gcc_jit_block_add_assignment (prologue->gcc_bb, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); + } - gcc_jit_block_end_with_jump (prologue->gcc_bb, - NULL, - push_nargs_check->gcc_bb); - emit_comparison_jump (GCC_JIT_COMPARISON_LE, - gcc_jit_lvalue_as_rvalue (i), - gcc_jit_param_as_rvalue ( - gcc_jit_function_get_param (comp.func, 0)), /* nargs */ - push_nargs, &bb_map[0]); - gcc_jit_lvalue *arg = - gcc_jit_rvalue_dereference ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.ptrdiff_type, - gcc_jit_param_as_rvalue ( - gcc_jit_function_get_param (comp.func, 1)), /* args */ - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MULT, - comp.ptrdiff_type, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - sizeof (Lisp_Object)), - gcc_jit_lvalue_as_rvalue (i))), - NULL); + /* + rest arguments + */ + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + min_args), + gcc_jit_lvalue_as_rvalue (args) }; - /* FIXME check side stack values */ - gcc_jit_block_add_assignment ( - push_nargs->gcc_bb, - NULL, - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_lvalue_as_rvalue (i)), - gcc_jit_lvalue_as_rvalue (arg)); - - gcc_jit_block_add_assignment ( - push_nargs->gcc_bb, - NULL, - i, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (i), - comp.one)); - - gcc_jit_block_end_with_jump (push_nargs->gcc_bb, - NULL, - push_nargs_check->gcc_bb); + PUSH_RVAL (emit_call ("Flist", comp.lisp_obj_type, 2, list_args)); } - + gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); comp.block = &bb_map[0]; gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 7bd4ddf01ca..ef8e57c40c1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -164,6 +164,24 @@ (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + (byte-compile #'comp-tests-ffuncall-callee-optional-f) + (native-compile #'comp-tests-ffuncall-callee-optional-f) + + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + + (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + (byte-compile #'comp-tests-ffuncall-callee-rest-f) + (native-compile #'comp-tests-ffuncall-callee-rest-f) + + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." (make-vector 1 nil)) From 4992fba7c56a4e7de8af4e79305883b505a84da4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jul 2019 09:27:45 +0200 Subject: [PATCH 0147/1452] rework COMP_DEBUG strategy --- src/comp.c | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index eefe8db2e2c..0fadeaad11c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1930,6 +1930,12 @@ init_comp (int opt_level) comp.ctxt = gcc_jit_context_acquire(); if (COMP_DEBUG) + { + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + } + if (COMP_DEBUG > 1) { logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, @@ -1938,16 +1944,9 @@ init_comp (int opt_level) gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, 1); - } - if (COMP_DEBUG > 1) - { gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DEBUGINFO, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, 1); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_INITIAL_GIMPLE, - 1); - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); } @@ -2072,8 +2071,6 @@ init_comp (int opt_level) static void release_comp (void) { - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); if (comp.ctxt) gcc_jit_context_release(comp.ctxt); @@ -3304,6 +3301,8 @@ compile_f (const char *lisp_f_name, const char *c_f_name, } } + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); goto exit; @@ -3363,9 +3362,9 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, if (dump_asm) { - gcc_jit_context_compile_to_file(comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - DISASS_FILE_NAME); + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_ASSEMBLER, + DISASS_FILE_NAME); } unblock_atimers (&oldset); release_comp (); From 98b500a0a21b486a98bf4e1ae989fd38616164bc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jul 2019 11:02:52 +0200 Subject: [PATCH 0148/1452] optimize outgoing native manyarg calls --- src/comp.c | 46 +++++++++++++++++++++++++++++++----------- test/src/comp-tests.el | 11 +++++++++- 2 files changed, 44 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0fadeaad11c..d705b5fa70f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2398,12 +2398,10 @@ compile_f (const char *lisp_f_name, const char *c_f_name, docall: { res = NULL; - ptrdiff_t nargs = op + 1; - pop (nargs, &stack, args); + pop (op + 1, &stack, args); if (stack->const_set && stack->type == Lisp_Symbol) { - ptrdiff_t native_nargs = op; char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); if (!strcmp (sym_name, lisp_f_name)) @@ -2412,24 +2410,49 @@ compile_f (const char *lisp_f_name, const char *c_f_name, res = gcc_jit_context_new_call (comp.ctxt, NULL, comp.func, - native_nargs, + op, args + 1); } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) { /* Optimize primitive native calls. */ emit_comment (format_string ("Calling primitive %s", sym_name)); + /* FIXME we really should check is a primitive too!! */ struct Lisp_Subr *subr = XSUBR ((XSYMBOL (stack->constant)->u.s.function)); if (subr->max_args == MANY) { - /* FIXME: do we want to optimize this case too? */ - goto dofuncall; + /* f (nargs, args); */ + args[0] = + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.ptrdiff_type, + op); + args[1] = + gcc_jit_lvalue_get_address ((stack + 1)->gcc_lval, + NULL); + gcc_jit_type *types[] = + { comp.ptrdiff_type, comp.lisp_obj_ptr_type }; + gcc_jit_type *fn_ptr_type = + gcc_jit_context_new_function_ptr_type ( + comp.ctxt, + NULL, + comp.lisp_obj_type, + 2, types, 0); + res = + gcc_jit_context_new_call_through_ptr ( + comp.ctxt, + NULL, + gcc_jit_context_new_rvalue_from_ptr ( + comp.ctxt, + fn_ptr_type, + subr->function.a0), + 2, args); } else { - gcc_jit_type *types[native_nargs]; + gcc_jit_type *types[op]; - for (int i = 0; i < native_nargs; i++) + for (int i = 0; i < op; i++) types[i] = comp.lisp_obj_type; gcc_jit_type *fn_ptr_type = @@ -2437,7 +2460,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.ctxt, NULL, comp.lisp_obj_type, - native_nargs, + op, types, 0); res = @@ -2448,15 +2471,14 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.ctxt, fn_ptr_type, subr->function.a0), - native_nargs, + op, args + 1); } } } - dofuncall: /* Fall back to regular funcall dispatch mechanism. */ if (!res) - res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + res = emit_call_n_ref ("Ffuncall", op + 1, stack->gcc_lval); PUSH_RVAL (res); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ef8e57c40c1..d732d558cdd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -189,7 +189,16 @@ (byte-compile #'comp-tests-ffuncall-native-f) (native-compile #'comp-tests-ffuncall-native-f) - (should (vectorp (comp-tests-ffuncall-native-f))) + (should (equal (comp-tests-ffuncall-native-f) [nil])) + + (defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) + + (byte-compile #'comp-tests-ffuncall-native-rest-f) + (native-compile #'comp-tests-ffuncall-native-rest-f) + + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) From ccc719b230776b856aa4bf581ff19fd681a1aa56 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jul 2019 16:43:09 +0200 Subject: [PATCH 0149/1452] jump table support --- src/comp.c | 56 +++++++++++++++++++++++++++++++++++++----- test/src/comp-tests.el | 15 +++++++++++ 2 files changed, 65 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index d705b5fa70f..54f6602c52f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1816,7 +1816,8 @@ ucmp(const void *a, const void *b) /* Compute and initialize all basic blocks. */ static basic_block_t * -compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) +compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, + Lisp_Object *vectorp, ptrdiff_t const_length) { ptrdiff_t pc = 0; unsigned op; @@ -1890,6 +1891,30 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) case Breturn: new_bb = true; break; + case Bswitch: + /* Handled in Bconstant case. */ + emacs_abort (); + break; + case Bconstant: + { + if (!(Bconstant <= op && op < Bconstant + const_length)) + emacs_abort (); + + if (bytestr_data[pc] != Bswitch) + break; + /* Jump table with following Bswitch. */ + ++pc; + op -= Bconstant; + struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object pc = HASH_VALUE (h, i); + bb_start_pc[bb_n++] = XFIXNUM (pc); + } + bb_start_pc[bb_n++] = pc; + ++pc; + } default: break; } @@ -2082,7 +2107,7 @@ static comp_f_res_t compile_f (const char *lisp_f_name, const char *c_f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, EMACS_INT stack_depth, Lisp_Object *vectorp, - ptrdiff_t vector_size, Lisp_Object args_template) + ptrdiff_t const_length, Lisp_Object args_template) { USE_SAFE_ALLOCA; gcc_jit_rvalue *res; @@ -2169,7 +2194,8 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); comp.block = prologue; - basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); + basic_block_t *bb_map = + compute_blocks (bytestr_length, bytestr_data, vectorp, const_length); if (!parse_args) { @@ -3281,7 +3307,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DISCARD (op); break; CASE (Bswitch); - error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have @@ -3293,7 +3318,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, default: CASE (Bconstant); { - if (op < Bconstant || op > Bconstant + vector_size) + if (op < Bconstant || op > Bconstant + const_length) goto fail; op -= Bconstant; @@ -3316,8 +3341,27 @@ compile_f (const char *lisp_f_name, const char *c_f_name, break; } - /* We're compiling Bswitch instead. */ + /* Jump table with following Bswitch. */ ++pc; + + struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); + POP1; + basic_block_t *jump_block; + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + SAFE_ALLOCA_BLOCK (jump_block, + comp.func, + format_string ("jump_t_%ld", + i)); + ptrdiff_t target_pc = XFIXNUM (HASH_VALUE (h, i)); + gcc_jit_rvalue *val = + emit_lisp_obj_from_ptr (HASH_KEY (h, i)); + emit_cond_jump (emit_EQ (args[0], val), &bb_map[target_pc], + jump_block); + comp.block = jump_block; + } + break; } } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d732d558cdd..b6a8904347f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -218,6 +218,21 @@ (should (= (comp-tests-ffuncall-lambda-f 1) 2))) +(ert-deftest comp-tests-jump-table () + "Testing jump tables" + (defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + + (byte-compile #'comp-tests-jump-table-1-f) + (byte-compile #'comp-tests-jump-table-1-f) + + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + (ert-deftest comp-tests-conditionals () "Testing conditionals." (defun comp-tests-conditionals-1-f (x) From cfcfd1fe8d6e16b85bf28a09582b81683e263db2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jul 2019 19:51:53 +0200 Subject: [PATCH 0150/1452] fix jump table --- src/comp.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 54f6602c52f..4837b122106 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1853,7 +1853,6 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, case Bvarbind6: case Bcall6: case Bunbind6: - case Bconstant2: case BlistN: case BconcatN: case BinsertN: @@ -1895,11 +1894,12 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, /* Handled in Bconstant case. */ emacs_abort (); break; + case Bconstant2: + op = FETCH2; + FALLTHROUGH; + default: case Bconstant: { - if (!(Bconstant <= op && op < Bconstant + const_length)) - emacs_abort (); - if (bytestr_data[pc] != Bswitch) break; /* Jump table with following Bswitch. */ @@ -1915,8 +1915,6 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, bb_start_pc[bb_n++] = pc; ++pc; } - default: - break; } } @@ -3032,8 +3030,8 @@ compile_f (const char *lisp_f_name, const char *c_f_name, CASE_CALL_N (end_of_line, 1); CASE (Bconstant2); - goto do_constant; - break; + op = FETCH2; + goto do_constant; CASE (Bgoto); op = FETCH2; From 15402fe9dbdacd598a723e3b39fc9e90032680cd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jul 2019 09:23:10 +0200 Subject: [PATCH 0151/1452] add comp.el --- lisp/emacs-lisp/comp.el | 50 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 lisp/emacs-lisp/comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el new file mode 100644 index 00000000000..d72127a6eb1 --- /dev/null +++ b/lisp/emacs-lisp/comp.el @@ -0,0 +1,50 @@ +;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Keywords: lisp +;; Package: emacs + +;; 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 . + +;;; Code: + +(require 'disass) +(eval-when-compile (require 'cl-lib)) + +(defgroup comp nil + "Emacs Lisp native compiler." + :group 'lisp) + +(defun comp-recuparate-lap (fun) + "Compile FUN if necessary and recuparate its LAP rapresentation." + (byte-compile-close-variables + (byte-compile-top-level (byte-compile-preprocess fun)) + byte-compile-lap-output)) + +(defun comp-compute-blocks (obj) + "Split OBJ in basic blocks." + obj) + +(defun native-compile (fun) + "FUN is the function definition to be compiled to native code." + (if-let ((f (symbol-function fun))) + (comp-recuparate-lap f) + (error "Trying to native compile not a function"))) + +(provide 'comp) + +;;; comp.el ends here From adeb0183c72cba367b2896dc67eb6afd750ec693 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jul 2019 10:35:20 +0200 Subject: [PATCH 0152/1452] spill lap --- lisp/emacs-lisp/bytecomp.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 40cf821720e..2617142c622 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -559,6 +559,7 @@ outputting warnings about functions not being defined at runtime.") (defvar byte-compile-output nil "Alist describing contents to put in byte code string. Each element is (INDEX . VALUE)") +(defvar byte-compile-lap-output nil) (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") @@ -3111,6 +3112,8 @@ for symbols generated by the byte compiler itself." (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) + ;; Spill lap output here + (setq byte-compile-lap-output byte-compile-output) (let ((byte-compile-vector (byte-compile-constants-vector))) (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) From 8d0ae21c4847e5b78d3dd19325821414095c2756 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jul 2019 12:30:03 +0200 Subject: [PATCH 0153/1452] working on comp.el --- lisp/emacs-lisp/byte-run.el | 2 + lisp/emacs-lisp/bytecomp.el | 1 + lisp/emacs-lisp/comp.el | 149 +++++++++++++++++++++++++++++++++--- 3 files changed, 142 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 6a49c60099d..fedbd61ffd1 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -597,4 +597,6 @@ Otherwise, return nil. For internal use only." (make-obsolete 'macro-declaration-function 'macro-declarations-alist "24.3") +(provide 'byte-run) + ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2617142c622..fa3f5a7f9b9 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,6 +124,7 @@ (require 'backquote) (require 'macroexp) (require 'cconv) +(require 'byte-run) (eval-when-compile (require 'compile)) ;; Refrain from using cl-lib at run-time here, since it otherwise prevents ;; us from emitting warnings when compiling files which use cl-lib without diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d72127a6eb1..9b3bb98e39a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -22,27 +22,156 @@ ;;; Code: -(require 'disass) +(require 'bytecomp) (eval-when-compile (require 'cl-lib)) (defgroup comp nil "Emacs Lisp native compiler." :group 'lisp) -(defun comp-recuparate-lap (fun) - "Compile FUN if necessary and recuparate its LAP rapresentation." - (byte-compile-close-variables - (byte-compile-top-level (byte-compile-preprocess fun)) - byte-compile-lap-output)) +(defconst comp-debug t) -(defun comp-compute-blocks (obj) - "Split OBJ in basic blocks." - obj) +(defconst comp-passes '(comp-recuparate-lap + comp-limplify) + "Passes to be executed in order.") + +(cl-defstruct comp-args + mandatory nonrest rest) + +(cl-defstruct (comp-func (:copier nil)) + "Internal rapresentation for a function." + (symbol-name nil + :documentation "Function symbol's name") + (func nil + :documentation "Original form") + (byte-func nil + :documentation "Byte compiled version") + (ir nil + :documentation "Current intermediate rappresentation") + (args nil :type 'comp-args)) + +(cl-defstruct (comp-meta-var (:copier nil)) + "A frame slot into the meta-stack." + (slot nil :type fixnum + :documentation "Slot position into the meta-stack") + (const-vld nil + :documentation "Valid for the following slot") + (constant nil + :documentation "When const-vld non nil this is used for constant + propagation") + (type nil + :documentation "When non nil is used for type propagation")) + +(cl-defstruct (comp-limple-frame (:copier nil)) + "A LIMPLE func." + (sp 0 :type 'fixnum + :documentation "Current stack pointer") + (frame nil :type 'vector + :documentation "Meta-stack used to flat LAP")) + +(defun comp-decrypt-lambda-list (x) + "Decript lambda list X." + (make-comp-args :rest (not (= (logand x 128) 0)) + :mandatory (logand x 127) + :nonrest (ash x -8))) + +(defun comp-recuparate-lap (ir) + "Byte compile and recuparate LAP rapresentation for IR." + ;; FIXME block timers here, otherwise we could spill the wrong LAP. + (setf (comp-func-byte-func ir) + (byte-compile (comp-func-symbol-name ir))) + (when comp-debug + (cl-prettyprint byte-compile-lap-output)) + (setf (comp-func-args ir) + (comp-decrypt-lambda-list (aref (comp-func-byte-func ir) 0))) + (setf (comp-func-ir ir) byte-compile-lap-output) + ir) + +(defmacro comp-sp () + "Current stack pointer." + '(comp-limple-frame-sp frame)) + +(defmacro comp-slot () + "Current slot into the meta-stack pointed by sp." + '(aref (comp-limple-frame-frame frame) (comp-sp))) + +(defmacro comp-push (n) + "Push slot number N into frame." + `(progn + (cl-incf (comp-sp)) + (list '= (comp-slot) ,n))) + +(defmacro comp-push-slot (n) + "Push slot number N into frame." + `(let ((src-slot (aref (comp-limple-frame-frame frame) ,n))) + (cl-incf (comp-sp)) + (setf (comp-slot) + (copy-sequence src-slot)) + (setf (comp-meta-var-slot (comp-slot)) (comp-sp)) + (list '= (comp-slot) src-slot))) + +(defmacro comp-push-const (x) + "Push X into frame. +X value is known at compile time." + `(progn + (cl-incf (comp-sp)) + (setf (comp-slot) (make-comp-meta-var :slot (comp-sp) + :const-vld t + :constant ,x)) + (list '= (comp-slot) ,x))) + +(defmacro comp-pop (n) + "Pop N elements from the meta-stack." + `(cl-decf (comp-sp) ,n)) + +(defun comp-limplify-lap-inst (inst frame) + "Limplify LAP instruction INST in current FRAME." + (let ((op (car inst))) + (pcase op + ('byte-varref + (comp-push `(call Fsymbol_value ,(second inst)))) + ('byte-constant + (comp-push-const (second inst))) + ('byte-stack-ref + (comp-push-slot (- (comp-sp) (cdr inst)))) + ('byte-plus + (comp-pop 2) + (comp-push `(callref Fplus 2 ,(comp-sp)))) + ('byte-return + `(return ,(comp-sp))) + (_ 'xxx)))) + +(defun comp-limplify (ir) + "Take IR and return LIMPLE." + (let* ((frame-size (aref (comp-func-byte-func ir) 3)) + (frame (make-comp-limple-frame + :sp (1- (comp-args-mandatory (comp-func-args ir))) + :frame (let ((v (make-vector frame-size nil))) + (cl-loop for i below frame-size + do (aset v i (make-comp-meta-var :slot i))) + v))) + (limple-ir + (cl-loop + for inst in (comp-func-ir ir) + collect (comp-limplify-lap-inst inst frame)))) + (setf (comp-func-ir ir) limple-ir) + (when comp-debug + (cl-prettyprint (comp-func-ir ir))) + ir)) (defun native-compile (fun) "FUN is the function definition to be compiled to native code." + (unless lexical-binding + (error "Can't compile a non lexical binded function")) (if-let ((f (symbol-function fun))) - (comp-recuparate-lap f) + (progn + (when (byte-code-function-p f) + (error "Can't native compile an already bytecompiled function")) + (cl-loop with ir = (make-comp-func :symbol-name fun + :func f) + for pass in comp-passes + do (funcall pass ir) + finally return ir)) (error "Trying to native compile not a function"))) (provide 'comp) From 83d1a34ef975ea40bb840d6a0eeb37b407d4cb9e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jul 2019 18:42:55 +0200 Subject: [PATCH 0154/1452] first limple --- lisp/emacs-lisp/comp.el | 48 +++++++++++++++++++++++++++-------------- 1 file changed, 32 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9b3bb98e39a..99f34a069dd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -91,24 +91,28 @@ "Current stack pointer." '(comp-limple-frame-sp frame)) +(defmacro comp-slot-n (n) + "Slot N into the meta-stack." + `(aref (comp-limple-frame-frame frame) ,n)) + (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." - '(aref (comp-limple-frame-frame frame) (comp-sp))) + '(comp-slot-n (comp-sp))) -(defmacro comp-push (n) - "Push slot number N into frame." +(defmacro comp-push (x) + "Push X into frame." `(progn (cl-incf (comp-sp)) - (list '= (comp-slot) ,n))) + (list '= (comp-slot) ,x))) -(defmacro comp-push-slot (n) +(defmacro comp-push-slot-n (n) "Push slot number N into frame." - `(let ((src-slot (aref (comp-limple-frame-frame frame) ,n))) + `(let ((src-slot (comp-slot-n ,n))) (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-meta-var-slot (comp-slot)) (comp-sp)) - (list '= (comp-slot) src-slot))) + (list '=slot (comp-slot) src-slot))) (defmacro comp-push-const (x) "Push X into frame. @@ -118,7 +122,7 @@ X value is known at compile time." (setf (comp-slot) (make-comp-meta-var :slot (comp-sp) :const-vld t :constant ,x)) - (list '= (comp-slot) ,x))) + (list '=const (comp-slot) ,x))) (defmacro comp-pop (n) "Pop N elements from the meta-stack." @@ -128,32 +132,44 @@ X value is known at compile time." "Limplify LAP instruction INST in current FRAME." (let ((op (car inst))) (pcase op + ('byte-dup + (comp-push-slot-n (comp-sp))) ('byte-varref (comp-push `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref - (comp-push-slot (- (comp-sp) (cdr inst)))) + (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 2) (comp-push `(callref Fplus 2 ,(comp-sp)))) + ('byte-car + (comp-pop 1) + (comp-push `(Fcar ,(comp-sp)))) ('byte-return - `(return ,(comp-sp))) + `(return ,(comp-slot))) (_ 'xxx)))) (defun comp-limplify (ir) - "Take IR and return LIMPLE." + "Given IR and return LIMPLE." (let* ((frame-size (aref (comp-func-byte-func ir) 3)) (frame (make-comp-limple-frame - :sp (1- (comp-args-mandatory (comp-func-args ir))) + :sp -1 :frame (let ((v (make-vector frame-size nil))) (cl-loop for i below frame-size do (aset v i (make-comp-meta-var :slot i))) v))) - (limple-ir - (cl-loop - for inst in (comp-func-ir ir) - collect (comp-limplify-lap-inst inst frame)))) + (limple-ir ())) + ;; Prologue + (push '(BLOCK prologue) limple-ir) + (cl-loop for i below (comp-args-mandatory (comp-func-args ir)) + do (progn + (cl-incf (comp-sp)) + (push `(=par ,(comp-slot) ,i) limple-ir))) + (push '(BLOCK body) limple-ir) + (cl-loop for inst in (comp-func-ir ir) + do (push (comp-limplify-lap-inst inst frame) limple-ir)) + (setq limple-ir (reverse limple-ir)) (setf (comp-func-ir ir) limple-ir) (when comp-debug (cl-prettyprint (comp-func-ir ir))) From 85eb3adf002d3ffd61756329b830902e446650ec Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jul 2019 21:49:11 +0200 Subject: [PATCH 0155/1452] working on --- lisp/emacs-lisp/comp.el | 67 +++++++++++++++++++++++++++-------------- 1 file changed, 44 insertions(+), 23 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99f34a069dd..c1248ca3272 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -35,6 +35,8 @@ comp-limplify) "Passes to be executed in order.") +(defconst comp-known-ret-types '((Fcons . cons))) + (cl-defstruct comp-args mandatory nonrest rest) @@ -50,12 +52,12 @@ :documentation "Current intermediate rappresentation") (args nil :type 'comp-args)) -(cl-defstruct (comp-meta-var (:copier nil)) - "A frame slot into the meta-stack." +(cl-defstruct (comp-mvar (:copier nil)) + "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum - :documentation "Slot position into the meta-stack") + :documentation "Slot position") (const-vld nil - :documentation "Valid for the following slot") + :documentation "Valid signal for the following slot") (constant nil :documentation "When const-vld non nil this is used for constant propagation") @@ -99,11 +101,19 @@ "Current slot into the meta-stack pointed by sp." '(comp-slot-n (comp-sp))) -(defmacro comp-push (x) - "Push X into frame." - `(progn +(defmacro comp-slot-next () + "Slot into the meta-stack pointed by sp + 1." + '(comp-slot-n (1+ (comp-sp)))) + +(defmacro comp-push-call (x) + "Push call X into frame." + `(let ((src-slot ,x)) (cl-incf (comp-sp)) - (list '= (comp-slot) ,x))) + (setf (comp-slot) + (make-comp-mvar :slot (comp-sp) + :type (alist-get (second src-slot) + comp-known-ret-types))) + (push (list '=call (comp-slot) src-slot) ir))) (defmacro comp-push-slot-n (n) "Push slot number N into frame." @@ -111,44 +121,54 @@ (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) - (setf (comp-meta-var-slot (comp-slot)) (comp-sp)) - (list '=slot (comp-slot) src-slot))) + (setf (comp-mvar-slot (comp-slot)) (comp-sp)) + (push (list '=slot (comp-slot) src-slot) ir))) (defmacro comp-push-const (x) "Push X into frame. X value is known at compile time." - `(progn + `(let ((val ,x)) (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-meta-var :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t - :constant ,x)) - (list '=const (comp-slot) ,x))) + :constant val)) + (push (list '=const (comp-slot) val) ir))) (defmacro comp-pop (n) "Pop N elements from the meta-stack." `(cl-decf (comp-sp) ,n)) -(defun comp-limplify-lap-inst (inst frame) - "Limplify LAP instruction INST in current FRAME." +(defun comp-limplify-lap-inst (inst frame ir) + "Limplify LAP instruction INST in current FRAME accumulating in IR. +Return the new head." (let ((op (car inst))) (pcase op ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref - (comp-push `(call Fsymbol_value ,(second inst)))) + (comp-push-call `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 2) - (comp-push `(callref Fplus 2 ,(comp-sp)))) + (comp-push-call `(callref Fplus 2 ,(comp-sp)))) ('byte-car (comp-pop 1) - (comp-push `(Fcar ,(comp-sp)))) + (comp-push-call `(call Fcar ,(comp-sp)))) + ('byte-list3 + (comp-pop 1) + (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (dotimes (_ 1) + (comp-pop 2) + (comp-push-call `(call Fcons + ,(comp-slot) + ,(comp-slot-next))))) ('byte-return `(return ,(comp-slot))) - (_ 'xxx)))) + (_ (error "Unexpected LAP op %s" (symbol-name op))))) + ir) (defun comp-limplify (ir) "Given IR and return LIMPLE." @@ -157,7 +177,7 @@ X value is known at compile time." :sp -1 :frame (let ((v (make-vector frame-size nil))) (cl-loop for i below frame-size - do (aset v i (make-comp-meta-var :slot i))) + do (aset v i (make-comp-mvar :slot i))) v))) (limple-ir ())) ;; Prologue @@ -167,8 +187,9 @@ X value is known at compile time." (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) limple-ir))) (push '(BLOCK body) limple-ir) - (cl-loop for inst in (comp-func-ir ir) - do (push (comp-limplify-lap-inst inst frame) limple-ir)) + (mapc (lambda (inst) + (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir))) + (comp-func-ir ir)) (setq limple-ir (reverse limple-ir)) (setf (comp-func-ir ir) limple-ir) (when comp-debug From 2782a07f4d9b8ebc0e89c2b1350aa05c1fd41158 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jul 2019 22:04:50 +0200 Subject: [PATCH 0156/1452] add lists car and cdr --- lisp/emacs-lisp/comp.el | 67 ++++++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 28 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c1248ca3272..42533759424 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -130,8 +130,8 @@ X value is known at compile time." `(let ((val ,x)) (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :const-vld t - :constant val)) + :const-vld t + :constant val)) (push (list '=const (comp-slot) val) ir))) (defmacro comp-pop (n) @@ -141,33 +141,44 @@ X value is known at compile time." (defun comp-limplify-lap-inst (inst frame ir) "Limplify LAP instruction INST in current FRAME accumulating in IR. Return the new head." - (let ((op (car inst))) - (pcase op - ('byte-dup - (comp-push-slot-n (comp-sp))) - ('byte-varref - (comp-push-call `(call Fsymbol_value ,(second inst)))) - ('byte-constant - (comp-push-const (second inst))) - ('byte-stack-ref - (comp-push-slot-n (- (comp-sp) (cdr inst)))) - ('byte-plus - (comp-pop 2) - (comp-push-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-car - (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-sp)))) - ('byte-list3 - (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) nil)) - (dotimes (_ 1) + (cl-flet ((do-list (n) + (comp-pop 1) + (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (dotimes (_ (1- n)) + (comp-pop 2) + (comp-push-call `(call Fcons + ,(comp-slot-next) + ,(comp-slot-n (+ 2 (comp-sp)))))))) + (let ((op (car inst))) + (pcase op + ('byte-dup + (comp-push-slot-n (comp-sp))) + ('byte-varref + (comp-push-call `(call Fsymbol_value ,(second inst)))) + ('byte-constant + (comp-push-const (second inst))) + ('byte-stack-ref + (comp-push-slot-n (- (comp-sp) (cdr inst)))) + ('byte-plus (comp-pop 2) - (comp-push-call `(call Fcons - ,(comp-slot) - ,(comp-slot-next))))) - ('byte-return - `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))) + (comp-push-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-car + (comp-pop 1) + (comp-push-call `(call Fcar ,(comp-sp)))) + ('byte-cdr + (comp-pop 1) + (comp-push-call `(call Fcdr ,(comp-sp)))) + ('byte-list1 + (do-list 1)) + ('byte-list2 + (do-list 2)) + ('byte-list3 + (do-list 3)) + ('byte-list4 + (do-list 4)) + ('byte-return + `(return ,(comp-slot))) + (_ (error "Unexpected LAP op %s" (symbol-name op)))))) ir) (defun comp-limplify (ir) From 02bd9340e2d81dcdc991c4cc47888b2404e56110 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 07:17:28 +0200 Subject: [PATCH 0157/1452] some code for const propagation --- lisp/emacs-lisp/comp.el | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 42533759424..8ed75e0a4b3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,6 +37,15 @@ (defconst comp-known-ret-types '((Fcons . cons))) +(defconst comp-mostly-pure-funcs + '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior + lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax + symbol-name) + "Functions on witch we do constant propagation." + ;; Is it acceptable to move into the compile time functions that are + ;; allocating memory? (these are technically not side effect free) +) + (cl-defstruct comp-args mandatory nonrest rest) @@ -105,6 +114,13 @@ "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) +;; (defun comp-opt-call (inst) +;; "Optimize if possible a side-effect-free call in INST." +;; (cl-destructuring-bind (_ f &rest args) inst +;; (when (and (member f comp-mostly-pure-funcs) +;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) +;; (apply f (mapcar #'comp-mvar-constant args))))) + (defmacro comp-push-call (x) "Push call X into frame." `(let ((src-slot ,x)) From 8107fc6d0ce15f7a3da13df9eb74d63ab00167a7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 07:56:37 +0200 Subject: [PATCH 0158/1452] add SSA --- lisp/emacs-lisp/comp.el | 86 +++++++++++++------------ test/src/comp-tests.el | 135 ++++++++++++++-------------------------- 2 files changed, 94 insertions(+), 127 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8ed75e0a4b3..a51b993c654 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -59,10 +59,14 @@ :documentation "Byte compiled version") (ir nil :documentation "Current intermediate rappresentation") - (args nil :type 'comp-args)) + (args nil :type 'comp-args) + (limple-cnt -1 :type 'number + :documentation "Counter to create ssa limple vars")) -(cl-defstruct (comp-mvar (:copier nil)) +(cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." + (n nil :type number + :documentation "SSA number") (slot nil :type fixnum :documentation "Slot position") (const-vld nil @@ -73,6 +77,11 @@ (type nil :documentation "When non nil is used for type propagation")) +(cl-defun make-comp-mvar (func &key slot const-vld constant type) + (make--comp-mvar :n (cl-incf (comp-func-limple-cnt func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + (cl-defstruct (comp-limple-frame (:copier nil)) "A LIMPLE func." (sp 0 :type 'fixnum @@ -86,17 +95,24 @@ :mandatory (logand x 127) :nonrest (ash x -8))) -(defun comp-recuparate-lap (ir) - "Byte compile and recuparate LAP rapresentation for IR." +(defun comp-recuparate-lap (func) + "Byte compile and recuparate LAP rapresentation for FUNC." ;; FIXME block timers here, otherwise we could spill the wrong LAP. - (setf (comp-func-byte-func ir) - (byte-compile (comp-func-symbol-name ir))) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) (when comp-debug (cl-prettyprint byte-compile-lap-output)) - (setf (comp-func-args ir) - (comp-decrypt-lambda-list (aref (comp-func-byte-func ir) 0))) - (setf (comp-func-ir ir) byte-compile-lap-output) - ir) + (setf (comp-func-args func) + (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-ir func) byte-compile-lap-output) + func) + +;; (defun comp-opt-call (inst) +;; "Optimize if possible a side-effect-free call in INST." +;; (cl-destructuring-bind (_ f &rest args) inst +;; (when (and (member f comp-mostly-pure-funcs) +;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) +;; (apply f (mapcar #'comp-mvar-constant args))))) (defmacro comp-sp () "Current stack pointer." @@ -114,19 +130,13 @@ "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -;; (defun comp-opt-call (inst) -;; "Optimize if possible a side-effect-free call in INST." -;; (cl-destructuring-bind (_ f &rest args) inst -;; (when (and (member f comp-mostly-pure-funcs) -;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) -;; (apply f (mapcar #'comp-mvar-constant args))))) - (defmacro comp-push-call (x) "Push call X into frame." `(let ((src-slot ,x)) (cl-incf (comp-sp)) (setf (comp-slot) - (make-comp-mvar :slot (comp-sp) + (make-comp-mvar func + :slot (comp-sp) :type (alist-get (second src-slot) comp-known-ret-types))) (push (list '=call (comp-slot) src-slot) ir))) @@ -145,7 +155,8 @@ X value is known at compile time." `(let ((val ,x)) (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar func + :slot (comp-sp) :const-vld t :constant val)) (push (list '=const (comp-slot) val) ir))) @@ -154,9 +165,9 @@ X value is known at compile time." "Pop N elements from the meta-stack." `(cl-decf (comp-sp) ,n)) -(defun comp-limplify-lap-inst (inst frame ir) - "Limplify LAP instruction INST in current FRAME accumulating in IR. -Return the new head." +(defun comp-limplify-lap-inst (inst frame ir func) + "Limplify LAP instruction INST in current FRAME accumulating in IR for current + FUNC." (cl-flet ((do-list (n) (comp-pop 1) (comp-push-call `(call Fcons ,(comp-slot-next) nil)) @@ -197,31 +208,28 @@ Return the new head." (_ (error "Unexpected LAP op %s" (symbol-name op)))))) ir) -(defun comp-limplify (ir) - "Given IR and return LIMPLE." - (let* ((frame-size (aref (comp-func-byte-func ir) 3)) +(defun comp-limplify (func) + "Given FUNC and return LIMPLE." + (let* ((frame-size (aref (comp-func-byte-func func) 3)) (frame (make-comp-limple-frame :sp -1 - :frame (let ((v (make-vector frame-size nil))) - (cl-loop for i below frame-size - do (aset v i (make-comp-mvar :slot i))) - v))) + :frame (make-vector frame-size nil))) (limple-ir ())) ;; Prologue (push '(BLOCK prologue) limple-ir) - (cl-loop for i below (comp-args-mandatory (comp-func-args ir)) + (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) limple-ir))) (push '(BLOCK body) limple-ir) (mapc (lambda (inst) - (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir))) - (comp-func-ir ir)) + (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir func))) + (comp-func-ir func)) (setq limple-ir (reverse limple-ir)) - (setf (comp-func-ir ir) limple-ir) + (setf (comp-func-ir func) limple-ir) (when comp-debug - (cl-prettyprint (comp-func-ir ir))) - ir)) + (cl-prettyprint (comp-func-ir func))) + func)) (defun native-compile (fun) "FUN is the function definition to be compiled to native code." @@ -231,11 +239,11 @@ Return the new head." (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) - (cl-loop with ir = (make-comp-func :symbol-name fun - :func f) + (cl-loop with func = (make-comp-func :symbol-name fun + :func f) for pass in comp-passes - do (funcall pass ir) - finally return ir)) + do (funcall pass func) + finally return func)) (error "Trying to native compile not a function"))) (provide 'comp) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b6a8904347f..421f77008a4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -31,13 +31,16 @@ (defvar comp-tests-var1 3) +(defun comp-test-compile (f) + ;; (byte-compile f) + (native-compile f)) + (ert-deftest comp-tests-varref () "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) - (byte-compile #'comp-tests-varref-f) - (native-compile #'comp-tests-varref-f) + (comp-test-compile #'comp-tests-varref-f) (should (= (comp-tests-varref-f) 3))) @@ -58,16 +61,11 @@ ;; Bcdr_safe (cdr-safe x)) - (byte-compile #'comp-tests-list-f) - (native-compile #'comp-tests-list-f) - (byte-compile #'comp-tests-car-f) - (native-compile #'comp-tests-car-f) - (byte-compile #'comp-tests-cdr-f) - (native-compile #'comp-tests-cdr-f) - (byte-compile #'comp-tests-car-safe-f) - (native-compile #'comp-tests-car-safe-f) - (byte-compile #'comp-tests-cdr-safe-f) - (native-compile #'comp-tests-cdr-safe-f) + (comp-test-compile #'comp-tests-list-f) + (comp-test-compile #'comp-tests-car-f) + (comp-test-compile #'comp-tests-cdr-f) + (comp-test-compile #'comp-tests-car-safe-f) + (comp-test-compile #'comp-tests-cdr-safe-f) (should (equal (comp-tests-list-f) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) @@ -91,13 +89,11 @@ "Testing cons car cdr." (defun comp-tests-cons-car-f () (car (cons 1 2))) - (byte-compile #'comp-tests-cons-car-f) - (native-compile #'comp-tests-cons-car-f) + (comp-test-compile #'comp-tests-cons-car-f) (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) - (byte-compile #'comp-tests-cons-cdr-f) - (native-compile #'comp-tests-cons-cdr-f) + (comp-test-compile #'comp-tests-cons-cdr-f) (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-cdr-f 3) 3))) @@ -106,8 +102,7 @@ "Testing varset." (defun comp-tests-varset-f () (setq comp-tests-var1 55)) - (byte-compile #'comp-tests-varset-f) - (native-compile #'comp-tests-varset-f) + (comp-test-compile #'comp-tests-varset-f) (comp-tests-varset-f) (should (= comp-tests-var1 55))) @@ -116,8 +111,7 @@ "Testing length." (defun comp-tests-length-f () (length '(1 2 3))) - (byte-compile #'comp-tests-length-f) - (native-compile #'comp-tests-length-f) + (comp-test-compile #'comp-tests-length-f) (should (= (comp-tests-length-f) 3))) @@ -127,8 +121,7 @@ (let ((vec [1 2 3])) (aset vec 2 100) (aref vec 2))) - (byte-compile #'comp-tests-aref-aset-f) - (native-compile #'comp-tests-aref-aset-f) + (comp-test-compile #'comp-tests-aref-aset-f) (should (= (comp-tests-aref-aset-f) 100))) @@ -137,8 +130,7 @@ (defvar comp-tests-var2 3) (defun comp-tests-symbol-value-f () (symbol-value 'comp-tests-var2)) - (byte-compile #'comp-tests-symbol-value-f) - (native-compile #'comp-tests-symbol-value-f) + (comp-test-compile #'comp-tests-symbol-value-f) (should (= (comp-tests-symbol-value-f) 3))) @@ -147,8 +139,7 @@ (defun comp-tests-concat-f (x) (concat "a" "b" "c" "d" (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - (byte-compile #'comp-tests-concat-f) - (native-compile #'comp-tests-concat-f) + (comp-test-compile #'comp-tests-concat-f) (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) @@ -159,15 +150,13 @@ (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) - (byte-compile #'comp-tests-ffuncall-caller-f) - (native-compile #'comp-tests-ffuncall-caller-f) + (comp-test-compile #'comp-tests-ffuncall-caller-f) (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) - (byte-compile #'comp-tests-ffuncall-callee-optional-f) - (native-compile #'comp-tests-ffuncall-callee-optional-f) + (comp-test-compile #'comp-tests-ffuncall-callee-optional-f) (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) @@ -175,8 +164,7 @@ (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) (list a b c)) - (byte-compile #'comp-tests-ffuncall-callee-rest-f) - (native-compile #'comp-tests-ffuncall-callee-rest-f) + (comp-test-compile #'comp-tests-ffuncall-callee-rest-f) (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) @@ -186,8 +174,7 @@ "Call a primitive with no dedicate op." (make-vector 1 nil)) - (byte-compile #'comp-tests-ffuncall-native-f) - (native-compile #'comp-tests-ffuncall-native-f) + (comp-test-compile #'comp-tests-ffuncall-native-f) (should (equal (comp-tests-ffuncall-native-f) [nil])) @@ -195,16 +182,14 @@ "Call a primitive with no dedicate op with &rest." (vector 1 2 3)) - (byte-compile #'comp-tests-ffuncall-native-rest-f) - (native-compile #'comp-tests-ffuncall-native-rest-f) + (comp-test-compile #'comp-tests-ffuncall-native-rest-f) (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) - (byte-compile #'comp-tests-ffuncall-apply-many-f) - (native-compile #'comp-tests-ffuncall-apply-many-f) + (comp-test-compile #'comp-tests-ffuncall-apply-many-f) (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) @@ -213,8 +198,7 @@ (1+ x)))) (funcall fun x))) - (byte-compile #'comp-tests-ffuncall-lambda-f) - (native-compile #'comp-tests-ffuncall-lambda-f) + (comp-test-compile #'comp-tests-ffuncall-lambda-f) (should (= (comp-tests-ffuncall-lambda-f 1) 2))) @@ -226,8 +210,6 @@ ('y 'b) (_ 'c))) - (byte-compile #'comp-tests-jump-table-1-f) - (byte-compile #'comp-tests-jump-table-1-f) (should (eq (comp-tests-jump-table-1-f 'x) 'a)) (should (eq (comp-tests-jump-table-1-f 'y) 'b)) @@ -242,10 +224,8 @@ ;; Generate goto-if-nil-else-pop (when x 1340)) - (byte-compile #'comp-tests-conditionals-1-f) - (byte-compile #'comp-tests-conditionals-2-f) - (native-compile #'comp-tests-conditionals-1-f) - (native-compile #'comp-tests-conditionals-2-f) + (comp-test-compile #'comp-tests-conditionals-1-f) + (comp-test-compile #'comp-tests-conditionals-2-f) (should (= (comp-tests-conditionals-1-f t) 1)) (should (= (comp-tests-conditionals-1-f nil) 2)) @@ -264,12 +244,9 @@ ;; Bnegate (- x)) - (byte-compile #'comp-tests-fixnum-1-minus-f) - (byte-compile #'comp-tests-fixnum-1-plus-f) - (byte-compile #'comp-tests-fixnum-minus-f) - (native-compile #'comp-tests-fixnum-1-minus-f) - (native-compile #'comp-tests-fixnum-1-plus-f) - (native-compile #'comp-tests-fixnum-minus-f) + (comp-test-compile #'comp-tests-fixnum-1-minus-f) + (comp-test-compile #'comp-tests-fixnum-1-plus-f) + (comp-test-compile #'comp-tests-fixnum-minus-f) (should (= (comp-tests-fixnum-1-minus-f 10) 9)) (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) @@ -311,17 +288,12 @@ ;; Bgeq (>= x y)) - (byte-compile #'comp-tests-eqlsign-f) - (byte-compile #'comp-tests-gtr-f) - (byte-compile #'comp-tests-lss-f) - (byte-compile #'comp-tests-les-f) - (byte-compile #'comp-tests-geq-f) - (native-compile #'comp-tests-eqlsign-f) - (native-compile #'comp-tests-gtr-f) - (native-compile #'comp-tests-lss-f) - (native-compile #'comp-tests-les-f) - (native-compile #'comp-tests-geq-f) + (comp-test-compile #'comp-tests-eqlsign-f) + (comp-test-compile #'comp-tests-gtr-f) + (comp-test-compile #'comp-tests-lss-f) + (comp-test-compile #'comp-tests-les-f) + (comp-test-compile #'comp-tests-geq-f) (should (eq (comp-tests-eqlsign-f 4 3) nil)) (should (eq (comp-tests-eqlsign-f 3 3) t)) @@ -348,10 +320,8 @@ (setcdr x y) x) - (byte-compile #'comp-tests-setcar-f) - (byte-compile #'comp-tests-setcdr-f) - (native-compile #'comp-tests-setcar-f) - (native-compile #'comp-tests-setcdr-f) + (comp-test-compile #'comp-tests-setcar-f) + (comp-test-compile #'comp-tests-setcdr-f) (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) @@ -380,8 +350,7 @@ (setq i (1- i))) list)) - (byte-compile #'comp-bubble-sort-f) - (native-compile #'comp-bubble-sort-f) + (comp-test-compile #'comp-bubble-sort-f) (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) @@ -397,10 +366,8 @@ ;; Bsetcar (setcar x 3)) - (byte-compile #'comp-tests-consp-f) - (native-compile #'comp-tests-consp-f) - (byte-compile #'comp-tests-car-f) - (native-compile #'comp-tests-car-f) + (comp-test-compile #'comp-tests-consp-f) + (comp-test-compile #'comp-tests-car-f) (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil)) @@ -417,10 +384,8 @@ ;; Bnumberp (numberp x)) - (byte-compile #'comp-tests-integerp-f) - (native-compile #'comp-tests-integerp-f) - (byte-compile #'comp-tests-numberp-f) - (native-compile #'comp-tests-numberp-f) + (comp-test-compile #'comp-tests-integerp-f) + (comp-test-compile #'comp-tests-numberp-f) (should (eq (comp-tests-integerp-f 1) t)) (should (eq (comp-tests-integerp-f '(1)) nil)) @@ -443,10 +408,8 @@ ;; Binsert (insert a b c d)) - (byte-compile #'comp-tests-discardn-f) - (native-compile #'comp-tests-discardn-f) - (byte-compile #'comp-tests-insertn-f) - (native-compile #'comp-tests-insertn-f) + (comp-test-compile #'comp-tests-discardn-f) + (comp-test-compile #'comp-tests-insertn-f) (should (= (comp-tests-discardn-f 10) 2)) @@ -493,14 +456,10 @@ (defun comp-tests-throw-f (x) (throw 'foo x)) - (byte-compile #'comp-tests-condition-case-0-f) - (native-compile #'comp-tests-condition-case-0-f) - (byte-compile #'comp-tests-condition-case-1-f) - (native-compile #'comp-tests-condition-case-1-f) - (byte-compile #'comp-tests-catch-f) - (native-compile #'comp-tests-catch-f) - (byte-compile #'comp-tests-throw-f) - (native-compile #'comp-tests-throw-f) + (comp-test-compile #'comp-tests-condition-case-0-f) + (comp-test-compile #'comp-tests-condition-case-1-f) + (comp-test-compile #'comp-tests-catch-f) + (comp-test-compile #'comp-tests-throw-f) (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) From a4ea174a3727b9d690a4503f1f32b0382088f419 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 09:06:58 +0200 Subject: [PATCH 0159/1452] clean all crazy macrology in favor of some special var --- lisp/emacs-lisp/comp.el | 98 +++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 47 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a51b993c654..8740779b8b3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -114,13 +114,18 @@ ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) +;; Special vars used during limplifications +(defvar comp-frame) +(defvar comp-limple) +(defvar comp-func) + (defmacro comp-sp () "Current stack pointer." - '(comp-limple-frame-sp frame)) + '(comp-limple-frame-sp comp-frame)) (defmacro comp-slot-n (n) "Slot N into the meta-stack." - `(aref (comp-limple-frame-frame frame) ,n)) + `(aref (comp-limple-frame-frame comp-frame) ,n)) (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." @@ -130,44 +135,42 @@ "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defmacro comp-push-call (x) +(defun comp-push-call (src-slot) "Push call X into frame." - `(let ((src-slot ,x)) - (cl-incf (comp-sp)) - (setf (comp-slot) - (make-comp-mvar func - :slot (comp-sp) - :type (alist-get (second src-slot) - comp-known-ret-types))) - (push (list '=call (comp-slot) src-slot) ir))) + (cl-incf (comp-sp)) + (setf (comp-slot) + (make-comp-mvar comp-func + :slot (comp-sp) + :type (alist-get (second src-slot) + comp-known-ret-types))) + (push (list '=call (comp-slot) src-slot) comp-limple)) -(defmacro comp-push-slot-n (n) +(defun comp-push-slot-n (n) "Push slot number N into frame." - `(let ((src-slot (comp-slot-n ,n))) - (cl-incf (comp-sp)) - (setf (comp-slot) - (copy-sequence src-slot)) - (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list '=slot (comp-slot) src-slot) ir))) + (let ((src-slot (comp-slot-n n))) + (cl-incf (comp-sp)) + (setf (comp-slot) + (copy-sequence src-slot)) + (setf (comp-mvar-slot (comp-slot)) (comp-sp)) + (push (list '=slot (comp-slot) src-slot) comp-limple))) -(defmacro comp-push-const (x) - "Push X into frame. -X value is known at compile time." - `(let ((val ,x)) - (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar func - :slot (comp-sp) - :const-vld t - :constant val)) - (push (list '=const (comp-slot) val) ir))) +(defun comp-push-const (val) + "Push VAL into frame. +VAL is known at compile time." + (cl-incf (comp-sp)) + (setf (comp-slot) (make-comp-mvar comp-func + :slot (comp-sp) + :const-vld t + :constant val)) + (push (list '=const (comp-slot) val) comp-limple)) -(defmacro comp-pop (n) +(defun comp-pop (n) "Pop N elements from the meta-stack." - `(cl-decf (comp-sp) ,n)) + (cl-decf (comp-sp) n)) -(defun comp-limplify-lap-inst (inst frame ir func) - "Limplify LAP instruction INST in current FRAME accumulating in IR for current - FUNC." +(defun comp-limplify-lap-inst (inst) + "Limplify LAP instruction INST in current frame accumulating in `comp-limple' + for current `func'." (cl-flet ((do-list (n) (comp-pop 1) (comp-push-call `(call Fcons ,(comp-slot-next) nil)) @@ -205,28 +208,29 @@ X value is known at compile time." (do-list 4)) ('byte-return `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op)))))) - ir) + (_ (error "Unexpected LAP op %s" (symbol-name op))))))) (defun comp-limplify (func) "Given FUNC and return LIMPLE." (let* ((frame-size (aref (comp-func-byte-func func) 3)) - (frame (make-comp-limple-frame - :sp -1 - :frame (make-vector frame-size nil))) - (limple-ir ())) + (comp-frame (make-comp-limple-frame + :sp -1 + :frame (let ((v (make-vector frame-size nil))) + (cl-loop for i below frame-size + do (aset v i (make-comp-mvar func + :slot i))) + v))) + (comp-func func) + (comp-limple ())) ;; Prologue - (push '(BLOCK prologue) limple-ir) + (push '(BLOCK prologue) comp-limple) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) - (push `(=par ,(comp-slot) ,i) limple-ir))) - (push '(BLOCK body) limple-ir) - (mapc (lambda (inst) - (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir func))) - (comp-func-ir func)) - (setq limple-ir (reverse limple-ir)) - (setf (comp-func-ir func) limple-ir) + (push `(=par ,(comp-slot) ,i) comp-limple))) + (push '(BLOCK body) comp-limple) + (mapc #'comp-limplify-lap-inst (comp-func-ir func)) + (setf (comp-func-ir func) (reverse comp-limple)) (when comp-debug (cl-prettyprint (comp-func-ir func))) func)) From f745b498ad42fd6289870fabc7e8e28b46e14b07 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 09:15:09 +0200 Subject: [PATCH 0160/1452] move out comp-limplify-listn --- lisp/emacs-lisp/comp.el | 77 +++++++++++++++++++++-------------------- 1 file changed, 39 insertions(+), 38 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8740779b8b3..e3594227e27 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -168,47 +168,48 @@ VAL is known at compile time." "Pop N elements from the meta-stack." (cl-decf (comp-sp) n)) +(defun comp-limplify-listn (n) + (comp-pop 1) + (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (dotimes (_ (1- n)) + (comp-pop 2) + (comp-push-call `(call Fcons + ,(comp-slot-next) + ,(comp-slot-n (+ 2 (comp-sp))))))) + (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST in current frame accumulating in `comp-limple' for current `func'." - (cl-flet ((do-list (n) - (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) nil)) - (dotimes (_ (1- n)) - (comp-pop 2) - (comp-push-call `(call Fcons - ,(comp-slot-next) - ,(comp-slot-n (+ 2 (comp-sp)))))))) - (let ((op (car inst))) - (pcase op - ('byte-dup - (comp-push-slot-n (comp-sp))) - ('byte-varref - (comp-push-call `(call Fsymbol_value ,(second inst)))) - ('byte-constant - (comp-push-const (second inst))) - ('byte-stack-ref - (comp-push-slot-n (- (comp-sp) (cdr inst)))) - ('byte-plus - (comp-pop 2) - (comp-push-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-car - (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-sp)))) - ('byte-cdr - (comp-pop 1) - (comp-push-call `(call Fcdr ,(comp-sp)))) - ('byte-list1 - (do-list 1)) - ('byte-list2 - (do-list 2)) - ('byte-list3 - (do-list 3)) - ('byte-list4 - (do-list 4)) - ('byte-return - `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))))) + (let ((op (car inst))) + (pcase op + ('byte-dup + (comp-push-slot-n (comp-sp))) + ('byte-varref + (comp-push-call `(call Fsymbol_value ,(second inst)))) + ('byte-constant + (comp-push-const (second inst))) + ('byte-stack-ref + (comp-push-slot-n (- (comp-sp) (cdr inst)))) + ('byte-plus + (comp-pop 2) + (comp-push-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-car + (comp-pop 1) + (comp-push-call `(call Fcar ,(comp-sp)))) + ('byte-cdr + (comp-pop 1) + (comp-push-call `(call Fcdr ,(comp-sp)))) + ('byte-list1 + (comp-limplify-listn 1)) + ('byte-list2 + (comp-limplify-listn 2)) + ('byte-list3 + (comp-limplify-listn 3)) + ('byte-list4 + (comp-limplify-listn 4)) + ('byte-return + `(return ,(comp-slot))) + (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify (func) "Given FUNC and return LIMPLE." From e209967089ebd7fa91ab7268dc0fe66e1d1297be Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 09:29:13 +0200 Subject: [PATCH 0161/1452] working on --- lisp/emacs-lisp/comp.el | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e3594227e27..22dcfc77b36 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,11 +77,6 @@ (type nil :documentation "When non nil is used for type propagation")) -(cl-defun make-comp-mvar (func &key slot const-vld constant type) - (make--comp-mvar :n (cl-incf (comp-func-limple-cnt func)) - :slot slot :const-vld const-vld :constant constant - :type type)) - (cl-defstruct (comp-limple-frame (:copier nil)) "A LIMPLE func." (sp 0 :type 'fixnum @@ -119,6 +114,11 @@ (defvar comp-limple) (defvar comp-func) +(cl-defun make-comp-mvar (&key slot const-vld constant type) + (make--comp-mvar :n (cl-incf (comp-func-limple-cnt comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + (defmacro comp-sp () "Current stack pointer." '(comp-limple-frame-sp comp-frame)) @@ -139,8 +139,7 @@ "Push call X into frame." (cl-incf (comp-sp)) (setf (comp-slot) - (make-comp-mvar comp-func - :slot (comp-sp) + (make-comp-mvar :slot (comp-sp) :type (alist-get (second src-slot) comp-known-ret-types))) (push (list '=call (comp-slot) src-slot) comp-limple)) @@ -158,8 +157,7 @@ "Push VAL into frame. VAL is known at compile time." (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar comp-func - :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) (push (list '=const (comp-slot) val) comp-limple)) @@ -169,8 +167,11 @@ VAL is known at compile time." (cl-decf (comp-sp) n)) (defun comp-limplify-listn (n) + "Limplify list N." (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (comp-push-call `(call Fcons ,(comp-slot-next) + ,(make-comp-mvar :const-vld t + :constant nil))) (dotimes (_ (1- n)) (comp-pop 2) (comp-push-call `(call Fcons @@ -178,8 +179,7 @@ VAL is known at compile time." ,(comp-slot-n (+ 2 (comp-sp))))))) (defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST in current frame accumulating in `comp-limple' - for current `func'." + "Limplify LAP instruction INST accumulating in `comp-limple'." (let ((op (car inst))) (pcase op ('byte-dup @@ -199,6 +199,12 @@ VAL is known at compile time." ('byte-cdr (comp-pop 1) (comp-push-call `(call Fcdr ,(comp-sp)))) + ('byte-car-safe + (comp-pop 1) + (comp-push-call `(call Fcar-safe ,(comp-sp)))) + ('byte-cdr-safe + (comp-pop 1) + (comp-push-call `(call Fcdr-safe ,(comp-sp)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -214,14 +220,13 @@ VAL is known at compile time." (defun comp-limplify (func) "Given FUNC and return LIMPLE." (let* ((frame-size (aref (comp-func-byte-func func) 3)) + (comp-func func) (comp-frame (make-comp-limple-frame :sp -1 :frame (let ((v (make-vector frame-size nil))) (cl-loop for i below frame-size - do (aset v i (make-comp-mvar func - :slot i))) + do (aset v i (make-comp-mvar :slot i))) v))) - (comp-func func) (comp-limple ())) ;; Prologue (push '(BLOCK prologue) comp-limple) From a9894ace841f89bdb1e4510ad48cb7fd76112ac0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 11:18:17 +0200 Subject: [PATCH 0162/1452] purge C side --- lisp/emacs-lisp/comp.el | 6 +- src/comp.c | 1743 +-------------------------------------- test/src/comp-tests.el | 5 + 3 files changed, 51 insertions(+), 1703 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 22dcfc77b36..fda4dc437b6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -136,7 +136,8 @@ '(comp-slot-n (1+ (comp-sp)))) (defun comp-push-call (src-slot) - "Push call X into frame." + "Push call SRC-SLOT into frame." + (cl-assert src-slot) (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) @@ -147,6 +148,7 @@ (defun comp-push-slot-n (n) "Push slot number N into frame." (let ((src-slot (comp-slot-n n))) + (cl-assert src-slot) (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) @@ -186,6 +188,8 @@ VAL is known at compile time." (comp-push-slot-n (comp-sp))) ('byte-varref (comp-push-call `(call Fsymbol_value ,(second inst)))) + ;; ('byte-varset + ;; (comp-push-call `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref diff --git a/src/comp.c b/src/comp.c index 4837b122106..fb1fa79d12d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,138 +31,12 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" -#define DEFAULT_SPEED 2 /* From 0 to 3 map to gcc -O */ +#define DEFAULT_SPEED 2 /* See comp-speed var. */ #define COMP_DEBUG 1 -#define MAX_FUN_NAME 256 - -/* Max number of entries of the meta-stack that can get poped. */ - -#define MAX_POP 64 - #define DISASS_FILE_NAME "emacs-asm.s" -#define CHECK_STACK \ - eassert (stack >= stack_base && stack < stack_over) - -#define PUSH_LVAL(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (comp.block, \ - stack, \ - gcc_jit_lvalue_as_rvalue (obj)); \ - stack++; \ - } while (0) - -#define PUSH_RVAL(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (comp.block, stack, (obj)); \ - stack++; \ - } while (0) - -/* This always happens in the first basic block. */ - -#define PUSH_PARAM(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (prologue, \ - stack, \ - gcc_jit_param_as_rvalue (obj)); \ - stack++; \ - } while (0) - -#define TOS (*(stack - 1)) - -#define DISCARD(n) (stack -= (n)) - -#define POP0 - -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -/* Fetch the next byte from the bytecode stream. */ - -#define FETCH (bytestr_data[pc++]) - -/* Fetch two bytes from the bytecode stream and make a 16-bit number - out of them. */ - -#define FETCH2 (op = FETCH, op + (FETCH << 8)) - -#define STR(s) #s - -/* With most of the ops we need to do the same stuff so this macros are meant - to save some typing. */ - -#define CASE(op) \ - case op : \ - emit_comment (STR(op)) - -/* Pop from the meta-stack, emit the call and push the result */ - -#define EMIT_CALL_N(name, nargs) \ - do { \ - POP##nargs; \ - res = emit_call ((name), comp.lisp_obj_type, (nargs), args); \ - PUSH_RVAL (res); \ - } while (0) - -/* Generate appropriate case and emit call to function. */ - -#define CASE_CALL_N(name, nargs) \ - CASE (B##name); \ - EMIT_CALL_N (STR(F##name), nargs); \ - break - -/* - Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args). - This is done by passing a reference to the first obj involved on the stack. -*/ - -#define EMIT_CALL_N_REF(name, nargs) \ - do { \ - DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), stack->gcc_lval); \ - PUSH_RVAL (res); \ - } while (0) - -#define EMIT_ARITHCOMPARE(comparison) \ - do { \ - POP2; \ - args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ - comp.int_type, \ - (comparison)); \ - res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ - PUSH_RVAL (res); \ - } while (0) - - #define SAFE_ALLOCA_BLOCK(ptr, func, name) \ do { \ (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ @@ -171,6 +45,8 @@ do { \ (ptr)->top = NULL; \ } while (0) +#define STR(s) #s + #define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ basic_block_t *(name); \ SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) @@ -304,24 +180,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Pop form the main evaluation stack and place the elements in args in reversed - order. */ - -INLINE static void -pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) -{ - eassert (n <= MAX_POP); /* FIXME? */ - stack_el_t *stack = *stack_ref; - - while (n--) - { - stack--; - args[n] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); - } - - *stack_ref = stack; -} - INLINE static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -1806,150 +1664,16 @@ define_bool_to_lisp_obj (void) SAFE_FREE (); } -static int -ucmp(const void *a, const void *b) +DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, + 0, 0, 0, + doc: /* Initialize the native compiler context. Return t on success. */) + (void) { -#define _I(x) *(const int*)x - return _I(a) < _I(b) ? -1 : _I(a) > _I(b); -#undef _I -} - -/* Compute and initialize all basic blocks. */ -static basic_block_t * -compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, - Lisp_Object *vectorp, ptrdiff_t const_length) -{ - ptrdiff_t pc = 0; - unsigned op; - bool new_bb = true; - basic_block_t *bb_map = xmalloc (bytestr_length * sizeof (basic_block_t)); - unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); - unsigned bb_n = 0; - - while (pc < bytestr_length) + if (comp.ctxt) { - if (new_bb) - { - bb_start_pc[bb_n++] = pc; - new_bb = false; - } - - op = FETCH; - switch (op) - { - /* 3 byte non branch ops */ - case Bvarref7: - case Bvarset7: - case Bvarbind7: - case Bcall7: - case Bunbind7: - case Bstack_ref7: - case Bstack_set2: - pc += 2; - break; - /* 2 byte non branch ops */ - case Bvarref6: - case Bvarset6: - case Bvarbind6: - case Bcall6: - case Bunbind6: - case BlistN: - case BconcatN: - case BinsertN: - case Bstack_ref6: - case Bstack_set: - case BdiscardN: - ++pc; - break; - /* Absolute branches */ - case Bgoto: - case Bgotoifnil: - case Bgotoifnonnil: - case Bgotoifnilelsepop: - case Bgotoifnonnilelsepop: - case Bpushcatch: - case Bpushconditioncase: - op = FETCH2; - bb_start_pc[bb_n++] = op; - new_bb = true; - break; - /* PC relative branches */ - case BRgoto: - case BRgotoifnil: - case BRgotoifnonnil: - case BRgotoifnilelsepop: - case BRgotoifnonnilelsepop: - op = FETCH - 128; - bb_start_pc[bb_n++] = op; - new_bb = true; - break; - /* Other ops changing bb */ - case Bsub1: - case Badd1: - case Bnegate: - case Breturn: - new_bb = true; - break; - case Bswitch: - /* Handled in Bconstant case. */ - emacs_abort (); - break; - case Bconstant2: - op = FETCH2; - FALLTHROUGH; - default: - case Bconstant: - { - if (bytestr_data[pc] != Bswitch) - break; - /* Jump table with following Bswitch. */ - ++pc; - op -= Bconstant; - struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i))) - { - Lisp_Object pc = HASH_VALUE (h, i); - bb_start_pc[bb_n++] = XFIXNUM (pc); - } - bb_start_pc[bb_n++] = pc; - ++pc; - } - } + error ("Compiler context already taken."); + return Qnil; } - - /* Sort and remove possible duplicates. */ - qsort (bb_start_pc, bb_n, sizeof(unsigned), ucmp); - { - unsigned i, j; - for (i = j = 0; i < bb_n; i++) - if (bb_start_pc[i] != bb_start_pc[j]) - bb_start_pc[++j] = bb_start_pc[i]; - bb_n = j + 1; - } - - basic_block_t curr_bb; - for (int i = 0, pc = 0; pc < bytestr_length; pc++) - { - if (i < bb_n && pc == bb_start_pc[i]) - { - ++i; - curr_bb.gcc_bb = - gcc_jit_function_new_block (comp.func, format_string ("bb_%d", i)); - curr_bb.top = NULL; - curr_bb.terminated = false; - } - bb_map[pc] = curr_bb; - } - - xfree (bb_start_pc); - - return bb_map; -} - -static void -init_comp (int opt_level) -{ comp.ctxt = gcc_jit_context_acquire(); if (COMP_DEBUG) @@ -1974,14 +1698,9 @@ init_comp (int opt_level) } - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - opt_level); - /* Do not inline within a compilation unit. */ gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); @@ -2089,1438 +1808,58 @@ init_comp (int opt_level) define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr(); + + return Qt; } -static void -release_comp (void) +DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, + 0, 0, 0, + doc: /* Release the native compiler context. */) + (void) { if (comp.ctxt) gcc_jit_context_release(comp.ctxt); if (logfile) fclose (logfile); + comp.ctxt = NULL; + + return Qt; } -static comp_f_res_t -compile_f (const char *lisp_f_name, const char *c_f_name, - ptrdiff_t bytestr_length, unsigned char *bytestr_data, - EMACS_INT stack_depth, Lisp_Object *vectorp, - ptrdiff_t const_length, Lisp_Object args_template) +DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, + 1, 1, 0, + doc: /* Add limple FUNC to the current compilation context. */) + (Lisp_Object func) { - USE_SAFE_ALLOCA; - gcc_jit_rvalue *res; - comp_f_res_t comp_res = { NULL, 0, 0 }; - ptrdiff_t pc = 0; - gcc_jit_rvalue *args[MAX_POP]; - unsigned op; - unsigned pushhandler_n = 0; - comp_res.min_args = 0; - comp_res.max_args = MANY; - - /* Meta-stack we use to flat the bytecode written for push and pop - Emacs VM.*/ - stack_el_t *stack_base, *stack, *stack_over; - SAFE_NALLOCA (stack_base, sizeof (stack_el_t), stack_depth); - stack = stack_base; - stack_over = stack_base + stack_depth; - - bool parse_args = true; - if (FIXNUMP (args_template)) - { - ptrdiff_t at = XFIXNUM (args_template); - bool rest = (at & 128) != 0; - int mandatory = at & 127; - ptrdiff_t nonrest = at >> 8; - - comp_res.min_args = mandatory; - - if (!rest && nonrest < SUBR_MAX_ARGS) - { - comp_res.max_args = nonrest; - parse_args = false; - } - } - - if (!parse_args) - { - comp.func = - emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); - } - else - { - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "args") }; - comp.func = - gcc_jit_context_new_function (comp.ctxt, - NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_f_name, - 2, - param, - 0); - } - - - gcc_jit_lvalue *meta_stack_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - stack_depth), - "local"); - - for (int i = 0; i < stack_depth; ++i) - stack[i].gcc_lval = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); - - DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); - comp.block = prologue; - - basic_block_t *bb_map = - compute_blocks (bytestr_length, bytestr_data, vectorp, const_length); - - if (!parse_args) - { - for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - } - else - { - /* - nargs will be known at runtime therfore we emit: - - prologue: - local[0] = *args; - ++args; - . - . - . - local[min_args - 1] = *args; - ++args; - local[min_args] = list (nargs - min_args, args); - bb_1: - . - . - . - */ - gcc_jit_lvalue *nargs = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_lvalue *args = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_rvalue *min_args = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - comp_res.min_args); - - for (ptrdiff_t i = 0; i < comp_res.min_args; ++i) - { - PUSH_LVAL (gcc_jit_rvalue_dereference ( - gcc_jit_lvalue_as_rvalue (args), - NULL)); - gcc_jit_block_add_assignment (prologue->gcc_bb, - NULL, - args, - emit_ptr_arithmetic ( - gcc_jit_lvalue_as_rvalue (args), - comp.lisp_obj_ptr_type, - sizeof (Lisp_Object), - comp.one)); - } - - /* - rest arguments - */ - gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - min_args), - gcc_jit_lvalue_as_rvalue (args) }; - - PUSH_RVAL (emit_call ("Flist", comp.lisp_obj_type, 2, list_args)); - } - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); - comp.block = &bb_map[0]; - gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); - - comp.block = NULL; - - while (pc < bytestr_length) - { - enum handlertype type; - - /* If we are changing BB and the last was one wasn't terminated - terminate it with a fall through. */ - if (comp.block && comp.block->gcc_bb != bb_map[pc].gcc_bb && - !comp.block->terminated) - { - gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[pc].gcc_bb); - comp.block->terminated = true; - } - comp.block = &bb_map[pc]; - if (bb_map[pc].top) - stack = bb_map[pc].top; - op = FETCH; - - switch (op) - { - CASE (Bstack_ref1); - goto stack_ref; - CASE (Bstack_ref2); - goto stack_ref; - CASE (Bstack_ref3); - goto stack_ref; - CASE (Bstack_ref4); - goto stack_ref; - CASE (Bstack_ref5); - stack_ref: - PUSH_LVAL ( - stack_base[(stack - stack_base) - (op - Bstack_ref) - 1].gcc_lval); - break; - - CASE (Bstack_ref6); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1].gcc_lval); - break; - - CASE (Bstack_ref7); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1].gcc_lval); - break; - - CASE (Bvarref7); - op = FETCH2; - goto varref; - - CASE (Bvarref); - goto varref_count; - CASE (Bvarref1); - goto varref_count; - CASE (Bvarref2); - goto varref_count; - CASE (Bvarref3); - goto varref_count; - CASE (Bvarref4); - goto varref_count; - CASE (Bvarref5); - varref_count: - op -= Bvarref; - goto varref; - - CASE (Bvarref6); - op = FETCH; - varref: - { - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - break; - } - - CASE (Bvarset); - goto varset_count; - CASE (Bvarset1); - goto varset_count; - CASE (Bvarset2); - goto varset_count; - CASE (Bvarset3); - goto varset_count; - CASE (Bvarset4); - goto varset_count; - CASE (Bvarset5); - varset_count: - op -= Bvarset; - goto varset; - - CASE (Bvarset7); - op = FETCH2; - goto varset; - - CASE (Bvarset6); - op = FETCH; - varset: - { - POP1; - args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - args[2] = nil; - args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - SET_INTERNAL_SET); - res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH_RVAL (res); - } - break; - - CASE (Bvarbind6); - op = FETCH; - goto varbind; - - CASE (Bvarbind7); - op = FETCH2; - goto varbind; - - CASE (Bvarbind); - goto varbind_count; - CASE (Bvarbind1); - goto varbind_count; - CASE (Bvarbind2); - goto varbind_count; - CASE (Bvarbind3); - goto varbind_count; - CASE (Bvarbind4); - goto varbind_count; - CASE (Bvarbind5); - varbind_count: - op -= Bvarbind; - varbind: - { - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - pop (1, &stack, &args[1]); - res = emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - break; - } - - CASE (Bcall6); - op = FETCH; - goto docall; - - CASE (Bcall7); - op = FETCH2; - goto docall; - - CASE (Bcall); - goto docall_count; - CASE (Bcall1); - goto docall_count; - CASE (Bcall2); - goto docall_count; - CASE (Bcall3); - goto docall_count; - CASE (Bcall4); - goto docall_count; - CASE (Bcall5); - docall_count: - op -= Bcall; - docall: - { - res = NULL; - pop (op + 1, &stack, args); - if (stack->const_set && - stack->type == Lisp_Symbol) - { - char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); - if (!strcmp (sym_name, - lisp_f_name)) - { - /* Optimize self calls. */ - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - op, - args + 1); - } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) - { - /* Optimize primitive native calls. */ - emit_comment (format_string ("Calling primitive %s", - sym_name)); - /* FIXME we really should check is a primitive too!! */ - struct Lisp_Subr *subr = - XSUBR ((XSYMBOL (stack->constant)->u.s.function)); - if (subr->max_args == MANY) - { - /* f (nargs, args); */ - args[0] = - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.ptrdiff_type, - op); - args[1] = - gcc_jit_lvalue_get_address ((stack + 1)->gcc_lval, - NULL); - gcc_jit_type *types[] = - { comp.ptrdiff_type, comp.lisp_obj_ptr_type }; - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type ( - comp.ctxt, - NULL, - comp.lisp_obj_type, - 2, types, 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr ( - comp.ctxt, - fn_ptr_type, - subr->function.a0), - 2, args); - } else - { - gcc_jit_type *types[op]; - - for (int i = 0; i < op; i++) - types[i] = comp.lisp_obj_type; - - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type ( - comp.ctxt, - NULL, - comp.lisp_obj_type, - op, - types, - 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr ( - comp.ctxt, - fn_ptr_type, - subr->function.a0), - op, - args + 1); - } - } - } - /* Fall back to regular funcall dispatch mechanism. */ - if (!res) - res = emit_call_n_ref ("Ffuncall", op + 1, stack->gcc_lval); - - PUSH_RVAL (res); - break; - } - - CASE (Bunbind6); - op = FETCH; - goto dounbind; - - CASE (Bunbind7); - op = FETCH2; - goto dounbind; - - CASE (Bunbind); - goto dounbind_count; - CASE (Bunbind1); - goto dounbind_count; - CASE (Bunbind2); - goto dounbind_count; - CASE (Bunbind3); - goto dounbind_count; - CASE (Bunbind4); - goto dounbind_count; - CASE (Bunbind5); - dounbind_count: - op -= Bunbind; - dounbind: - { - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - op); - - emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); - } - break; - - CASE (Bpophandler); - { - /* current_thread->m_handlerlist = - current_thread->m_handlerlist->next; */ - gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); - - gcc_jit_block_add_assignment( - comp.block->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (m_handlerlist), - NULL, - comp.handler_next_field))); - break; - } - - CASE (Bpushconditioncase); /* New in 24.4. */ - type = CONDITION_CASE; - goto pushhandler; - - CASE (Bpushcatch); /* New in 24.4. */ - type = CATCHER; - pushhandler: - { - /* struct handler *c = push_handler (POP, type); */ - int handler_pc = FETCH2; - gcc_jit_lvalue *c = - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("c_%u", - pushhandler_n)); - POP1; - args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - type); - gcc_jit_block_add_assignment ( - comp.block->gcc_bb, - NULL, - c, - emit_call ("push_handler", comp.handler_ptr_type, 2, args)); - - args[0] = - gcc_jit_lvalue_get_address ( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_jmp_field), - NULL); -#ifdef HAVE__SETJMP - res = emit_call ("_setjmp", comp.int_type, 1, args); -#else - res = emit_call ("setjmp", comp.int_type, 1, args); -#endif - basic_block_t *push_h_val_block; - SAFE_ALLOCA_BLOCK (push_h_val_block, - comp.func, - format_string ("push_h_val_%u", - pushhandler_n)); - - emit_cond_jump (res, push_h_val_block, &bb_map[pc]); - - stack_el_t *stack_to_restore = stack; - /* This emit the handler part. */ - - basic_block_t *bb_orig = comp.block; - comp.block = push_h_val_block; - /* current_thread->m_handlerlist = c->next; */ - gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); - /* PUSH (c->val); */ - PUSH_LVAL (gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field)); - bb_map[handler_pc].top = stack; - comp.block = bb_orig; - - gcc_jit_block_end_with_jump (push_h_val_block->gcc_bb, NULL, - bb_map[handler_pc].gcc_bb); - - stack = stack_to_restore; - ++pushhandler_n; - } - break; - - CASE_CALL_N (nth, 2); - CASE_CALL_N (symbolp, 1); - - CASE (Bconsp); - POP1; - res = emit_cast (comp.bool_type, - emit_CONSP (args[0])); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE_CALL_N (stringp, 1); - CASE_CALL_N (listp, 1); - CASE_CALL_N (eq, 2); - CASE_CALL_N (memq, 1); - CASE_CALL_N (not, 1); - - case Bcar: - POP1; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.car, - 1, args); - PUSH_RVAL (res); - break; - - case Bcdr: - POP1; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.cdr, - 1, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (cons, 2); - - CASE (BlistN); - op = FETCH; - goto make_list; - - CASE (Blist1); - goto make_list_count; - CASE (Blist2); - goto make_list_count; - CASE (Blist3); - goto make_list_count; - CASE (Blist4); - make_list_count: - op = op - Blist1; - make_list: - { - POP1; - args[1] = nil; - res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - for (int i = 0; i < op; ++i) - { - POP2; - res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - } - break; - } - - CASE_CALL_N (length, 1); - CASE_CALL_N (aref, 2); - CASE_CALL_N (aset, 3); - CASE_CALL_N (symbol_value, 1); - CASE_CALL_N (symbol_function, 1); - CASE_CALL_N (set, 2); - CASE_CALL_N (fset, 2); - CASE_CALL_N (get, 2); - CASE_CALL_N (substring, 3); - - CASE (Bconcat2); - EMIT_CALL_N_REF ("Fconcat", 2); - break; - CASE (Bconcat3); - EMIT_CALL_N_REF ("Fconcat", 3); - break; - CASE (Bconcat4); - EMIT_CALL_N_REF ("Fconcat", 4); - break; - CASE (BconcatN); - op = FETCH; - EMIT_CALL_N_REF ("Fconcat", op); - break; - - CASE (Bsub1); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (sub1_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum)), - sub1_inline_block, - sub1_fcall_block); - - gcc_jit_rvalue *sub1_inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.emacs_int_type, - tos_as_num, - comp.one); - - basic_block_t *bb_orig = comp.block; - - comp.block = sub1_inline_block; - emit_assign_to_stack_slot (sub1_inline_block, - &TOS, - emit_make_fixnum (sub1_inline_res)); - comp.block = sub1_fcall_block; - POP1; - res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - - gcc_jit_block_end_with_jump (sub1_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - - break; - CASE (Badd1); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (add1_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_positive_fixnum)), - add1_inline_block, - add1_fcall_block); - - gcc_jit_rvalue *add1_inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tos_as_num, - comp.one); - - basic_block_t *bb_orig = comp.block; - comp.block = add1_inline_block; - emit_assign_to_stack_slot(add1_inline_block, - &TOS, - emit_make_fixnum (add1_inline_res)); - comp.block = add1_fcall_block; - POP1; - res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - - gcc_jit_block_end_with_jump (add1_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (add1_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - break; - - CASE (Beqlsign); - EMIT_ARITHCOMPARE (ARITH_EQUAL); - break; - - CASE (Bgtr); - EMIT_ARITHCOMPARE (ARITH_GRTR); - break; - - CASE (Blss); - EMIT_ARITHCOMPARE (ARITH_LESS); - break; - - CASE (Bleq); - EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); - break; - - CASE (Bgeq); - EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); - break; - - CASE (Bdiff); - EMIT_CALL_N_REF ("Fminus", 2); - break; - - CASE (Bnegate); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (- XFIXNUM (TOP)) - : Fminus (1, &TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (negate_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum)), - negate_inline_block, - negate_fcall_block); - - gcc_jit_rvalue *negate_inline_res = - gcc_jit_context_new_unary_op (comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_MINUS, - comp.emacs_int_type, - tos_as_num); - - basic_block_t *bb_orig = comp.block; - - comp.block = negate_inline_block; - emit_assign_to_stack_slot (negate_inline_block, - &TOS, - emit_make_fixnum (negate_inline_res)); - comp.block = negate_fcall_block; - EMIT_CALL_N_REF ("Fminus", 1); - - gcc_jit_block_end_with_jump (negate_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (negate_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - break; - CASE (Bplus); - EMIT_CALL_N_REF ("Fplus", 2); - break; - CASE (Bmax); - EMIT_CALL_N_REF ("Fmax", 2); - break; - CASE (Bmin); - EMIT_CALL_N_REF ("Fmin", 2); - break; - CASE (Bmult); - EMIT_CALL_N_REF ("Ftimes", 2); - break; - CASE (Bpoint); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - PT); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (goto_char, 1); - - CASE (Binsert); - EMIT_CALL_N_REF ("Finsert", 1); - break; - - CASE (Bpoint_max); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - ZV); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE (Bpoint_min); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - BEGV); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (char_after, 1); - CASE_CALL_N (following_char, 0); - - CASE (Bpreceding_char); - res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (current_column, 0); - - CASE (Bindent_to); - POP1; - args[1] = nil; - res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (eolp, 0); - CASE_CALL_N (eobp, 0); - CASE_CALL_N (bolp, 0); - CASE_CALL_N (bobp, 0); - CASE_CALL_N (current_buffer, 0); - CASE_CALL_N (set_buffer, 1); - - CASE (Bsave_current_buffer); /* Obsolete since ??. */ - goto save_current; - CASE (Bsave_current_buffer_1); - save_current: - emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); - break; - - CASE (Binteractive_p); /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (intern ("interactive-p"))); - res = emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (forward_char, 1); - CASE_CALL_N (forward_word, 1); - CASE_CALL_N (skip_chars_forward, 2); - CASE_CALL_N (skip_chars_backward, 2); - CASE_CALL_N (forward_line, 1); - CASE_CALL_N (char_syntax, 1); - CASE_CALL_N (buffer_substring, 2); - CASE_CALL_N (delete_region, 2); - CASE_CALL_N (narrow_to_region, 2); - CASE_CALL_N (widen, 0); - CASE_CALL_N (end_of_line, 1); - - CASE (Bconstant2); - op = FETCH2; - goto do_constant; - - CASE (Bgoto); - op = FETCH2; - gcc_jit_block_end_with_jump (comp.block->gcc_bb, - NULL, - bb_map[op].gcc_bb); - comp.block->terminated = true; - bb_map[op].top = stack; - break; - - CASE (Bgotoifnil); - op = FETCH2; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (Bgotoifnonnil); - op = FETCH2; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (Bgotoifnilelsepop); - op = FETCH2; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (Bgotoifnonnilelsepop); - op = FETCH2; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (Breturn); - POP1; - gcc_jit_block_end_with_return(comp.block->gcc_bb, - NULL, - args[0]); - comp.block->terminated = true; - break; - - CASE (Bdiscard); - DISCARD (1); - break; - - CASE (Bdup); - PUSH_LVAL (TOS.gcc_lval); - break; - - CASE (Bsave_excursion); - res = emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); - break; - - CASE (Bsave_window_excursion); /* Obsolete since 24.1. */ - EMIT_CALL_N ("helper_save_window_excursion", 1); - break; - - CASE (Bsave_restriction); - args[0] = emit_lisp_obj_from_ptr (save_restriction_restore); - args[1] = emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL); - emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); - break; - - CASE (Bcatch); /* Obsolete since 24.4. */ - POP2; - args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (eval_sub); - emit_call ("internal_catch", comp.void_ptr_type, 3, args); - break; - - CASE (Bunwind_protect); /* FIXME: avoid closure for lexbind. */ - POP1; - emit_call ("helper_unwind_protect", comp.void_type, 1, args); - break; - - CASE (Bcondition_case); /* Obsolete since 24.4. */ - POP3; - emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); - break; - - CASE (Btemp_output_buffer_setup); /* Obsolete since 24.1. */ - EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); - break; - - CASE (Btemp_output_buffer_show); /* Obsolete since 24.1. */ - POP2; - emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); - PUSH_RVAL (args[0]); - emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); - - break; - CASE (Bunbind_all); /* Obsolete. Never used. */ - /* To unbind back to the beginning of this frame. Not used yet, - but will be needed for tail-recursion elimination. */ - error ("Bunbind_all not supported"); - break; - - CASE_CALL_N (set_marker, 3); - CASE_CALL_N (match_beginning, 1); - CASE_CALL_N (match_end, 1); - CASE_CALL_N (upcase, 1); - CASE_CALL_N (downcase, 1); - - CASE (Bstringeqlsign); - EMIT_CALL_N ("Fstring_equal", 2); - break; - - CASE (Bstringlss); - EMIT_CALL_N ("Fstring_lessp", 2); - break; - - CASE_CALL_N (equal, 2); - CASE_CALL_N (nthcdr, 2); - CASE_CALL_N (elt, 2); - CASE_CALL_N (member, 2); - CASE_CALL_N (assq, 2); - - case Bsetcar: - POP2; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcar, - 2, args); - PUSH_RVAL (res); - break; - - case Bsetcdr: - POP2; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcdr, - 2, args); - PUSH_RVAL (res); - break; - - CASE (Bcar_safe); - EMIT_CALL_N ("CAR_SAFE", 1); - break; - - CASE (Bcdr_safe); - EMIT_CALL_N ("CDR_SAFE", 1); - break; - - CASE (Bnconc); - EMIT_CALL_N_REF ("Fnconc", 2); - break; - - CASE (Bquo); - EMIT_CALL_N_REF ("Fquo", 2); - break; - - CASE_CALL_N (rem, 2); - - CASE (Bnumberp); - POP1; - res = emit_NUMBERP (args[0]); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE (Bintegerp); - POP1; - res = emit_INTEGERP(args[0]); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE (BRgoto); - op = FETCH - 128; - op += pc; - gcc_jit_block_end_with_jump (comp.block->gcc_bb, - NULL, - bb_map[op].gcc_bb); - comp.block->terminated = true; - bb_map[op].top = stack; - break; - - CASE (BRgotoifnil); - op = FETCH - 128; - op += pc; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (BRgotoifnonnil); - op = FETCH - 128; - op += pc; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (BRgotoifnilelsepop); - op = FETCH - 128; - op += pc; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (BRgotoifnonnilelsepop); - op = FETCH - 128; - op += pc; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (BinsertN); - op = FETCH; - EMIT_CALL_N_REF ("Finsert", op); - break; - - CASE (Bstack_set); - /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ - op = FETCH; - POP1; - if (op > 0) - emit_assign_to_stack_slot (comp.block, stack - op, args[0]); - break; - - CASE (Bstack_set2); - op = FETCH2; - POP1; - emit_assign_to_stack_slot (comp.block, stack - op, args[0]); - break; - - CASE (BdiscardN); - op = FETCH; - if (op & 0x80) - { - op &= 0x7F; - POP1; - emit_assign_to_stack_slot (comp.block, stack - op - 1, args[0]); - } - - DISCARD (op); - break; - CASE (Bswitch); - /* The cases of Bswitch that we handle (which in theory is - all of them) are done in Bconstant, below. This is done - due to a design issue with Bswitch -- it should have - taken a constant pool index inline, but instead looks for - a constant on the stack. */ - goto fail; - break; - - default: - CASE (Bconstant); - { - if (op < Bconstant || op > Bconstant + const_length) - goto fail; - - op -= Bconstant; - do_constant: - - /* See the Bswitch case for commentary. */ - if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) - { - gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (vectorp[op]); - PUSH_RVAL (c); - TOS.type = XTYPE (vectorp[op]); - if (TOS.type == Lisp_Symbol) - { - /* Store the symbol value for later use is used while - optimizing native and self calls. */ - TOS.constant = vectorp[op]; - TOS.const_set = true; - } - break; - } - - /* Jump table with following Bswitch. */ - ++pc; - - struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); - POP1; - basic_block_t *jump_block; - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i))) - { - SAFE_ALLOCA_BLOCK (jump_block, - comp.func, - format_string ("jump_t_%ld", - i)); - ptrdiff_t target_pc = XFIXNUM (HASH_VALUE (h, i)); - gcc_jit_rvalue *val = - emit_lisp_obj_from_ptr (HASH_KEY (h, i)); - emit_cond_jump (emit_EQ (args[0], val), &bb_map[target_pc], - jump_block); - comp.block = jump_block; - } - - break; - } - } - } - - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); - comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); - - goto exit; - - fail: - error ("Something went wrong"); - - exit: - xfree (bb_map); - SAFE_FREE (); - return comp_res; + return Qt; } -void -emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, int opt_level, bool dump_asm) +DEFUN ("comp-compile-ctxt", Fcomp_compile_ctxt, Scomp_compile_ctxt, + 0, 1, 0, + doc: /* Compile as native code the current context. */) + (Lisp_Object disassemble) { - init_comp (opt_level); - Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); - CHECK_STRING (bytestr); - - if (STRING_MULTIBYTE (bytestr)) - /* BYTESTR must have been produced by Emacs 20.2 or the earlier - because they produced a raw 8-bit string for byte-code and now - such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must - convert them back to the originally intended unibyte form. */ - bytestr = Fstring_as_unibyte (bytestr); - - ptrdiff_t bytestr_length = SBYTES (bytestr); - - Lisp_Object vector = AREF (func, COMPILED_CONSTANTS); - CHECK_VECTOR (vector); - Lisp_Object *vectorp = XVECTOR (vector)->contents; - - Lisp_Object maxdepth = AREF (func, COMPILED_STACK_DEPTH); - CHECK_FIXNAT (maxdepth); - - /* Gcc doesn't like being interrupted. */ - sigset_t oldset; - block_atimers (&oldset); - - comp_f_res_t comp_res = compile_f (lisp_f_name, c_f_name, bytestr_length, - SDATA (bytestr), XFIXNAT (maxdepth) + 1, - vectorp, ASIZE (vector), - AREF (func, COMPILED_ARGLIST)); - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); - eassert (x->s.function.a0); - x->s.min_args = comp_res.min_args; - x->s.max_args = comp_res.max_args; - x->s.symbol_name = lisp_f_name; - defsubr(x); - - if (dump_asm) - { - gcc_jit_context_compile_to_file (comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - DISASS_FILE_NAME); - } - unblock_atimers (&oldset); - release_comp (); -} - -DEFUN ("native-compile", Fnative_compile, Snative_compile, - 1, 3, 0, - doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ - (Lisp_Object func, Lisp_Object speed, Lisp_Object disassemble) -{ - static char c_f_name[MAX_FUN_NAME]; - char *lisp_f_name; - - if (!SYMBOLP (func)) - error ("Not a symbol."); - - lisp_f_name = (char *) SDATA (SYMBOL_NAME (func)); - - int res = snprintf (c_f_name, MAX_FUN_NAME, "Fnative_comp_%s", lisp_f_name); - - if (res >= MAX_FUN_NAME) - error ("Function name too long"); - - /* FIXME how many other characters are not allowed in C? - This will introduce name clashs too. */ - char *c = c_f_name; - while (*c) - { - if (*c == '-' || - *c == '+') - *c = '_'; - ++c; - } - - func = indirect_function (func); - if (!COMPILEDP (func)) - error ("Not a byte-compiled function"); - - if (speed != Qnil && - (!FIXNUMP (speed) || - !(XFIXNUM (speed) >= 0 && - XFIXNUM (speed) <= 3))) - error ("opt-level must be number between 0 and 3"); - - int opt_level; - if (speed == Qnil) - opt_level = DEFAULT_SPEED; - else - opt_level = XFIXNUM (speed); - - emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, - !NILP (disassemble)); - - if (!NILP (disassemble)) - { - FILE *fd; - Lisp_Object str; - - if ((fd = fopen (DISASS_FILE_NAME, "r"))) - { - fseek (fd , 0L, SEEK_END); - long int size = ftell (fd); - fseek (fd , 0L, SEEK_SET); - char *buffer = xmalloc (size + 1); - ptrdiff_t nread = fread (buffer, 1, size, fd); - if (nread > 0) - { - size = nread; - buffer[size] = '\0'; - str = make_string (buffer, size); - fclose (fd); - } - else - str = empty_unibyte_string; - xfree (buffer); - return str; - } - else - { - error ("disassemble file could not be found"); - } - } - - return Qnil; + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + comp_speed); + return Qt; } void syms_of_comp (void) { - defsubr (&Snative_compile); + defsubr (&Scomp_init_ctxt); + defsubr (&Scomp_release_ctxt); + defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); + + DEFVAR_INT ("comp-speed", comp_speed, + doc: /* From 0 to 3. */); + comp_speed = DEFAULT_SPEED; + } /******************************************************************************/ diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 421f77008a4..c6ee5b76855 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -103,6 +103,11 @@ (defun comp-tests-varset-f () (setq comp-tests-var1 55)) (comp-test-compile #'comp-tests-varset-f) +((byte-constant 55 . 1) + (byte-dup . 0) + (byte-varset comp-tests-var1 . 0) + (byte-return . 0)) + (comp-tests-varset-f) (should (= comp-tests-var1 55))) From a09816558395ee289897561627ac44fdf1775a6b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 11:37:17 +0200 Subject: [PATCH 0163/1452] calling C --- lisp/emacs-lisp/comp.el | 35 ++++++++++++++++++++++++----------- src/comp.c | 8 +++++--- 2 files changed, 29 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fda4dc437b6..b6e3e010323 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -23,7 +23,9 @@ ;;; Code: (require 'bytecomp) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) +(require 'cl-extra) +(require 'subr-x) (defgroup comp nil "Emacs Lisp native compiler." @@ -102,6 +104,11 @@ (setf (comp-func-ir func) byte-compile-lap-output) func) +(declare-function comp-init-ctxt "comp.c") +(declare-function comp-release-ctxt "comp.c") +(declare-function comp-add-func-to-ctxt "comp.c") +(declare-function comp-compile-and-load-ctxt "comp.c") + ;; (defun comp-opt-call (inst) ;; "Optimize if possible a side-effect-free call in INST." ;; (cl-destructuring-bind (_ f &rest args) inst @@ -141,7 +148,7 @@ (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :type (alist-get (second src-slot) + :type (alist-get (cadr src-slot) comp-known-ret-types))) (push (list '=call (comp-slot) src-slot) comp-limple)) @@ -187,11 +194,11 @@ VAL is known at compile time." ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref - (comp-push-call `(call Fsymbol_value ,(second inst)))) + (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ;; ('byte-varset - ;; (comp-push-call `(call Fsymbol_value ,(second inst)))) + ;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ('byte-constant - (comp-push-const (second inst))) + (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus @@ -246,18 +253,24 @@ VAL is known at compile time." func)) (defun native-compile (fun) - "FUN is the function definition to be compiled to native code." + "FUN is the function definition to be compiled into native code." (unless lexical-binding (error "Can't compile a non lexical binded function")) (if-let ((f (symbol-function fun))) (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) - (cl-loop with func = (make-comp-func :symbol-name fun - :func f) - for pass in comp-passes - do (funcall pass func) - finally return func)) + (let ((func (make-comp-func :symbol-name fun + :func f))) + (mapc (lambda (pass) + (funcall pass func)) + comp-passes) + ;; Once we have the final LIMPLE we jump into C. + (when (boundp #'comp-init-ctxt) + (comp-init-ctxt) + (comp-add-func-to-ctxt func) + (comp-compile-and-load-ctxt) + (comp-release-ctxt)))) (error "Trying to native compile not a function"))) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index fb1fa79d12d..89d057217dc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1835,9 +1835,11 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, return Qt; } -DEFUN ("comp-compile-ctxt", Fcomp_compile_ctxt, Scomp_compile_ctxt, +DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, + Scomp_compile_and_load_ctxt, 0, 1, 0, - doc: /* Compile as native code the current context. */) + doc: /* Compile as native code the current context and load its + functions. */) (Lisp_Object disassemble) { gcc_jit_context_set_int_option (comp.ctxt, @@ -1852,7 +1854,7 @@ syms_of_comp (void) defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); - defsubr (&Scomp_compile_ctxt); + defsubr (&Scomp_compile_and_load_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); From 34e0be815db9c9ad8f8b98b52824aa3cf15a3ccc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 12:11:34 +0200 Subject: [PATCH 0164/1452] add comp-c-func-name --- lisp/emacs-lisp/comp.el | 40 +++++++++++++++++++++++++++++----------- src/comp.c | 5 +++-- 2 files changed, 32 insertions(+), 13 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6e3e010323..90713ec77b6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,11 +54,13 @@ (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." (symbol-name nil - :documentation "Function symbol's name") + :documentation "Function symbol's name") + (c-func-name nil :type 'string + :documentation "The function name in the native world") (func nil - :documentation "Original form") + :documentation "Original form") (byte-func nil - :documentation "Byte compiled version") + :documentation "Byte compiled version") (ir nil :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) @@ -86,6 +88,21 @@ (frame nil :type 'vector :documentation "Meta-stack used to flat LAP")) +(defun comp-c-func-name (symbol-function) + "Given SYMBOL-FUNCTION return a name suitable for the native code." + ;; Unfortunatelly not all symbol names are valid as C function names... + (let* ((orig-name (symbol-name symbol-function)) + (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) + for j from 0 by 2 + for i across orig-name + for byte = (format "%x" i) + do (aset str j (aref byte 0)) + do (aset str (1+ j) (aref byte 1)) + finally return str)) + (human-readable (replace-regexp-in-string + (rx (not (any "a-z"))) "" orig-name))) + (concat "F" crypted "_" human-readable))) + (defun comp-decrypt-lambda-list (x) "Decript lambda list X." (make-comp-args :rest (not (= (logand x 128) 0)) @@ -255,23 +272,24 @@ VAL is known at compile time." (defun native-compile (fun) "FUN is the function definition to be compiled into native code." (unless lexical-binding - (error "Can't compile a non lexical binded function")) + (error "Can't native compile a non lexical scoped function")) (if-let ((f (symbol-function fun))) (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) (let ((func (make-comp-func :symbol-name fun - :func f))) + :func f + :c-func-name (comp-c-func-name fun)))) (mapc (lambda (pass) (funcall pass func)) comp-passes) ;; Once we have the final LIMPLE we jump into C. - (when (boundp #'comp-init-ctxt) - (comp-init-ctxt) - (comp-add-func-to-ctxt func) - (comp-compile-and-load-ctxt) - (comp-release-ctxt)))) - (error "Trying to native compile not a function"))) + (when t ;(boundp #'comp-init-ctxt) + (comp-init-ctxt) + (comp-add-func-to-ctxt func) + (comp-compile-and-load-ctxt) + (comp-release-ctxt)))) + (error "Trying to native compile something not a function"))) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index 89d057217dc..ed7aef0aa9b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -35,8 +35,6 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 -#define DISASS_FILE_NAME "emacs-asm.s" - #define SAFE_ALLOCA_BLOCK(ptr, func, name) \ do { \ (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ @@ -1832,6 +1830,9 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, doc: /* Add limple FUNC to the current compilation context. */) (Lisp_Object func) { + char *c_name = + (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func)); + return Qt; } From ee04ef4f6f999250b714384285a76141510564ad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 14:13:38 +0200 Subject: [PATCH 0165/1452] comment out unused functions --- src/comp.c | 382 ++++++++++++++++++++++++++--------------------------- 1 file changed, 191 insertions(+), 191 deletions(-) diff --git a/src/comp.c b/src/comp.c index ed7aef0aa9b..e176967da7a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -230,17 +230,17 @@ emit_comment (const char *str) /* Assignments to the meta-stack slots should be emitted usign this to always */ /* reset annotation fields. */ -static void -emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, - gcc_jit_rvalue *val) -{ - gcc_jit_block_add_assignment (block->gcc_bb, - NULL, - slot->gcc_lval, - val); - slot->type = -1; - slot->const_set = false; -} +/* static void */ +/* emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, */ +/* gcc_jit_rvalue *val) */ +/* { */ +/* gcc_jit_block_add_assignment (block->gcc_bb, */ +/* NULL, */ +/* slot->gcc_lval, */ +/* val); */ +/* slot->type = -1; */ +/* slot->const_set = false; */ +/* } */ /* Declare a function with all args being Lisp_Object and returning a Lisp_Object. */ @@ -305,8 +305,8 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - emit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, - true); + emit_func_declare (f_name, ret_type, nargs, args, + GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); } @@ -352,20 +352,20 @@ emit_cond_jump (gcc_jit_rvalue *test, /* Close current basic block emitting a comparison between two rval. */ -static gcc_jit_rvalue * -emit_comparison_jump (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - basic_block_t *then_target, basic_block_t *else_target) -{ - gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, - NULL, - op, - a, b); +/* static gcc_jit_rvalue * */ +/* emit_comparison_jump (enum gcc_jit_comparison op, */ +/* gcc_jit_rvalue *a, gcc_jit_rvalue *b, */ +/* basic_block_t *then_target, basic_block_t *else_target) */ +/* { */ +/* gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, */ +/* NULL, */ +/* op, */ +/* a, b); */ - emit_cond_jump (test, then_target, else_target); +/* emit_cond_jump (test, then_target, else_target); */ - return test; -} +/* return test; */ +/* } */ static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) @@ -399,34 +399,34 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ -static gcc_jit_rvalue * -emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, - int size_of_ptr_ref, gcc_jit_rvalue *i) -{ - emit_comment ("ptr_arithmetic"); +/* static gcc_jit_rvalue * */ +/* emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, */ +/* int size_of_ptr_ref, gcc_jit_rvalue *i) */ +/* { */ +/* emit_comment ("ptr_arithmetic"); */ - gcc_jit_rvalue *offset = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MULT, - comp.uintptr_type, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.uintptr_type, - size_of_ptr_ref), - emit_cast (comp.uintptr_type, i)); +/* gcc_jit_rvalue *offset = */ +/* gcc_jit_context_new_binary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_MULT, */ +/* comp.uintptr_type, */ +/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ +/* comp.uintptr_type, */ +/* size_of_ptr_ref), */ +/* emit_cast (comp.uintptr_type, i)); */ - return - emit_cast ( - ptr_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.uintptr_type, - emit_cast (comp.uintptr_type, ptr), - offset)); -} +/* return */ +/* emit_cast ( */ +/* ptr_type, */ +/* gcc_jit_context_new_binary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_PLUS, */ +/* comp.uintptr_type, */ +/* emit_cast (comp.uintptr_type, ptr), */ +/* offset)); */ +/* } */ INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) @@ -575,155 +575,155 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } -static gcc_jit_rvalue * -emit_FLOATP (gcc_jit_rvalue *obj) -{ - emit_comment ("FLOATP"); +/* static gcc_jit_rvalue * */ +/* emit_FLOATP (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("FLOATP"); */ - return emit_TAGGEDP (obj, Lisp_Float); -} +/* return emit_TAGGEDP (obj, Lisp_Float); */ +/* } */ -static gcc_jit_rvalue * -emit_BIGNUMP (gcc_jit_rvalue *obj) -{ - /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ - emit_comment ("BIGNUMP"); +/* static gcc_jit_rvalue * */ +/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ +/* { */ +/* /\* PSEUDOVECTORP (x, PVEC_BIGNUM); *\/ */ +/* emit_comment ("BIGNUMP"); */ - gcc_jit_rvalue *args[2] = { - obj, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - PVEC_BIGNUM) }; +/* gcc_jit_rvalue *args[2] = { */ +/* obj, */ +/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ +/* comp.int_type, */ +/* PVEC_BIGNUM) }; */ - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.pseudovectorp, - 2, - args); -} +/* return gcc_jit_context_new_call (comp.ctxt, */ +/* NULL, */ +/* comp.pseudovectorp, */ +/* 2, */ +/* args); */ +/* } */ -static gcc_jit_rvalue * -emit_FIXNUMP (gcc_jit_rvalue *obj) -{ - /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) - & ((1 << INTTYPEBITS) - 1))) */ - emit_comment ("FIXNUMP"); +/* static gcc_jit_rvalue * */ +/* emit_FIXNUMP (gcc_jit_rvalue *obj) */ +/* { */ +/* /\* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) */ +/* - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) */ +/* & ((1 << INTTYPEBITS) - 1))) *\/ */ +/* emit_comment ("FIXNUMP"); */ - gcc_jit_rvalue *sh_res = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, - (USE_LSB_TAG ? 0 : FIXNUM_BITS))); +/* gcc_jit_rvalue *sh_res = */ +/* gcc_jit_context_new_binary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_RSHIFT, */ +/* comp.emacs_int_type, */ +/* emit_XLI (obj), */ +/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ +/* comp.emacs_int_type, */ +/* (USE_LSB_TAG ? 0 : FIXNUM_BITS))); */ - gcc_jit_rvalue *minus_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_type, - emit_cast (comp.unsigned_type, sh_res), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - (Lisp_Int0 >> !USE_LSB_TAG))); +/* gcc_jit_rvalue *minus_res = */ +/* gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_MINUS, */ +/* comp.unsigned_type, */ +/* emit_cast (comp.unsigned_type, sh_res), */ +/* gcc_jit_context_new_rvalue_from_int ( */ +/* comp.ctxt, */ +/* comp.unsigned_type, */ +/* (Lisp_Int0 >> !USE_LSB_TAG))); */ - gcc_jit_rvalue *res = - gcc_jit_context_new_unary_op ( - comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_LOGICAL_NEGATE, - comp.int_type, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.unsigned_type, - minus_res, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - ((1 << INTTYPEBITS) - 1)))); +/* gcc_jit_rvalue *res = */ +/* gcc_jit_context_new_unary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_UNARY_OP_LOGICAL_NEGATE, */ +/* comp.int_type, */ +/* gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_BITWISE_AND, */ +/* comp.unsigned_type, */ +/* minus_res, */ +/* gcc_jit_context_new_rvalue_from_int ( */ +/* comp.ctxt, */ +/* comp.unsigned_type, */ +/* ((1 << INTTYPEBITS) - 1)))); */ - return res; -} +/* return res; */ +/* } */ -static gcc_jit_rvalue * -emit_XFIXNUM (gcc_jit_rvalue *obj) -{ - emit_comment ("XFIXNUM"); +/* static gcc_jit_rvalue * */ +/* emit_XFIXNUM (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("XFIXNUM"); */ - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - comp.inttypebits); -} +/* return gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_RSHIFT, */ +/* comp.emacs_int_type, */ +/* emit_XLI (obj), */ +/* comp.inttypebits); */ +/* } */ -static gcc_jit_rvalue * -emit_INTEGERP (gcc_jit_rvalue *obj) -{ - emit_comment ("INTEGERP"); +/* static gcc_jit_rvalue * */ +/* emit_INTEGERP (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("INTEGERP"); */ - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (obj)), - emit_BIGNUMP (obj)); -} +/* return gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ +/* comp.bool_type, */ +/* emit_cast (comp.bool_type, */ +/* emit_FIXNUMP (obj)), */ +/* emit_BIGNUMP (obj)); */ +/* } */ -static gcc_jit_rvalue * -emit_NUMBERP (gcc_jit_rvalue *obj) -{ - emit_comment ("NUMBERP"); +/* static gcc_jit_rvalue * */ +/* emit_NUMBERP (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("NUMBERP"); */ - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_INTEGERP(obj), - emit_cast (comp.bool_type, - emit_FLOATP (obj))); -} +/* return gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ +/* comp.bool_type, */ +/* emit_INTEGERP(obj), */ +/* emit_cast (comp.bool_type, */ +/* emit_FLOATP (obj))); */ +/* } */ -static gcc_jit_rvalue * -emit_make_fixnum (gcc_jit_rvalue *obj) -{ - emit_comment ("make_fixnum"); +/* static gcc_jit_rvalue * */ +/* emit_make_fixnum (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("make_fixnum"); */ - gcc_jit_rvalue *tmp = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - obj, - comp.inttypebits); +/* gcc_jit_rvalue *tmp = */ +/* gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_LSHIFT, */ +/* comp.emacs_int_type, */ +/* obj, */ +/* comp.inttypebits); */ - tmp = gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tmp, - comp.lisp_int0); +/* tmp = gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_PLUS, */ +/* comp.emacs_int_type, */ +/* tmp, */ +/* comp.lisp_int0); */ - gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - "lisp_obj_fixnum"); +/* gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, */ +/* NULL, */ +/* comp.lisp_obj_type, */ +/* "lisp_obj_fixnum"); */ - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - emit_lval_XLI (res), - tmp); +/* gcc_jit_block_add_assignment (comp.block->gcc_bb, */ +/* NULL, */ +/* emit_lval_XLI (res), */ +/* tmp); */ - return gcc_jit_lvalue_as_rvalue (res); -} +/* return gcc_jit_lvalue_as_rvalue (res); */ +/* } */ /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * @@ -943,19 +943,19 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } -static gcc_jit_rvalue * -emit_call_n_ref (const char *f_name, unsigned nargs, - gcc_jit_lvalue *base_arg) -{ - gcc_jit_rvalue *args[] = - { gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (f_name, comp.lisp_obj_type, 2, args); -} +/* static gcc_jit_rvalue * */ +/* emit_call_n_ref (const char *f_name, unsigned nargs, */ +/* gcc_jit_lvalue *base_arg) */ +/* { */ +/* gcc_jit_rvalue *args[] = */ +/* { gcc_jit_context_new_rvalue_from_int(comp.ctxt, */ +/* comp.ptrdiff_type, */ +/* nargs), */ +/* gcc_jit_lvalue_get_address (base_arg, NULL) }; */ +/* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ +/* } */ -/* struct Lisp_Cons definition. */ +/* /\* struct Lisp_Cons definition. *\/ */ static void define_lisp_cons (void) From c51b7fe2c881335c9958f75d205859d434cc6de4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 15:29:32 +0200 Subject: [PATCH 0166/1452] start compilation C side --- lisp/emacs-lisp/comp.el | 35 ++++-- src/comp.c | 248 +++++++++++++++++++++++----------------- 2 files changed, 166 insertions(+), 117 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 90713ec77b6..963c22dc590 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -49,7 +49,14 @@ ) (cl-defstruct comp-args - mandatory nonrest rest) + (min nil :type number + :documentation "Minimum number of arguments allowed") + (max nil + :documentation "Maximum number of arguments allowed +To be used when ncall-conv is nil.") + (ncall-conv nil :type boolean + :documentation "If t the signature is: +(ptrdiff_t nargs, Lisp_Object *args)")) (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." @@ -64,6 +71,7 @@ (ir nil :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) + (frame-size nil :type 'number) (limple-cnt -1 :type 'number :documentation "Counter to create ssa limple vars")) @@ -105,9 +113,15 @@ (defun comp-decrypt-lambda-list (x) "Decript lambda list X." - (make-comp-args :rest (not (= (logand x 128) 0)) - :mandatory (logand x 127) - :nonrest (ash x -8))) + (let ((rest (not (= (logand x 128) 0))) + (mandatory (logand x 127)) + (nonrest (ash x -8))) + (if (and (null rest) + (< nonrest 9)) ;; SUBR_MAX_ARGS + (make-comp-args :min mandatory + :max nonrest) + (make-comp-args :min mandatory + :ncall-conv t)))) (defun comp-recuparate-lap (func) "Byte compile and recuparate LAP rapresentation for FUNC." @@ -119,6 +133,7 @@ (setf (comp-func-args func) (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-ir func) byte-compile-lap-output) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func) (declare-function comp-init-ctxt "comp.c") @@ -242,12 +257,13 @@ VAL is known at compile time." ('byte-list4 (comp-limplify-listn 4)) ('byte-return + (push (list 'return (comp-slot)) comp-limple) `(return ,(comp-slot))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify (func) "Given FUNC and return LIMPLE." - (let* ((frame-size (aref (comp-func-byte-func func) 3)) + (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-frame (make-comp-limple-frame :sp -1 @@ -284,11 +300,10 @@ VAL is known at compile time." (funcall pass func)) comp-passes) ;; Once we have the final LIMPLE we jump into C. - (when t ;(boundp #'comp-init-ctxt) - (comp-init-ctxt) - (comp-add-func-to-ctxt func) - (comp-compile-and-load-ctxt) - (comp-release-ctxt)))) + (comp-init-ctxt) + (comp-add-func-to-ctxt func) + (comp-compile-and-load-ctxt) + (comp-release-ctxt))) (error "Trying to native compile something not a function"))) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index e176967da7a..6f5863b7f7e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -35,34 +35,11 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 -#define SAFE_ALLOCA_BLOCK(ptr, func, name) \ -do { \ - (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ - (ptr)->gcc_bb = gcc_jit_function_new_block ((func), (name)); \ - (ptr)->terminated = false; \ - (ptr)->top = NULL; \ - } while (0) - #define STR(s) #s -#define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ - basic_block_t *(name); \ - SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) - -/* Element of the meta stack. */ -typedef struct { - gcc_jit_lvalue *gcc_lval; - enum Lisp_Type type; /* -1 if not set. */ - Lisp_Object constant; /* This is used for constant propagation. */ - bool const_set; -} stack_el_t; - -typedef struct { - gcc_jit_block *gcc_bb; - /* When non zero indicates a stack pointer restart. */ - stack_el_t *top; - bool terminated; -} basic_block_t; +#define DECL_BLOCK(name, func) \ + gcc_jit_block *(name) = \ + gcc_jit_function_new_block ((func), STR(name)) /* The compiler context */ @@ -127,7 +104,8 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_cons_ptr; gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; - gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_function *func; /* Current function being compiled. */ + gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -141,7 +119,6 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; - basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -149,13 +126,6 @@ static comp_t comp; FILE *logfile = NULL; -/* The result of one function compilation. */ - -typedef struct { - gcc_jit_result *gcc_res; - short min_args, max_args; -} comp_f_res_t; - void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); @@ -221,7 +191,7 @@ INLINE static void emit_comment (const char *str) { if (COMP_DEBUG) - gcc_jit_block_add_comment (comp.block->gcc_bb, + gcc_jit_block_add_comment (comp.block, NULL, str); } @@ -325,29 +295,28 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, INLINE static void emit_cond_jump (gcc_jit_rvalue *test, - basic_block_t *then_target, basic_block_t *else_target) + gcc_jit_block *then_target, gcc_jit_block *else_target) { if (gcc_jit_rvalue_get_type (test) == comp.bool_type) - gcc_jit_block_end_with_conditional (comp.block->gcc_bb, + gcc_jit_block_end_with_conditional (comp.block, NULL, test, - then_target->gcc_bb, - else_target->gcc_bb); + then_target, + else_target); else /* In case test is not bool we do a logical negation to obtain a bool as result. */ gcc_jit_block_end_with_conditional ( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_context_new_unary_op (comp.ctxt, NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.bool_type, test), - else_target->gcc_bb, - then_target->gcc_bb); + else_target, + then_target); - comp.block->terminated = true; } /* Close current basic block emitting a comparison between two rval. */ @@ -355,7 +324,7 @@ emit_cond_jump (gcc_jit_rvalue *test, /* static gcc_jit_rvalue * */ /* emit_comparison_jump (enum gcc_jit_comparison op, */ /* gcc_jit_rvalue *a, gcc_jit_rvalue *b, */ -/* basic_block_t *then_target, basic_block_t *else_target) */ +/* gcc_jit_block *then_target, gcc_jit_block *else_target) */ /* { */ /* gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, */ /* NULL, */ @@ -381,7 +350,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) NULL, comp.cast_union_type, format_string ("union_cast_%u", i++)); - gcc_jit_block_add_assignment (comp.block->gcc_bb, + gcc_jit_block_add_assignment (comp.block, NULL, gcc_jit_lvalue_access_field (tmp_u, NULL, @@ -717,7 +686,7 @@ emit_CONSP (gcc_jit_rvalue *obj) /* comp.lisp_obj_type, */ /* "lisp_obj_fixnum"); */ -/* gcc_jit_block_add_assignment (comp.block->gcc_bb, */ +/* gcc_jit_block_add_assignment (comp.block, */ /* NULL, */ /* emit_lval_XLI (res), */ /* tmp); */ @@ -747,7 +716,7 @@ emit_lisp_obj_from_ptr (void *p) format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); - gcc_jit_block_add_assignment (comp.block->gcc_bb, + gcc_jit_block_add_assignment (comp.block, NULL, emit_lval_XLP (lisp_obj), void_ptr); @@ -867,7 +836,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) x }; gcc_jit_block_add_eval ( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -898,7 +867,7 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) emit_comment ("XSETCAR"); gcc_jit_block_add_assignment( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_rvalue_dereference ( emit_car_addr (c), @@ -912,7 +881,7 @@ emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) emit_comment ("XSETCDR"); gcc_jit_block_add_assignment( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_rvalue_dereference ( emit_cdr_addr (c), @@ -955,7 +924,29 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ /* } */ -/* /\* struct Lisp_Cons definition. *\/ */ +static void +emit_limple_inst (Lisp_Object inst) +{ + Lisp_Object op = XCAR (inst); + Lisp_Object arg0 = XCAR (XCDR (inst)); + + if (EQ (op, Qblock)) + { + char *block_name = SDATA (SYMBOL_NAME (arg0)); + comp.block = gcc_jit_function_new_block (comp.func, block_name); + } + else if (EQ (op, Qeqcall)) + { + } + else if (EQ (op, Qeqconst)) + { + } + else if (EQ (op, Qreturn)) + { + } +} + +/* struct Lisp_Cons definition. */ static void define_lisp_cons (void) @@ -1300,7 +1291,6 @@ define_cast_union (void) static void define_CHECK_TYPE (void) { - USE_SAFE_ALLOCA; gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1326,29 +1316,27 @@ define_CHECK_TYPE (void) gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_type); - DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_type); - DECL_AND_SAFE_ALLOCA_BLOCK (not_ok_block, comp.check_type); + DECL_BLOCK (init_block, comp.check_type); + DECL_BLOCK (ok_block, comp.check_type); + DECL_BLOCK (not_ok_block, comp.check_type); comp.block = init_block; comp.func = comp.check_type; emit_cond_jump (ok, ok_block, not_ok_block); - gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); + gcc_jit_block_end_with_void_return (ok_block, NULL); comp.block = not_ok_block; gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; - gcc_jit_block_add_eval (comp.block->gcc_bb, + gcc_jit_block_add_eval (comp.block, NULL, emit_call ("wrong_type_argument", comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_void_return (not_ok_block->gcc_bb, NULL); - - SAFE_FREE (); + gcc_jit_block_end_with_void_return (not_ok_block, NULL); } @@ -1357,8 +1345,6 @@ define_CHECK_TYPE (void) static void define_CAR_CDR (void) { - USE_SAFE_ALLOCA; - gcc_jit_param *car_param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1392,9 +1378,9 @@ define_CAR_CDR (void) for (int i = 0; i < 2; i++) { gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, f); - DECL_AND_SAFE_ALLOCA_BLOCK (is_cons_b, f); - DECL_AND_SAFE_ALLOCA_BLOCK (not_a_cons_b, f); + DECL_BLOCK (init_block, f); + DECL_BLOCK (is_cons_b, f); + DECL_BLOCK (not_a_cons_b, f); comp.block = init_block; comp.func = f; @@ -1404,23 +1390,23 @@ define_CAR_CDR (void) comp.block = is_cons_b; if (f == comp.car) - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); else - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c)); comp.block = not_a_cons_b; - DECL_AND_SAFE_ALLOCA_BLOCK (is_nil_b, f); - DECL_AND_SAFE_ALLOCA_BLOCK (not_nil_b, f); + DECL_BLOCK (is_nil_b, f); + DECL_BLOCK (not_nil_b, f); emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); comp.block = is_nil_b; - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_lisp_obj_from_ptr (Qnil)); @@ -1428,25 +1414,21 @@ define_CAR_CDR (void) gcc_jit_rvalue *wrong_type_args[] = { emit_lisp_obj_from_ptr (Qlistp), c }; - gcc_jit_block_add_eval (comp.block->gcc_bb, + gcc_jit_block_add_eval (comp.block, NULL, emit_call ("wrong_type_argument", comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_lisp_obj_from_ptr (Qnil)); f = comp.cdr; param = cdr_param; } - - SAFE_FREE (); } static void define_setcar_setcdr (void) { - USE_SAFE_ALLOCA; - char const *f_name[] = {"setcar", "setcdr"}; char const *par_name[] = {"new_car", "new_cdr"}; @@ -1473,7 +1455,7 @@ define_setcar_setcdr (void) 2, param, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, *f_ref); + DECL_BLOCK (init_block, *f_ref); comp.func = *f_ref; comp.block = init_block; @@ -1486,7 +1468,7 @@ define_setcar_setcdr (void) emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; gcc_jit_block_add_eval ( - init_block->gcc_bb, + init_block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -1503,11 +1485,10 @@ define_setcar_setcdr (void) gcc_jit_param_as_rvalue (new_el)); /* return newel; */ - gcc_jit_block_end_with_return (init_block->gcc_bb, + gcc_jit_block_end_with_return (init_block, NULL, gcc_jit_param_as_rvalue (new_el)); } - SAFE_FREE (); } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ @@ -1515,8 +1496,6 @@ define_setcar_setcdr (void) static void define_PSEUDOVECTORP (void) { - USE_SAFE_ALLOCA; - gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1536,9 +1515,9 @@ define_PSEUDOVECTORP (void) param, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.pseudovectorp); - DECL_AND_SAFE_ALLOCA_BLOCK (ret_false_b, comp.pseudovectorp); - DECL_AND_SAFE_ALLOCA_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); + DECL_BLOCK (init_block, comp.pseudovectorp); + DECL_BLOCK (ret_false_b, comp.pseudovectorp); + DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); comp.block = init_block; comp.func = comp.pseudovectorp; @@ -1548,7 +1527,7 @@ define_PSEUDOVECTORP (void) ret_false_b); comp.block = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b->gcc_bb, + gcc_jit_block_end_with_return (ret_false_b, NULL, gcc_jit_context_new_rvalue_from_int( comp.ctxt, @@ -1560,21 +1539,18 @@ define_PSEUDOVECTORP (void) gcc_jit_param_as_rvalue (param[1]) }; comp.block = call_pseudovector_typep_b; /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b->gcc_bb + gcc_jit_block_end_with_return (call_pseudovector_typep_b , NULL, emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args)); - SAFE_FREE (); } static void define_CHECK_IMPURE (void) { - USE_SAFE_ALLOCA; - gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1593,9 +1569,9 @@ define_CHECK_IMPURE (void) param, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_impure); - DECL_AND_SAFE_ALLOCA_BLOCK (err_block, comp.check_impure); - DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_impure); + DECL_BLOCK (init_block, comp.check_impure); + DECL_BLOCK (err_block, comp.check_impure); + DECL_BLOCK (ok_block, comp.check_impure); comp.block = init_block; comp.func = comp.check_impure; @@ -1603,29 +1579,26 @@ define_CHECK_IMPURE (void) emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ err_block, ok_block); - gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); + gcc_jit_block_end_with_void_return (ok_block, NULL); gcc_jit_rvalue *pure_write_error_arg = gcc_jit_param_as_rvalue (param[0]); comp.block = err_block; - gcc_jit_block_add_eval (comp.block->gcc_bb, + gcc_jit_block_add_eval (comp.block, NULL, emit_call ("pure_write_error", comp.void_type, 1, &pure_write_error_arg)); - gcc_jit_block_end_with_void_return (err_block->gcc_bb, NULL); - - SAFE_FREE ();} + gcc_jit_block_end_with_void_return (err_block, NULL); +} /* Declare a function to convert boolean into t or nil */ static void define_bool_to_lisp_obj (void) { - USE_SAFE_ALLOCA; - /* x ? Qt : Qnil */ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1639,9 +1612,9 @@ define_bool_to_lisp_obj (void) 1, ¶m, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.bool_to_lisp_obj); - DECL_AND_SAFE_ALLOCA_BLOCK (ret_t_block, comp.bool_to_lisp_obj); - DECL_AND_SAFE_ALLOCA_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); + DECL_BLOCK (init_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); comp.block = init_block; comp.func = comp.bool_to_lisp_obj; @@ -1650,16 +1623,15 @@ define_bool_to_lisp_obj (void) ret_nil_block); comp.block = ret_t_block; - gcc_jit_block_end_with_return (ret_t_block->gcc_bb, + gcc_jit_block_end_with_return (ret_t_block, NULL, emit_lisp_obj_from_ptr (Qt)); comp.block = ret_nil_block; - gcc_jit_block_end_with_return (ret_nil_block->gcc_bb, + gcc_jit_block_end_with_return (ret_nil_block, NULL, emit_lisp_obj_from_ptr (Qnil)); - SAFE_FREE (); } DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, @@ -1832,6 +1804,56 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, { char *c_name = (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func)); + Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); + EMACS_INT frame_size = + XFIXNUM (CALLN (Ffuncall, intern ("comp-func-frame-size"), func)); + EMACS_INT min_args = + XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + EMACS_INT max_args = + XFIXNUM (CALLN (Ffuncall, intern ("comp-args-max"), args)); + bool ncall = + !NILP (CALLN (Ffuncall, intern ("comp-args-ncall-conv"), args)); + + if (!ncall) + { + comp.func = + emit_func_declare (c_name, comp.lisp_obj_type, min_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); + } + else + { + error ("Not supported for now"); + } + + gcc_jit_lvalue *meta_frame = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "local"); + + gcc_jit_lvalue *frame[frame_size]; + for (int i = 0; i < frame_size; ++i) + frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_frame), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + + Lisp_Object limple = (CALLN (Ffuncall, intern ("comp-func-ir"), func)); + + while (CONSP (limple)) + { + Lisp_Object inst = XCAR (limple); + emit_limple_inst (inst); + limple = XCDR (limple); + }; return Qt; } @@ -1846,12 +1868,24 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp_speed); + /* Gcc doesn't like being interrupted. */ + sigset_t oldset; + block_atimers (&oldset); + + unblock_atimers (&oldset); + return Qt; } void syms_of_comp (void) { + /* Limple instruction set. */ + DEFSYM (Qblock, "BLOCK"); + DEFSYM (Qeqcall, "=call"); + DEFSYM (Qeqconst, "=const"); + DEFSYM (Qreturn, "return"); + defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); From a59ef0747f855fb30d66ff98c739965fafdfe0c7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 17:04:33 +0200 Subject: [PATCH 0167/1452] block list in limple --- lisp/emacs-lisp/comp.el | 22 ++++++++++++++++------ src/comp.c | 7 ++++++- 2 files changed, 22 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 963c22dc590..17de79bc470 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -72,6 +72,8 @@ To be used when ncall-conv is nil.") :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) (frame-size nil :type 'number) + (blocks () :type list + :documentation "List of basic block") (limple-cnt -1 :type 'number :documentation "Counter to create ssa limple vars")) @@ -198,10 +200,16 @@ To be used when ncall-conv is nil.") "Push VAL into frame. VAL is known at compile time." (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) + (let ((const (make-comp-mvar :slot (comp-sp) :const-vld t - :constant val)) - (push (list '=const (comp-slot) val) comp-limple)) + :constant val))) + (setf (comp-slot) const) + (push (list '=const (comp-slot) const) comp-limple))) + +(defun comp-push_block (bblock) + "Push basic block BBLOCK." + (push bblock (comp-func-blocks comp-func)) + (push `(block ,bblock) comp-limple)) (defun comp-pop (n) "Pop N elements from the meta-stack." @@ -262,7 +270,7 @@ VAL is known at compile time." (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify (func) - "Given FUNC and return LIMPLE." + "Given FUNC and return compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-frame (make-comp-limple-frame @@ -273,12 +281,14 @@ VAL is known at compile time." v))) (comp-limple ())) ;; Prologue - (push '(BLOCK prologue) comp-limple) + (comp-push_block 'prologue) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) comp-limple))) - (push '(BLOCK body) comp-limple) + (push '(jump body) comp-limple) + ;; Body + (comp-push_block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) (when comp-debug diff --git a/src/comp.c b/src/comp.c index 6f5863b7f7e..ca741fc9f1d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -935,6 +935,10 @@ emit_limple_inst (Lisp_Object inst) char *block_name = SDATA (SYMBOL_NAME (arg0)); comp.block = gcc_jit_function_new_block (comp.func, block_name); } + else if (EQ (op, Qjump)) + { + + } else if (EQ (op, Qeqcall)) { } @@ -1881,7 +1885,8 @@ void syms_of_comp (void) { /* Limple instruction set. */ - DEFSYM (Qblock, "BLOCK"); + DEFSYM (Qblock, "block"); + DEFSYM (Qjump, "jump"); DEFSYM (Qeqcall, "=call"); DEFSYM (Qeqconst, "=const"); DEFSYM (Qreturn, "return"); From 3f98a32b7e15fd32da15b5be6fb4ef77a1e43a43 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 17:44:19 +0200 Subject: [PATCH 0168/1452] basic blocks into C --- lisp/emacs-lisp/comp.el | 2 + src/comp.c | 90 ++++++++++++++++++++++++++++++++++++----- 2 files changed, 81 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 17de79bc470..d780e9363cc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -291,6 +291,8 @@ VAL is known at compile time." (comp-push_block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) + ;; Prologue block must be first + (setf (comp-func-blocks func) (reverse (comp-func-blocks func))) (when comp-debug (cl-prettyprint (comp-func-ir func))) func)) diff --git a/src/comp.c b/src/comp.c index ca741fc9f1d..4f6382304a6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -119,7 +119,8 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; - Lisp_Object func_hash; /* f_name -> gcc_func */ + Lisp_Object func_blocks; /* blk_name -> gcc_block. */ + Lisp_Object func_hash; /* f_name -> gcc_func. */ } comp_t; static comp_t comp; @@ -187,6 +188,35 @@ type_to_cast_field (gcc_jit_type *type) return field; } +static gcc_jit_block * +retrive_block (Lisp_Object symbol) +{ + char *block_name = (char *) SDATA (SYMBOL_NAME (symbol)); + Lisp_Object key = make_string (block_name, strlen (block_name)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); + ptrdiff_t i = hash_lookup (ht, key, &hash); + if (i == -1) + error ("LIMPLE basic block inconsistency"); + Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); + + return (gcc_jit_block *) XFIXNUMPTR (value); +} + +static void +declare_block (char *block_name) +{ + gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); + Lisp_Object key = make_string (block_name, strlen (block_name)); + Lisp_Object value = make_pointer_integer (XPL (block)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); + ptrdiff_t i = hash_lookup (ht, key, &hash); + if (i != -1) + error ("LIMPLE basic block inconsistency"); + hash_put (ht, key, value, hash); +} + INLINE static void emit_comment (const char *str) { @@ -249,14 +279,12 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, if (reusable) { - Lisp_Object value; Lisp_Object key = make_string (f_name, strlen (f_name)); - value = make_pointer_integer (XPL (func)); - + Lisp_Object value = make_pointer_integer (XPL (func)); EMACS_UINT hash = 0; struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); ptrdiff_t i = hash_lookup (ht, key, &hash); - /* Don't want to declare the same function two times */ + /* Don't want to declare the same function two times. */ eassert (i == -1); hash_put (ht, key, value, hash); } @@ -932,12 +960,15 @@ emit_limple_inst (Lisp_Object inst) if (EQ (op, Qblock)) { - char *block_name = SDATA (SYMBOL_NAME (arg0)); - comp.block = gcc_jit_function_new_block (comp.func, block_name); + /* Search for the already defined block and make it current. */ + comp.block = retrive_block (arg0); } else if (EQ (op, Qjump)) { - + /* Unconditional branch. */ + gcc_jit_block *target = retrive_block (arg0); + gcc_jit_block_end_with_jump (comp.block, NULL, target); + comp.block = target; } else if (EQ (op, Qeqcall)) { @@ -947,6 +978,12 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qreturn)) { + gcc_jit_rvalue *ret_val = + emit_lisp_obj_from_ptr ( + CALLN (Ffuncall, intern ("comp-mvar-constant"), arg0)); + gcc_jit_block_end_with_return (comp.block, + NULL, + ret_val); } } @@ -1829,7 +1866,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, error ("Not supported for now"); } - gcc_jit_lvalue *meta_frame = + gcc_jit_lvalue *frame_array = gcc_jit_function_new_local ( comp.func, NULL, @@ -1845,11 +1882,22 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, gcc_jit_context_new_array_access ( comp.ctxt, NULL, - gcc_jit_lvalue_as_rvalue (meta_frame), + gcc_jit_lvalue_as_rvalue (frame_array), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, i)); + comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + + /* Pre declare all basic blocks. */ + Lisp_Object blocks = (CALLN (Ffuncall, intern ("comp-func-blocks"), func)); + while (CONSP (blocks)) + { + char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); + declare_block (block_name); + blocks = XCDR (blocks); + } + Lisp_Object limple = (CALLN (Ffuncall, intern ("comp-func-ir"), func)); while (CONSP (limple)) @@ -1857,7 +1905,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, Lisp_Object inst = XCAR (limple); emit_limple_inst (inst); limple = XCDR (limple); - }; + } return Qt; } @@ -1876,6 +1924,25 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, sigset_t oldset; block_atimers (&oldset); + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); + gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); + + if (!NILP (disassemble)) + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_ASSEMBLER, + "gcc-ctxt-dump.s"); + + /* FIXME: must iterate all function names. */ + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = gcc_jit_result_get_code(gcc_res, "F666f6f_foo"); + eassert (x->s.function.a0); + x->s.min_args = 0; + x->s.max_args = 0; + x->s.symbol_name = "foo"; + defsubr(x); + unblock_atimers (&oldset); return Qt; @@ -1897,6 +1964,7 @@ syms_of_comp (void) defsubr (&Scomp_compile_and_load_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); + staticpro (&comp.func_blocks); DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); From cd55772c8c4fea27b344633dec7ad893cf799036 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jul 2019 18:33:56 +0200 Subject: [PATCH 0169/1452] first functional function --- src/comp.c | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4f6382304a6..e524e28b143 100644 --- a/src/comp.c +++ b/src/comp.c @@ -121,6 +121,7 @@ typedef struct { gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ + Lisp_Object funcs; /* List of functions defined. */ } comp_t; static comp_t comp; @@ -1686,6 +1687,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qnil; } comp.ctxt = gcc_jit_context_acquire(); + comp.funcs = Qnil; if (COMP_DEBUG) { @@ -1907,6 +1909,8 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, limple = XCDR (limple); } + comp.funcs = Fcons (func, comp.funcs); + return Qt; } @@ -1933,15 +1937,26 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, GCC_JIT_OUTPUT_KIND_ASSEMBLER, "gcc-ctxt-dump.s"); - /* FIXME: must iterate all function names. */ - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(gcc_res, "F666f6f_foo"); - eassert (x->s.function.a0); - x->s.min_args = 0; - x->s.max_args = 0; - x->s.symbol_name = "foo"; - defsubr(x); + while (CONSP (comp.funcs)) + { + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + Lisp_Object func = XCAR (comp.funcs); + Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); + char *c_name = + (char *) SDATA (CALLN (Ffuncall, + intern ("comp-func-c-func-name"), + func)); + + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); + eassert (x->s.function.a0); + x->s.min_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + x->s.max_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + x->s.symbol_name = "foo"; + defsubr(x); + + comp.funcs = XCDR (comp.funcs); + } unblock_atimers (&oldset); From e46c54e7387523e22f2ce371fd991d1edb4b09cb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jul 2019 14:46:52 +0200 Subject: [PATCH 0170/1452] introduce FUNCALL1 macro --- src/comp.c | 37 ++++++++++++++++--------------------- 1 file changed, 16 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index e524e28b143..7c97560d2e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,6 +37,9 @@ along with GNU Emacs. If not, see . */ #define STR(s) #s +#define FUNCALL1(fun, arg) \ + CALLN (Ffuncall, intern (STR(fun)), arg) + #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR(name)) @@ -981,7 +984,7 @@ emit_limple_inst (Lisp_Object inst) { gcc_jit_rvalue *ret_val = emit_lisp_obj_from_ptr ( - CALLN (Ffuncall, intern ("comp-mvar-constant"), arg0)); + FUNCALL1 (comp-mvar-constant, arg0)); gcc_jit_block_end_with_return (comp.block, NULL, ret_val); @@ -1845,17 +1848,12 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, doc: /* Add limple FUNC to the current compilation context. */) (Lisp_Object func) { - char *c_name = - (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func)); - Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); - EMACS_INT frame_size = - XFIXNUM (CALLN (Ffuncall, intern ("comp-func-frame-size"), func)); - EMACS_INT min_args = - XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); - EMACS_INT max_args = - XFIXNUM (CALLN (Ffuncall, intern ("comp-args-max"), args)); - bool ncall = - !NILP (CALLN (Ffuncall, intern ("comp-args-ncall-conv"), args)); + char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); + Lisp_Object args = FUNCALL1 (comp-func-args, func); + EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) { @@ -1892,7 +1890,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); /* Pre declare all basic blocks. */ - Lisp_Object blocks = (CALLN (Ffuncall, intern ("comp-func-blocks"), func)); + Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); while (CONSP (blocks)) { char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); @@ -1900,7 +1898,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, blocks = XCDR (blocks); } - Lisp_Object limple = (CALLN (Ffuncall, intern ("comp-func-ir"), func)); + Lisp_Object limple = FUNCALL1 (comp-func-ir, func); while (CONSP (limple)) { @@ -1941,17 +1939,14 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, { union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); Lisp_Object func = XCAR (comp.funcs); - Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); - char *c_name = - (char *) SDATA (CALLN (Ffuncall, - intern ("comp-func-c-func-name"), - func)); + Lisp_Object args = FUNCALL1 (comp-func-args, func); + char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); - x->s.max_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); + x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); x->s.symbol_name = "foo"; defsubr(x); From 0a227b6db46dcd5c4af0b6266d4f642b0c6157b5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jul 2019 18:09:47 +0200 Subject: [PATCH 0171/1452] wipe out propagation info every new basic block --- lisp/emacs-lisp/comp.el | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d780e9363cc..93e3bf17b35 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -98,6 +98,13 @@ To be used when ncall-conv is nil.") (frame nil :type 'vector :documentation "Meta-stack used to flat LAP")) +(defun comp-limple-frame-new-frame (size) + "Return a clean frame of meta variables of size SIZE." + (let ((v (make-vector size nil))) + (cl-loop for i below size + do (aset v i (make-comp-mvar :slot i))) + v)) + (defun comp-c-func-name (symbol-function) "Given SYMBOL-FUNCTION return a name suitable for the native code." ;; Unfortunatelly not all symbol names are valid as C function names... @@ -206,9 +213,13 @@ VAL is known at compile time." (setf (comp-slot) const) (push (list '=const (comp-slot) const) comp-limple))) -(defun comp-push_block (bblock) +(defun comp-push-block (bblock) "Push basic block BBLOCK." (push bblock (comp-func-blocks comp-func)) + ;; Every new block we are forced to wipe out all the frame. + ;; This will be superseded by proper flow analysis. + (setf (comp-limple-frame-frame comp-frame) + (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) (push `(block ,bblock) comp-limple)) (defun comp-pop (n) @@ -275,20 +286,17 @@ VAL is known at compile time." (comp-func func) (comp-frame (make-comp-limple-frame :sp -1 - :frame (let ((v (make-vector frame-size nil))) - (cl-loop for i below frame-size - do (aset v i (make-comp-mvar :slot i))) - v))) + :frame (comp-limple-frame-new-frame frame-size))) (comp-limple ())) ;; Prologue - (comp-push_block 'prologue) + (comp-push-block 'prologue) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) comp-limple))) (push '(jump body) comp-limple) ;; Body - (comp-push_block 'body) + (comp-push-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) ;; Prologue block must be first From c1a738bd98f7eaaf4dcc87b0769dad2821178ab8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jul 2019 22:28:29 +0200 Subject: [PATCH 0172/1452] update tests --- lisp/emacs-lisp/comp.el | 20 ++++++++++---------- test/src/comp-tests.el | 5 +---- 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 93e3bf17b35..e3cb8684386 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -79,7 +79,7 @@ To be used when ncall-conv is nil.") (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (n nil :type number + (id nil :type number :documentation "SSA number") (slot nil :type fixnum :documentation "Slot position") @@ -139,8 +139,11 @@ To be used when ncall-conv is nil.") (byte-compile (comp-func-symbol-name func))) (when comp-debug (cl-prettyprint byte-compile-lap-output)) - (setf (comp-func-args func) - (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (if (fixnump lambda-list) + (setf (comp-func-args func) + (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (error "Can't native compile a non lexical scoped function"))) (setf (comp-func-ir func) byte-compile-lap-output) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func) @@ -163,7 +166,7 @@ To be used when ncall-conv is nil.") (defvar comp-func) (cl-defun make-comp-mvar (&key slot const-vld constant type) - (make--comp-mvar :n (cl-incf (comp-func-limple-cnt comp-func)) + (make--comp-mvar :id (cl-incf (comp-func-limple-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -207,11 +210,10 @@ To be used when ncall-conv is nil.") "Push VAL into frame. VAL is known at compile time." (cl-incf (comp-sp)) - (let ((const (make-comp-mvar :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t - :constant val))) - (setf (comp-slot) const) - (push (list '=const (comp-slot) const) comp-limple))) + :constant val)) + (push (list '=const (comp-slot) val) comp-limple)) (defun comp-push-block (bblock) "Push basic block BBLOCK." @@ -307,8 +309,6 @@ VAL is known at compile time." (defun native-compile (fun) "FUN is the function definition to be compiled into native code." - (unless lexical-binding - (error "Can't native compile a non lexical scoped function")) (if-let ((f (symbol-function fun))) (progn (when (byte-code-function-p f) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c6ee5b76855..8d3a0f507d3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -26,6 +26,7 @@ ;;; Code: (require 'ert) +(require 'comp) (setq garbage-collection-messages t) @@ -103,10 +104,6 @@ (defun comp-tests-varset-f () (setq comp-tests-var1 55)) (comp-test-compile #'comp-tests-varset-f) -((byte-constant 55 . 1) - (byte-dup . 0) - (byte-varset comp-tests-var1 . 0) - (byte-return . 0)) (comp-tests-varset-f) From 1b9e05b430d0cc09480e53fb1eaa5c724f99b078 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jul 2019 22:50:52 +0200 Subject: [PATCH 0173/1452] fix function name --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 7c97560d2e6..c9207e18692 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1940,6 +1940,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); Lisp_Object func = XCAR (comp.funcs); Lisp_Object args = FUNCALL1 (comp-func-args, func); + char *symbol_name = (char *) SDATA (FUNCALL1 (symbol-name, func)); char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; @@ -1947,7 +1948,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, eassert (x->s.function.a0); x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - x->s.symbol_name = "foo"; + x->s.symbol_name = symbol_name; defsubr(x); comp.funcs = XCDR (comp.funcs); From 40ffcb131513386b24cf16ecc566f01a3666a895 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jul 2019 23:32:50 +0200 Subject: [PATCH 0174/1452] simple call support --- src/comp.c | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index c9207e18692..668e7a67dc7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,6 +37,13 @@ along with GNU Emacs. If not, see . */ #define STR(s) #s +#define FIRST(x) \ + XCAR(x) +#define SECOND(x) \ + XCAR (XCDR (x)) +#define THIRD(x) \ + XCAR (XCDR (XCDR (x))) + #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern (STR(fun)), arg) @@ -109,6 +116,7 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ gcc_jit_block *block; /* Current basic block being compiled. */ + gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -960,7 +968,7 @@ static void emit_limple_inst (Lisp_Object inst) { Lisp_Object op = XCAR (inst); - Lisp_Object arg0 = XCAR (XCDR (inst)); + Lisp_Object arg0 = SECOND (inst); if (EQ (op, Qblock)) { @@ -976,6 +984,18 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qeqcall)) { + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + Lisp_Object arg1 = THIRD (inst); + eassert (FIRST (arg1) == Qcall); + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + gcc_jit_rvalue *args[] = + { emit_lisp_obj_from_ptr (THIRD (arg1)) }; + gcc_jit_rvalue *res = emit_call (calle, comp.lisp_obj_type, 1, args); + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qeqconst)) { @@ -1886,6 +1906,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, i)); + comp.frame = frame; comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); @@ -1966,6 +1987,8 @@ syms_of_comp (void) DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qeqcall, "=call"); + DEFSYM (Qcall, "call"); + DEFSYM (Qncall, "ncall"); DEFSYM (Qeqconst, "=const"); DEFSYM (Qreturn, "return"); From 99ec0b493a48fefc69b337cd0d30290dfa1cf858 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jul 2019 23:54:07 +0200 Subject: [PATCH 0175/1452] proper return in place --- src/comp.c | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 668e7a67dc7..0670bf24bd4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -964,6 +964,21 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ /* } */ +/* Retrive an r-value from a meta variable. + In case this is a constant that was propagated return it otherwise load it + from the frame. */ + +static gcc_jit_rvalue * +retrive_mvar_val (Lisp_Object mvar) +{ + if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) + return + gcc_jit_lvalue_as_rvalue( + comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + else + return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); +} + static void emit_limple_inst (Lisp_Object inst) { @@ -1002,12 +1017,9 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qreturn)) { - gcc_jit_rvalue *ret_val = - emit_lisp_obj_from_ptr ( - FUNCALL1 (comp-mvar-constant, arg0)); gcc_jit_block_end_with_return (comp.block, NULL, - ret_val); + retrive_mvar_val (arg0)); } } @@ -1961,7 +1973,8 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); Lisp_Object func = XCAR (comp.funcs); Lisp_Object args = FUNCALL1 (comp-func-args, func); - char *symbol_name = (char *) SDATA (FUNCALL1 (symbol-name, func)); + char *symbol_name = + (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; From 24f80e510f51e0155fe3701c86d553e2f77d4093 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 02:36:28 +0200 Subject: [PATCH 0176/1452] rework hashtable usage --- src/comp.c | 34 +++++++++++----------------------- 1 file changed, 11 insertions(+), 23 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0670bf24bd4..bb056620d07 100644 --- a/src/comp.c +++ b/src/comp.c @@ -205,12 +205,9 @@ retrive_block (Lisp_Object symbol) { char *block_name = (char *) SDATA (SYMBOL_NAME (symbol)); Lisp_Object key = make_string (block_name, strlen (block_name)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); - ptrdiff_t i = hash_lookup (ht, key, &hash); - if (i == -1) + Lisp_Object value = Fgethash (key, comp.func_blocks, Qnil); + if (NILP (value)) error ("LIMPLE basic block inconsistency"); - Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); return (gcc_jit_block *) XFIXNUMPTR (value); } @@ -221,12 +218,9 @@ declare_block (char *block_name) gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); Lisp_Object key = make_string (block_name, strlen (block_name)); Lisp_Object value = make_pointer_integer (XPL (block)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); - ptrdiff_t i = hash_lookup (ht, key, &hash); - if (i != -1) + if (!NILP (Fgethash (key, comp.func_blocks, Qnil))) error ("LIMPLE basic block inconsistency"); - hash_put (ht, key, value, hash); + Fputhash (key, value, comp.func_blocks); } INLINE static void @@ -293,12 +287,10 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, { Lisp_Object key = make_string (f_name, strlen (f_name)); Lisp_Object value = make_pointer_integer (XPL (func)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); /* Don't want to declare the same function two times. */ - eassert (i == -1); - hash_put (ht, key, value, hash); + if (!NILP (Fgethash (key, comp.func_hash, Qnil))) + eassert (false); + Fputhash (key, value, comp.func_hash); } return func; @@ -309,19 +301,15 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); + Lisp_Object value = Fgethash (key, comp.func_hash, Qnil); - if (i == -1) + if (NILP (value)) { emit_func_declare (f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); - i = hash_lookup (ht, key, &hash); - eassert (i != -1); + value = Fgethash (key, comp.func_hash, Qnil); + eassert (!NILP (value)); } - - Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); return gcc_jit_context_new_call(comp.ctxt, From 30ba6d253246c0b0f91fa3e6b30f1694f446e88a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 02:36:49 +0200 Subject: [PATCH 0177/1452] rename entry block --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e3cb8684386..fe5a0694eea 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -291,7 +291,7 @@ VAL is known at compile time." :frame (comp-limple-frame-new-frame frame-size))) (comp-limple ())) ;; Prologue - (comp-push-block 'prologue) + (comp-push-block 'entry) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) From 25908f52e16e4a5de86f85945a89fa50c714188d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 00:39:42 +0200 Subject: [PATCH 0178/1452] parameter passing works again --- src/comp.c | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index bb056620d07..a52aa242c04 100644 --- a/src/comp.c +++ b/src/comp.c @@ -139,9 +139,6 @@ static comp_t comp; FILE *logfile = NULL; -void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, int opt_level, bool dump_asm); - static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) { @@ -985,7 +982,7 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } - else if (EQ (op, Qeqcall)) + else if (EQ (op, Q_call_ass)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); @@ -1000,7 +997,20 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], res); } - else if (EQ (op, Qeqconst)) + else if (EQ (op, Q_par_ass)) + { + /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + EMACS_UINT param_n = XFIXNUM (THIRD (inst)); + gcc_jit_rvalue *param = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, + param_n)); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + param); + } + else if (EQ (op, Q_const_ass)) { } else if (EQ (op, Qreturn)) @@ -1987,10 +1997,11 @@ syms_of_comp (void) /* Limple instruction set. */ DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); - DEFSYM (Qeqcall, "=call"); DEFSYM (Qcall, "call"); DEFSYM (Qncall, "ncall"); - DEFSYM (Qeqconst, "=const"); + DEFSYM (Q_par_ass, "=par"); + DEFSYM (Q_call_ass, "=call"); + DEFSYM (Q_const_ass, "=const"); DEFSYM (Qreturn, "return"); defsubr (&Scomp_init_ctxt); From 0bd54f29cbf264e0982d3b31b4c313329ae26a27 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 03:06:21 +0200 Subject: [PATCH 0179/1452] two test passing --- lisp/emacs-lisp/comp.el | 12 +- src/comp.c | 4 +- test/src/comp-tests.el | 782 ++++++++++++++++++++-------------------- 3 files changed, 399 insertions(+), 399 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe5a0694eea..934c76f8429 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -247,7 +247,9 @@ VAL is known at compile time." ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref - (comp-push-call `(call Fsymbol_value ,(cadr inst)))) + (comp-push-call `(call Fsymbol_value ,(make-comp-mvar + :const-vld t + :constant (cadr inst))))) ;; ('byte-varset ;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ('byte-constant @@ -259,16 +261,16 @@ VAL is known at compile time." (comp-push-call `(callref Fplus 2 ,(comp-sp)))) ('byte-car (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-sp)))) + (comp-push-call `(call Fcar ,(comp-slot)))) ('byte-cdr (comp-pop 1) - (comp-push-call `(call Fcdr ,(comp-sp)))) + (comp-push-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe (comp-pop 1) - (comp-push-call `(call Fcar-safe ,(comp-sp)))) + (comp-push-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe (comp-pop 1) - (comp-push-call `(call Fcdr-safe ,(comp-sp)))) + (comp-push-call `(call Fcdr_safe ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 diff --git a/src/comp.c b/src/comp.c index a52aa242c04..1a74605934a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -984,12 +984,14 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Q_call_ass)) { + /* Ex: (=call #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); eassert (FIRST (arg1) == Qcall); char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); gcc_jit_rvalue *args[] = - { emit_lisp_obj_from_ptr (THIRD (arg1)) }; + { retrive_mvar_val (THIRD (arg1)) }; gcc_jit_rvalue *res = emit_call (calle, comp.lisp_obj_type, 1, args); gcc_jit_block_add_assignment (comp.block, diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8d3a0f507d3..33f5ebfdc2e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -32,23 +32,19 @@ (defvar comp-tests-var1 3) -(defun comp-test-compile (f) - ;; (byte-compile f) - (native-compile f)) - (ert-deftest comp-tests-varref () "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) - (comp-test-compile #'comp-tests-varref-f) + (native-compile #'comp-tests-varref-f) (should (= (comp-tests-varref-f) 3))) -(ert-deftest comp-tests-list () +(ert-deftest comp-tests-list () "Testing cons car cdr." - (defun comp-tests-list-f () - (list 1 2 3)) + ;; (defun comp-tests-list-f () + ;; (list 1 2 3)) (defun comp-tests-car-f (x) ;; Bcar (car x)) @@ -62,13 +58,13 @@ ;; Bcdr_safe (cdr-safe x)) - (comp-test-compile #'comp-tests-list-f) - (comp-test-compile #'comp-tests-car-f) - (comp-test-compile #'comp-tests-cdr-f) - (comp-test-compile #'comp-tests-car-safe-f) - (comp-test-compile #'comp-tests-cdr-safe-f) + ;; (native-compile #'comp-tests-list-f) + (native-compile #'comp-tests-car-f) + (native-compile #'comp-tests-cdr-f) + (native-compile #'comp-tests-car-safe-f) + (native-compile #'comp-tests-cdr-safe-f) - (should (equal (comp-tests-list-f) '(1 2 3))) + ;; (should (equal (comp-tests-list-f) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) (should (= (condition-case err @@ -86,396 +82,396 @@ (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-safe-f 'a)))) -(ert-deftest comp-tests-cons-car-cdr () - "Testing cons car cdr." - (defun comp-tests-cons-car-f () - (car (cons 1 2))) - (comp-test-compile #'comp-tests-cons-car-f) +;; (ert-deftest comp-tests-cons-car-cdr () +;; "Testing cons car cdr." +;; (defun comp-tests-cons-car-f () +;; (car (cons 1 2))) +;; (native-compile #'comp-tests-cons-car-f) - (defun comp-tests-cons-cdr-f (x) - (cdr (cons 'foo x))) - (comp-test-compile #'comp-tests-cons-cdr-f) +;; (defun comp-tests-cons-cdr-f (x) +;; (cdr (cons 'foo x))) +;; (native-compile #'comp-tests-cons-cdr-f) - (should (= (comp-tests-cons-car-f) 1)) - (should (= (comp-tests-cons-cdr-f 3) 3))) +;; (should (= (comp-tests-cons-car-f) 1)) +;; (should (= (comp-tests-cons-cdr-f 3) 3))) -(ert-deftest comp-tests-varset () - "Testing varset." - (defun comp-tests-varset-f () - (setq comp-tests-var1 55)) - (comp-test-compile #'comp-tests-varset-f) +;; (ert-deftest comp-tests-varset () +;; "Testing varset." +;; (defun comp-tests-varset-f () +;; (setq comp-tests-var1 55)) +;; (native-compile #'comp-tests-varset-f) - (comp-tests-varset-f) +;; (comp-tests-varset-f) - (should (= comp-tests-var1 55))) +;; (should (= comp-tests-var1 55))) -(ert-deftest comp-tests-length () - "Testing length." - (defun comp-tests-length-f () - (length '(1 2 3))) - (comp-test-compile #'comp-tests-length-f) +;; (ert-deftest comp-tests-length () +;; "Testing length." +;; (defun comp-tests-length-f () +;; (length '(1 2 3))) +;; (native-compile #'comp-tests-length-f) - (should (= (comp-tests-length-f) 3))) +;; (should (= (comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref-aset () - "Testing aref and aset." - (defun comp-tests-aref-aset-f () - (let ((vec [1 2 3])) - (aset vec 2 100) - (aref vec 2))) - (comp-test-compile #'comp-tests-aref-aset-f) +;; (ert-deftest comp-tests-aref-aset () +;; "Testing aref and aset." +;; (defun comp-tests-aref-aset-f () +;; (let ((vec [1 2 3])) +;; (aset vec 2 100) +;; (aref vec 2))) +;; (native-compile #'comp-tests-aref-aset-f) - (should (= (comp-tests-aref-aset-f) 100))) +;; (should (= (comp-tests-aref-aset-f) 100))) -(ert-deftest comp-tests-symbol-value () - "Testing aref and aset." - (defvar comp-tests-var2 3) - (defun comp-tests-symbol-value-f () - (symbol-value 'comp-tests-var2)) - (comp-test-compile #'comp-tests-symbol-value-f) +;; (ert-deftest comp-tests-symbol-value () +;; "Testing aref and aset." +;; (defvar comp-tests-var2 3) +;; (defun comp-tests-symbol-value-f () +;; (symbol-value 'comp-tests-var2)) +;; (native-compile #'comp-tests-symbol-value-f) - (should (= (comp-tests-symbol-value-f) 3))) +;; (should (= (comp-tests-symbol-value-f) 3))) -(ert-deftest comp-tests-concat () - "Testing concatX opcodes." - (defun comp-tests-concat-f (x) - (concat "a" "b" "c" "d" - (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - (comp-test-compile #'comp-tests-concat-f) - - (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) - -(ert-deftest comp-tests-ffuncall () - "Test calling conventions." - (defun comp-tests-ffuncall-callee-f (x y z) - (list x y z)) - (defun comp-tests-ffuncall-caller-f () - (comp-tests-ffuncall-callee-f 1 2 3)) - - (comp-test-compile #'comp-tests-ffuncall-caller-f) - - (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) - - (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) - (list a b c d)) - (comp-test-compile #'comp-tests-ffuncall-callee-optional-f) - - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) - - (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) - (list a b c)) - (comp-test-compile #'comp-tests-ffuncall-callee-rest-f) - - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) - - (defun comp-tests-ffuncall-native-f () - "Call a primitive with no dedicate op." - (make-vector 1 nil)) - - (comp-test-compile #'comp-tests-ffuncall-native-f) - - (should (equal (comp-tests-ffuncall-native-f) [nil])) - - (defun comp-tests-ffuncall-native-rest-f () - "Call a primitive with no dedicate op with &rest." - (vector 1 2 3)) - - (comp-test-compile #'comp-tests-ffuncall-native-rest-f) - - (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) - - (defun comp-tests-ffuncall-apply-many-f (x) - (apply #'list x)) - - (comp-test-compile #'comp-tests-ffuncall-apply-many-f) - - (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) - - (defun comp-tests-ffuncall-lambda-f (x) - (let ((fun (lambda (x) - (1+ x)))) - (funcall fun x))) - - (comp-test-compile #'comp-tests-ffuncall-lambda-f) - - (should (= (comp-tests-ffuncall-lambda-f 1) 2))) - -(ert-deftest comp-tests-jump-table () - "Testing jump tables" - (defun comp-tests-jump-table-1-f (x) - (pcase x - ('x 'a) - ('y 'b) - (_ 'c))) - - - (should (eq (comp-tests-jump-table-1-f 'x) 'a)) - (should (eq (comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) - -(ert-deftest comp-tests-conditionals () - "Testing conditionals." - (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)) - (comp-test-compile #'comp-tests-conditionals-1-f) - (comp-test-compile #'comp-tests-conditionals-2-f) - - (should (= (comp-tests-conditionals-1-f t) 1)) - (should (= (comp-tests-conditionals-1-f nil) 2)) - (should (= (comp-tests-conditionals-2-f t) 1340)) - (should (eq (comp-tests-conditionals-2-f nil) nil))) - -(ert-deftest comp-tests-fixnum () - "Testing some fixnum inline operation." - (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)) - - (comp-test-compile #'comp-tests-fixnum-1-minus-f) - (comp-test-compile #'comp-tests-fixnum-1-plus-f) - (comp-test-compile #'comp-tests-fixnum-minus-f) - - (should (= (comp-tests-fixnum-1-minus-f 10) 9)) - (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) - (1- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-1-plus-f 10) 11)) - (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) - (1+ most-positive-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-plus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-minus-f 10) -10)) - (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) - (- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a)))) - -(ert-deftest comp-tests-arith-comp () - "Testing arithmetic comparisons." - (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)) - - - (comp-test-compile #'comp-tests-eqlsign-f) - (comp-test-compile #'comp-tests-gtr-f) - (comp-test-compile #'comp-tests-lss-f) - (comp-test-compile #'comp-tests-les-f) - (comp-test-compile #'comp-tests-geq-f) - - (should (eq (comp-tests-eqlsign-f 4 3) nil)) - (should (eq (comp-tests-eqlsign-f 3 3) t)) - (should (eq (comp-tests-eqlsign-f 2 3) nil)) - (should (eq (comp-tests-gtr-f 4 3) t)) - (should (eq (comp-tests-gtr-f 3 3) nil)) - (should (eq (comp-tests-gtr-f 2 3) nil)) - (should (eq (comp-tests-lss-f 4 3) nil)) - (should (eq (comp-tests-lss-f 3 3) nil)) - (should (eq (comp-tests-lss-f 2 3) t)) - (should (eq (comp-tests-les-f 4 3) nil)) - (should (eq (comp-tests-les-f 3 3) t)) - (should (eq (comp-tests-les-f 2 3) t)) - (should (eq (comp-tests-geq-f 4 3) t)) - (should (eq (comp-tests-geq-f 3 3) t)) - (should (eq (comp-tests-geq-f 2 3) nil))) - -(ert-deftest comp-tests-setcarcdr () - "Testing setcar setcdr." - (defun comp-tests-setcar-f (x y) - (setcar x y) - x) - (defun comp-tests-setcdr-f (x y) - (setcdr x y) - x) - - (comp-test-compile #'comp-tests-setcar-f) - (comp-test-compile #'comp-tests-setcdr-f) - - (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) - (should (equal (condition-case - err - (comp-tests-setcar-f 3 10) - (error err)) - '(wrong-type-argument consp 3))) - (should (equal (condition-case - err - (comp-tests-setcdr-f 3 10) - (error err)) - '(wrong-type-argument consp 3)))) - -(ert-deftest comp-tests-bubble-sort () - "Run bubble sort." - (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)) - - (comp-test-compile #'comp-bubble-sort-f) - - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) - (list2 (copy-sequence list1))) - (should (equal (comp-bubble-sort-f list1) - (sort list2 #'<))))) - -(ert-deftest comp-tests-list-inline () - "Test some inlined list functions." - (defun comp-tests-consp-f (x) - ;; Bconsp - (consp x)) - (defun comp-tests-car-f (x) - ;; Bsetcar - (setcar x 3)) - - (comp-test-compile #'comp-tests-consp-f) - (comp-test-compile #'comp-tests-car-f) - - (should (eq (comp-tests-consp-f '(1)) t)) - (should (eq (comp-tests-consp-f 1) nil)) - (let ((x (cons 1 2))) - (should (= (comp-tests-car-f x) 3)) - (should (equal x '(3 . 2))))) - -(ert-deftest comp-tests-num-inline () - "Test some inlined number functions." - (defun comp-tests-integerp-f (x) - ;; Bintegerp - (integerp x)) - (defun comp-tests-numberp-f (x) - ;; Bnumberp - (numberp x)) - - (comp-test-compile #'comp-tests-integerp-f) - (comp-test-compile #'comp-tests-numberp-f) - - (should (eq (comp-tests-integerp-f 1) t)) - (should (eq (comp-tests-integerp-f '(1)) nil)) - (should (eq (comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - - (should (eq (comp-tests-numberp-f 1) t)) - (should (eq (comp-tests-numberp-f 'a) nil)) - (should (eq (comp-tests-numberp-f 3.5) t))) - -(ert-deftest comp-tests-stack () - "Test some stack operation." - (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)) - - (comp-test-compile #'comp-tests-discardn-f) - (comp-test-compile #'comp-tests-insertn-f) - - (should (= (comp-tests-discardn-f 10) 2)) - - (should (string= (with-temp-buffer - (comp-tests-insertn-f "a" "b" "c" "d") - (buffer-string)) - "abcd"))) - -(ert-deftest comp-tests-non-locals () - "Test non locals." - (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)) - - (comp-test-compile #'comp-tests-condition-case-0-f) - (comp-test-compile #'comp-tests-condition-case-1-f) - (comp-test-compile #'comp-tests-catch-f) - (comp-test-compile #'comp-tests-throw-f) - - (should (string= (comp-tests-condition-case-0-f) - "arith-error Arithmetic error catched")) - (should (string= (comp-tests-condition-case-1-f) - "error foo catched")) - (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) - (should (= (catch 'foo - (comp-tests-throw-f 3))))) - -(ert-deftest comp-tests-gc () - "Try to do some longer computation to let the gc kick in." - (dotimes (_ 100000) - (comp-tests-cons-cdr-f 3)) - - (should (= (comp-tests-cons-cdr-f 3) 3))) +;; (ert-deftest comp-tests-concat () +;; "Testing concatX opcodes." +;; (defun comp-tests-concat-f (x) +;; (concat "a" "b" "c" "d" +;; (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) +;; (native-compile #'comp-tests-concat-f) + +;; (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + +;; (ert-deftest comp-tests-ffuncall () +;; "Test calling conventions." +;; (defun comp-tests-ffuncall-callee-f (x y z) +;; (list x y z)) +;; (defun comp-tests-ffuncall-caller-f () +;; (comp-tests-ffuncall-callee-f 1 2 3)) + +;; (native-compile #'comp-tests-ffuncall-caller-f) + +;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + +;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) +;; (list a b c d)) +;; (native-compile #'comp-tests-ffuncall-callee-optional-f) + +;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) +;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) +;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + +;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) +;; (list a b c)) +;; (native-compile #'comp-tests-ffuncall-callee-rest-f) + +;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) +;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) +;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + +;; (defun comp-tests-ffuncall-native-f () +;; "Call a primitive with no dedicate op." +;; (make-vector 1 nil)) + +;; (native-compile #'comp-tests-ffuncall-native-f) + +;; (should (equal (comp-tests-ffuncall-native-f) [nil])) + +;; (defun comp-tests-ffuncall-native-rest-f () +;; "Call a primitive with no dedicate op with &rest." +;; (vector 1 2 3)) + +;; (native-compile #'comp-tests-ffuncall-native-rest-f) + +;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + +;; (defun comp-tests-ffuncall-apply-many-f (x) +;; (apply #'list x)) + +;; (native-compile #'comp-tests-ffuncall-apply-many-f) + +;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + +;; (defun comp-tests-ffuncall-lambda-f (x) +;; (let ((fun (lambda (x) +;; (1+ x)))) +;; (funcall fun x))) + +;; (native-compile #'comp-tests-ffuncall-lambda-f) + +;; (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + +;; (ert-deftest comp-tests-jump-table () +;; "Testing jump tables" +;; (defun comp-tests-jump-table-1-f (x) +;; (pcase x +;; ('x 'a) +;; ('y 'b) +;; (_ 'c))) + + +;; (should (eq (comp-tests-jump-table-1-f 'x) 'a)) +;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) +;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + +;; (ert-deftest comp-tests-conditionals () +;; "Testing conditionals." +;; (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)) +;; (native-compile #'comp-tests-conditionals-1-f) +;; (native-compile #'comp-tests-conditionals-2-f) + +;; (should (= (comp-tests-conditionals-1-f t) 1)) +;; (should (= (comp-tests-conditionals-1-f nil) 2)) +;; (should (= (comp-tests-conditionals-2-f t) 1340)) +;; (should (eq (comp-tests-conditionals-2-f nil) nil))) + +;; (ert-deftest comp-tests-fixnum () +;; "Testing some fixnum inline operation." +;; (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)) + +;; (native-compile #'comp-tests-fixnum-1-minus-f) +;; (native-compile #'comp-tests-fixnum-1-plus-f) +;; (native-compile #'comp-tests-fixnum-minus-f) + +;; (should (= (comp-tests-fixnum-1-minus-f 10) 9)) +;; (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) +;; (1- most-negative-fixnum))) +;; (should (equal (condition-case err +;; (comp-tests-fixnum-1-minus-f 'a) +;; (error err)) +;; '(wrong-type-argument number-or-marker-p a))) +;; (should (= (comp-tests-fixnum-1-plus-f 10) 11)) +;; (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) +;; (1+ most-positive-fixnum))) +;; (should (equal (condition-case err +;; (comp-tests-fixnum-1-plus-f 'a) +;; (error err)) +;; '(wrong-type-argument number-or-marker-p a))) +;; (should (= (comp-tests-fixnum-minus-f 10) -10)) +;; (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) +;; (- most-negative-fixnum))) +;; (should (equal (condition-case err +;; (comp-tests-fixnum-minus-f 'a) +;; (error err)) +;; '(wrong-type-argument number-or-marker-p a)))) + +;; (ert-deftest comp-tests-arith-comp () +;; "Testing arithmetic comparisons." +;; (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)) + + +;; (native-compile #'comp-tests-eqlsign-f) +;; (native-compile #'comp-tests-gtr-f) +;; (native-compile #'comp-tests-lss-f) +;; (native-compile #'comp-tests-les-f) +;; (native-compile #'comp-tests-geq-f) + +;; (should (eq (comp-tests-eqlsign-f 4 3) nil)) +;; (should (eq (comp-tests-eqlsign-f 3 3) t)) +;; (should (eq (comp-tests-eqlsign-f 2 3) nil)) +;; (should (eq (comp-tests-gtr-f 4 3) t)) +;; (should (eq (comp-tests-gtr-f 3 3) nil)) +;; (should (eq (comp-tests-gtr-f 2 3) nil)) +;; (should (eq (comp-tests-lss-f 4 3) nil)) +;; (should (eq (comp-tests-lss-f 3 3) nil)) +;; (should (eq (comp-tests-lss-f 2 3) t)) +;; (should (eq (comp-tests-les-f 4 3) nil)) +;; (should (eq (comp-tests-les-f 3 3) t)) +;; (should (eq (comp-tests-les-f 2 3) t)) +;; (should (eq (comp-tests-geq-f 4 3) t)) +;; (should (eq (comp-tests-geq-f 3 3) t)) +;; (should (eq (comp-tests-geq-f 2 3) nil))) + +;; (ert-deftest comp-tests-setcarcdr () +;; "Testing setcar setcdr." +;; (defun comp-tests-setcar-f (x y) +;; (setcar x y) +;; x) +;; (defun comp-tests-setcdr-f (x y) +;; (setcdr x y) +;; x) + +;; (native-compile #'comp-tests-setcar-f) +;; (native-compile #'comp-tests-setcdr-f) + +;; (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) +;; (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) +;; (should (equal (condition-case +;; err +;; (comp-tests-setcar-f 3 10) +;; (error err)) +;; '(wrong-type-argument consp 3))) +;; (should (equal (condition-case +;; err +;; (comp-tests-setcdr-f 3 10) +;; (error err)) +;; '(wrong-type-argument consp 3)))) + +;; (ert-deftest comp-tests-bubble-sort () +;; "Run bubble sort." +;; (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)) + +;; (native-compile #'comp-bubble-sort-f) + +;; (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) +;; (list2 (copy-sequence list1))) +;; (should (equal (comp-bubble-sort-f list1) +;; (sort list2 #'<))))) + +;; (ert-deftest comp-tests-list-inline () +;; "Test some inlined list functions." +;; (defun comp-tests-consp-f (x) +;; ;; Bconsp +;; (consp x)) +;; (defun comp-tests-car-f (x) +;; ;; Bsetcar +;; (setcar x 3)) + +;; (native-compile #'comp-tests-consp-f) +;; (native-compile #'comp-tests-car-f) + +;; (should (eq (comp-tests-consp-f '(1)) t)) +;; (should (eq (comp-tests-consp-f 1) nil)) +;; (let ((x (cons 1 2))) +;; (should (= (comp-tests-car-f x) 3)) +;; (should (equal x '(3 . 2))))) + +;; (ert-deftest comp-tests-num-inline () +;; "Test some inlined number functions." +;; (defun comp-tests-integerp-f (x) +;; ;; Bintegerp +;; (integerp x)) +;; (defun comp-tests-numberp-f (x) +;; ;; Bnumberp +;; (numberp x)) + +;; (native-compile #'comp-tests-integerp-f) +;; (native-compile #'comp-tests-numberp-f) + +;; (should (eq (comp-tests-integerp-f 1) t)) +;; (should (eq (comp-tests-integerp-f '(1)) nil)) +;; (should (eq (comp-tests-integerp-f 3.5) nil)) +;; (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + +;; (should (eq (comp-tests-numberp-f 1) t)) +;; (should (eq (comp-tests-numberp-f 'a) nil)) +;; (should (eq (comp-tests-numberp-f 3.5) t))) + +;; (ert-deftest comp-tests-stack () +;; "Test some stack operation." +;; (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)) + +;; (native-compile #'comp-tests-discardn-f) +;; (native-compile #'comp-tests-insertn-f) + +;; (should (= (comp-tests-discardn-f 10) 2)) + +;; (should (string= (with-temp-buffer +;; (comp-tests-insertn-f "a" "b" "c" "d") +;; (buffer-string)) +;; "abcd"))) + +;; (ert-deftest comp-tests-non-locals () +;; "Test non locals." +;; (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)) + +;; (native-compile #'comp-tests-condition-case-0-f) +;; (native-compile #'comp-tests-condition-case-1-f) +;; (native-compile #'comp-tests-catch-f) +;; (native-compile #'comp-tests-throw-f) + +;; (should (string= (comp-tests-condition-case-0-f) +;; "arith-error Arithmetic error catched")) +;; (should (string= (comp-tests-condition-case-1-f) +;; "error foo catched")) +;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) +;; (should (= (catch 'foo +;; (comp-tests-throw-f 3))))) + +;; (ert-deftest comp-tests-gc () +;; "Try to do some longer computation to let the gc kick in." +;; (dotimes (_ 100000) +;; (comp-tests-cons-cdr-f 3)) + +;; (should (= (comp-tests-cons-cdr-f 3) 3))) ;;; comp-tests.el ends here From 65918ebff8ed764a3dcfb3d7f4c95a4cb854b0f7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 18:55:19 +0200 Subject: [PATCH 0180/1452] function name as annotation --- lisp/emacs-lisp/comp.el | 6 ++++++ src/comp.c | 18 ++++++++++++------ 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 934c76f8429..077e7a1eb33 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -206,6 +206,10 @@ To be used when ncall-conv is nil.") (setf (comp-mvar-slot (comp-slot)) (comp-sp)) (push (list '=slot (comp-slot) src-slot) comp-limple))) +(defun comp-emit-annotation (str) + "Emit annotation STR." + (push `(comment ,str) comp-limple)) + (defun comp-push-const (val) "Push VAL into frame. VAL is known at compile time." @@ -294,6 +298,8 @@ VAL is known at compile time." (comp-limple ())) ;; Prologue (comp-push-block 'entry) + (comp-emit-annotation (concat "Function: " + (symbol-name (comp-func-symbol-name func)))) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) diff --git a/src/comp.c b/src/comp.c index 1a74605934a..d6e09226cdd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -982,7 +982,7 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } - else if (EQ (op, Q_call_ass)) + else if (EQ (op, Qcall_ass)) { /* Ex: (=call #s(comp-mvar 6 1 nil nil nil) (call Fcar #s(comp-mvar 4 0 nil nil nil))). */ @@ -999,7 +999,7 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], res); } - else if (EQ (op, Q_par_ass)) + else if (EQ (op, Qpar_ass)) { /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1012,9 +1012,14 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], param); } - else if (EQ (op, Q_const_ass)) + else if (EQ (op, Qconst_ass)) { } + else if (EQ (op, Qcomment)) + { + /* Ex: (comment "Function: foo"). */ + emit_comment((char *) SDATA (arg0)); + } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, @@ -1997,13 +2002,14 @@ void syms_of_comp (void) { /* Limple instruction set. */ + DEFSYM (Qcomment, "comment"); DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qncall, "ncall"); - DEFSYM (Q_par_ass, "=par"); - DEFSYM (Q_call_ass, "=call"); - DEFSYM (Q_const_ass, "=const"); + DEFSYM (Qpar_ass, "=par"); + DEFSYM (Qcall_ass, "=call"); + DEFSYM (Qconst_ass, "=const"); DEFSYM (Qreturn, "return"); defsubr (&Scomp_init_ctxt); From c81aba08e3285d7864c60ea121959972a8584f35 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 21:19:40 +0200 Subject: [PATCH 0181/1452] fix list --- src/comp.c | 37 +++++++++++++++++++++++++++---------- test/src/comp-tests.el | 6 +++--- 2 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index d6e09226cdd..fe868def11d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -984,20 +984,37 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcall_ass)) { - /* Ex: (=call #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))). */ + /* + Ex: (=call #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))) + + Ex: (=call #s(comp-mvar 5 0 nil nil cons) + (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil))) + */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); eassert (FIRST (arg1) == Qcall); - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - gcc_jit_rvalue *args[] = - { retrive_mvar_val (THIRD (arg1)) }; - gcc_jit_rvalue *res = emit_call (calle, comp.lisp_obj_type, 1, args); + if (FIRST (arg1) == Qcall) + { + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + Lisp_Object call_args = XCDR (XCDR (arg1)); + ptrdiff_t nargs = list_length (call_args); + gcc_jit_rvalue *gcc_args[nargs]; + int i = 0; + FOR_EACH_TAIL (call_args) + gcc_args[i++] = retrive_mvar_val (XCAR (call_args)); + gcc_jit_rvalue *res = + emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); + } + else + eassert (false); } else if (EQ (op, Qpar_ass)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 33f5ebfdc2e..1d00dea2195 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -43,8 +43,8 @@ (ert-deftest comp-tests-list () "Testing cons car cdr." - ;; (defun comp-tests-list-f () - ;; (list 1 2 3)) + (defun comp-tests-list-f () + (list 1 2 3)) (defun comp-tests-car-f (x) ;; Bcar (car x)) @@ -58,7 +58,7 @@ ;; Bcdr_safe (cdr-safe x)) - ;; (native-compile #'comp-tests-list-f) + (native-compile #'comp-tests-list-f) (native-compile #'comp-tests-car-f) (native-compile #'comp-tests-cdr-f) (native-compile #'comp-tests-car-safe-f) From 749f4ce51f5f7348b9804e83d995a7ec22205727 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Jul 2019 21:29:32 +0200 Subject: [PATCH 0182/1452] improve function name translation --- lisp/emacs-lisp/comp.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 077e7a1eb33..bac1c6af696 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -108,6 +108,7 @@ To be used when ncall-conv is nil.") (defun comp-c-func-name (symbol-function) "Given SYMBOL-FUNCTION return a name suitable for the native code." ;; Unfortunatelly not all symbol names are valid as C function names... + ;; Nassi's algorithm. (let* ((orig-name (symbol-name symbol-function)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 @@ -117,7 +118,9 @@ To be used when ncall-conv is nil.") do (aset str (1+ j) (aref byte 1)) finally return str)) (human-readable (replace-regexp-in-string - (rx (not (any "a-z"))) "" orig-name))) + "-" "_" orig-name)) + (human-readable (replace-regexp-in-string + (rx (not (any "a-z_"))) "" human-readable))) (concat "F" crypted "_" human-readable))) (defun comp-decrypt-lambda-list (x) @@ -298,7 +301,7 @@ VAL is known at compile time." (comp-limple ())) ;; Prologue (comp-push-block 'entry) - (comp-emit-annotation (concat "Function: " + (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn From 6d0d29cae64051e61393be8f1ad1187e218cad40 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Jul 2019 22:10:21 +0200 Subject: [PATCH 0183/1452] call ref works --- src/comp.c | 34 ++++++++++++++++++++++++++++++++-- test/src/comp-tests.el | 2 +- 2 files changed, 33 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index fe868def11d..1d6eaf6648e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -43,6 +43,8 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (x)) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) +#define FORTH(x) \ + XCAR (XCDR (XCDR (XCDR (x)))) #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern (STR(fun)), arg) @@ -994,7 +996,7 @@ emit_limple_inst (Lisp_Object inst) */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); - eassert (FIRST (arg1) == Qcall); + if (FIRST (arg1) == Qcall) { char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); @@ -1013,8 +1015,28 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], res); } + else if ((FIRST (arg1) == Qcallref)) + { + /* Ex: (=call #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); + EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + gcc_jit_rvalue *gcc_args[2] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address ( + comp.frame[base_ptr], + NULL) }; + gcc_jit_rvalue *res = + emit_call (calle, comp.lisp_obj_type, 2, gcc_args); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); + } else - eassert (false); + error ("LIMPLE inconsistent arg1 for op =call"); } else if (EQ (op, Qpar_ass)) { @@ -1031,6 +1053,13 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qconst_ass)) { + /* EX: (=const #s(comp-mvar 9 1 t 3 nil) 3). */ + Lisp_Object arg1 = THIRD (inst); + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + emit_lisp_obj_from_ptr (arg1)); } else if (EQ (op, Qcomment)) { @@ -2023,6 +2052,7 @@ syms_of_comp (void) DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); + DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qpar_ass, "=par"); DEFSYM (Qcall_ass, "=call"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1d00dea2195..a8445c79c8f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -64,7 +64,7 @@ (native-compile #'comp-tests-car-safe-f) (native-compile #'comp-tests-cdr-safe-f) - ;; (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list-f) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) (should (= (condition-case err From 8f1492c0b7b3ca684b3f88dc709b882cb758aad3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Jul 2019 22:39:42 +0200 Subject: [PATCH 0184/1452] simplify limple instruction set --- lisp/emacs-lisp/comp.el | 8 ++-- src/comp.c | 81 ++++++++++++++++++++++------------------- 2 files changed, 47 insertions(+), 42 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bac1c6af696..0270788e215 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -197,7 +197,7 @@ To be used when ncall-conv is nil.") (make-comp-mvar :slot (comp-sp) :type (alist-get (cadr src-slot) comp-known-ret-types))) - (push (list '=call (comp-slot) src-slot) comp-limple)) + (push (list 'set (comp-slot) src-slot) comp-limple)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -207,7 +207,7 @@ To be used when ncall-conv is nil.") (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list '=slot (comp-slot) src-slot) comp-limple))) + (push (list 'set (comp-slot) src-slot) comp-limple))) (defun comp-emit-annotation (str) "Emit annotation STR." @@ -220,7 +220,7 @@ VAL is known at compile time." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) - (push (list '=const (comp-slot) val) comp-limple)) + (push (list 'setimm (comp-slot) val) comp-limple)) (defun comp-push-block (bblock) "Push basic block BBLOCK." @@ -306,7 +306,7 @@ VAL is known at compile time." (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) - (push `(=par ,(comp-slot) ,i) comp-limple))) + (push `(setpar ,(comp-slot) ,i) comp-limple))) (push '(jump body) comp-limple) ;; Body (comp-push-block 'body) diff --git a/src/comp.c b/src/comp.c index 1d6eaf6648e..cbbc5f03782 100644 --- a/src/comp.c +++ b/src/comp.c @@ -951,12 +951,12 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ /* } */ -/* Retrive an r-value from a meta variable. +/* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it - from the frame. */ + from frame. */ static gcc_jit_rvalue * -retrive_mvar_val (Lisp_Object mvar) +emit_mvar_val (Lisp_Object mvar) { if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) return @@ -971,6 +971,7 @@ emit_limple_inst (Lisp_Object inst) { Lisp_Object op = XCAR (inst); Lisp_Object arg0 = SECOND (inst); + gcc_jit_rvalue *res; if (EQ (op, Qblock)) { @@ -984,40 +985,43 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } - else if (EQ (op, Qcall_ass)) + else if (EQ (op, Qset)) { - /* - Ex: (=call #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) - - Ex: (=call #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) - */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); - if (FIRST (arg1) == Qcall) + if (EQ (Ftype_of (arg1), Qcomp_mvar)) { - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + /* + Ex: (= #s(comp-mvar 6 2 nil nil nil) + #s(comp-mvar 6 0 nil nil nil)). + */ + res = emit_mvar_val (arg1); + } + else if (EQ (FIRST (arg1), Qcall)) + { + /* + Ex: (= #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))) + Ex: (= #s(comp-mvar 5 0 nil nil cons) + (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil))) + */ + + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); Lisp_Object call_args = XCDR (XCDR (arg1)); ptrdiff_t nargs = list_length (call_args); gcc_jit_rvalue *gcc_args[nargs]; int i = 0; FOR_EACH_TAIL (call_args) - gcc_args[i++] = retrive_mvar_val (XCAR (call_args)); - gcc_jit_rvalue *res = - emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); - - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + gcc_args[i++] = emit_mvar_val (XCAR (call_args)); + res = emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); } - else if ((FIRST (arg1) == Qcallref)) + else if (EQ (FIRST (arg1), Qcallref)) { - /* Ex: (=call #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ + /* Ex: (= #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); @@ -1028,17 +1032,18 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_lvalue_get_address ( comp.frame[base_ptr], NULL) }; - gcc_jit_rvalue *res = - emit_call (calle, comp.lisp_obj_type, 2, gcc_args); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + res = emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } else - error ("LIMPLE inconsistent arg1 for op =call"); + { + error ("LIMPLE inconsistent arg1 for op ="); + } + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } - else if (EQ (op, Qpar_ass)) + else if (EQ (op, Qsetpar)) { /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1051,9 +1056,9 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], param); } - else if (EQ (op, Qconst_ass)) + else if (EQ (op, Qsetimm)) { - /* EX: (=const #s(comp-mvar 9 1 t 3 nil) 3). */ + /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ Lisp_Object arg1 = THIRD (inst); EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_block_add_assignment (comp.block, @@ -1070,7 +1075,7 @@ emit_limple_inst (Lisp_Object inst) { gcc_jit_block_end_with_return (comp.block, NULL, - retrive_mvar_val (arg0)); + emit_mvar_val (arg0)); } } @@ -2054,10 +2059,10 @@ syms_of_comp (void) DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); - DEFSYM (Qpar_ass, "=par"); - DEFSYM (Qcall_ass, "=call"); - DEFSYM (Qconst_ass, "=const"); + DEFSYM (Qsetpar, "setpar"); + DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); + DEFSYM (Qcomp_mvar, "comp-mvar"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 973a7b149f1362c4201d38bffeabbf857e7bb6d5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 11:33:15 +0200 Subject: [PATCH 0185/1452] some consistency rework one test + --- lisp/emacs-lisp/comp.el | 54 +++++++++++++++++++++-------------------- test/src/comp-tests.el | 20 +++++++-------- 2 files changed, 38 insertions(+), 36 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0270788e215..68bc770ff95 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -189,15 +189,19 @@ To be used when ncall-conv is nil.") "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-push-call (src-slot) - "Push call SRC-SLOT into frame." - (cl-assert src-slot) - (cl-incf (comp-sp)) +(defun comp-emit-call (call) + "Emit CALL." + (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :type (alist-get (cadr src-slot) + :type (alist-get (cadr call) comp-known-ret-types))) - (push (list 'set (comp-slot) src-slot) comp-limple)) + (push (list 'set (comp-slot) call) comp-limple)) + +(defun comp-push-call (call) + "Push call CALL into frame." + (cl-incf (comp-sp)) + (comp-emit-call call)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -222,7 +226,7 @@ VAL is known at compile time." :constant val)) (push (list 'setimm (comp-slot) val) comp-limple)) -(defun comp-push-block (bblock) +(defun comp-emit-block (bblock) "Push basic block BBLOCK." (push bblock (comp-func-blocks comp-func)) ;; Every new block we are forced to wipe out all the frame. @@ -237,15 +241,14 @@ VAL is known at compile time." (defun comp-limplify-listn (n) "Limplify list N." - (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) + (comp-emit-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) - (comp-pop 2) - (comp-push-call `(call Fcons - ,(comp-slot-next) - ,(comp-slot-n (+ 2 (comp-sp))))))) + (comp-pop 1) + (comp-emit-call `(call Fcons + ,(comp-slot) + ,(comp-slot-n (1+ (comp-sp))))))) (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." @@ -258,26 +261,25 @@ VAL is known at compile time." :const-vld t :constant (cadr inst))))) ;; ('byte-varset - ;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) + ;; (comp-emit-call `(call Fsymbol_value ,(cadr inst)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus - (comp-pop 2) - (comp-push-call `(callref Fplus 2 ,(comp-sp)))) + (comp-pop 1) + (comp-emit-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-cons + (comp-pop 1) + (comp-emit-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) ('byte-car - (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-slot)))) + (comp-emit-call `(call Fcar ,(comp-slot)))) ('byte-cdr - (comp-pop 1) - (comp-push-call `(call Fcdr ,(comp-slot)))) + (comp-emit-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe - (comp-pop 1) - (comp-push-call `(call Fcar_safe ,(comp-slot)))) + (comp-emit-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe - (comp-pop 1) - (comp-push-call `(call Fcdr_safe ,(comp-slot)))) + (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -300,7 +302,7 @@ VAL is known at compile time." :frame (comp-limple-frame-new-frame frame-size))) (comp-limple ())) ;; Prologue - (comp-push-block 'entry) + (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) @@ -309,7 +311,7 @@ VAL is known at compile time." (push `(setpar ,(comp-slot) ,i) comp-limple))) (push '(jump body) comp-limple) ;; Body - (comp-push-block 'body) + (comp-emit-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) ;; Prologue block must be first diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a8445c79c8f..0aea66f974b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -82,18 +82,18 @@ (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-safe-f 'a)))) -;; (ert-deftest comp-tests-cons-car-cdr () -;; "Testing cons car cdr." -;; (defun comp-tests-cons-car-f () -;; (car (cons 1 2))) -;; (native-compile #'comp-tests-cons-car-f) +(ert-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (defun comp-tests-cons-car-f () + (car (cons 1 2))) + (native-compile #'comp-tests-cons-car-f) -;; (defun comp-tests-cons-cdr-f (x) -;; (cdr (cons 'foo x))) -;; (native-compile #'comp-tests-cons-cdr-f) + (defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + (native-compile #'comp-tests-cons-cdr-f) -;; (should (= (comp-tests-cons-car-f) 1)) -;; (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) ;; (ert-deftest comp-tests-varset () ;; "Testing varset." From 73cb29c3fb6d56f32f77ec201f9b61ac77e57290 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 15:48:02 +0200 Subject: [PATCH 0186/1452] varset support 5 test passing --- lisp/emacs-lisp/comp.el | 14 ++++++-- src/comp.c | 79 ++++++++++++++++++++++++++++++----------- test/src/comp-tests.el | 26 +++++++------- 3 files changed, 83 insertions(+), 36 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 68bc770ff95..05f17e43d64 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -20,6 +20,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . +;;; Commentary: +;; This code is an attempt to make a Carrera out of a turbocharged VW Bug. +;; Or, to put it another way to make the pig fly. + ;;; Code: (require 'bytecomp) @@ -260,8 +264,12 @@ VAL is known at compile time." (comp-push-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t :constant (cadr inst))))) - ;; ('byte-varset - ;; (comp-emit-call `(call Fsymbol_value ,(cadr inst)))) + ('byte-varset + (comp-emit-call `(call set_internal + ,(make-comp-mvar + :const-vld t + :constant (cadr inst)) + ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref @@ -280,6 +288,8 @@ VAL is known at compile time." (comp-emit-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) + ('byte-length + (comp-emit-call `(call Flength ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 diff --git a/src/comp.c b/src/comp.c index cbbc5f03782..25598aa20c1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -966,6 +966,58 @@ emit_mvar_val (Lisp_Object mvar) return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); } +static gcc_jit_rvalue * +emit_limple_call (Lisp_Object arg1) +{ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + Lisp_Object call_args = XCDR (XCDR (arg1)); + int i = 0; + + if (calle[0] == 'F') + { + /* + Ex: (= #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))) + + Ex: (= #s(comp-mvar 5 0 nil nil cons) + (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil))) + */ + + ptrdiff_t nargs = list_length (call_args); + gcc_jit_rvalue *gcc_args[nargs]; + FOR_EACH_TAIL (call_args) + gcc_args[i++] = emit_mvar_val (XCAR (call_args)); + + return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + } + else if (!strcmp (calle, "set_internal")) + { + /* + Ex: (set #s(comp-mvar 8 1 nil nil nil) + (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil))) + */ + /* TODO: Inline the most common case. */ + eassert (list_length (call_args) == 2); + gcc_jit_rvalue *gcc_args[4]; + FOR_EACH_TAIL (call_args) + gcc_args[i++] = emit_mvar_val (XCAR (call_args)); + gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); + gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + gcc_jit_block_add_eval ( + comp.block, + NULL, + emit_call ("set_internal", comp.void_type , 4, gcc_args)); + + return NULL; + } + error ("LIMPLE inconsiste call"); +} + static void emit_limple_inst (Lisp_Object inst) { @@ -1000,23 +1052,7 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (FIRST (arg1), Qcall)) { - /* - Ex: (= #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) - - Ex: (= #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) - */ - - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - Lisp_Object call_args = XCDR (XCDR (arg1)); - ptrdiff_t nargs = list_length (call_args); - gcc_jit_rvalue *gcc_args[nargs]; - int i = 0; - FOR_EACH_TAIL (call_args) - gcc_args[i++] = emit_mvar_val (XCAR (call_args)); - res = emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + res = emit_limple_call (arg1); } else if (EQ (FIRST (arg1), Qcallref)) { @@ -1038,10 +1074,11 @@ emit_limple_inst (Lisp_Object inst) { error ("LIMPLE inconsistent arg1 for op ="); } - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + if (res) + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qsetpar)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0aea66f974b..64edddf4c04 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -95,23 +95,23 @@ (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-cdr-f 3) 3))) -;; (ert-deftest comp-tests-varset () -;; "Testing varset." -;; (defun comp-tests-varset-f () -;; (setq comp-tests-var1 55)) -;; (native-compile #'comp-tests-varset-f) +(ert-deftest comp-tests-varset () + "Testing varset." + (defun comp-tests-varset-f () + (setq comp-tests-var1 55)) + (native-compile #'comp-tests-varset-f) -;; (comp-tests-varset-f) + (comp-tests-varset-f) -;; (should (= comp-tests-var1 55))) + (should (= comp-tests-var1 55))) -;; (ert-deftest comp-tests-length () -;; "Testing length." -;; (defun comp-tests-length-f () -;; (length '(1 2 3))) -;; (native-compile #'comp-tests-length-f) +(ert-deftest comp-tests-length () + "Testing length." + (defun comp-tests-length-f () + (length '(1 2 3))) + (native-compile #'comp-tests-length-f) -;; (should (= (comp-tests-length-f) 3))) + (should (= (comp-tests-length-f) 3))) ;; (ert-deftest comp-tests-aref-aset () ;; "Testing aref and aset." From ba8ca065a7cde2f8221767ddb632b56eeefb29b5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 16:34:59 +0200 Subject: [PATCH 0187/1452] let limple support calls with no assignment --- lisp/emacs-lisp/comp.el | 52 ++++++++++++----------- src/comp.c | 93 +++++++++++++++++++---------------------- 2 files changed, 70 insertions(+), 75 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 05f17e43d64..1094acf1ea3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,19 +193,23 @@ To be used when ncall-conv is nil.") "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-emit-call (call) - "Emit CALL." +(defun comp-emit (x) + "Emit X into current LIMPLE ir.." + (push x comp-limple)) + +(defun comp-emit-set-call (call) + "Emit CALL assigning the result the the current slot frame.." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :type (alist-get (cadr call) comp-known-ret-types))) - (push (list 'set (comp-slot) call) comp-limple)) + (comp-emit (list 'set (comp-slot) call))) (defun comp-push-call (call) - "Push call CALL into frame." + "Increase sp and call `comp-emit-set-call' to emit CALL." (cl-incf (comp-sp)) - (comp-emit-call call)) + (comp-emit-set-call call)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -215,11 +219,11 @@ To be used when ncall-conv is nil.") (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list 'set (comp-slot) src-slot) comp-limple))) + (comp-emit (list 'set (comp-slot) src-slot)))) (defun comp-emit-annotation (str) "Emit annotation STR." - (push `(comment ,str) comp-limple)) + (comp-emit `(comment ,str))) (defun comp-push-const (val) "Push VAL into frame. @@ -228,7 +232,7 @@ VAL is known at compile time." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) - (push (list 'setimm (comp-slot) val) comp-limple)) + (comp-emit (list 'setimm (comp-slot) val))) (defun comp-emit-block (bblock) "Push basic block BBLOCK." @@ -237,7 +241,7 @@ VAL is known at compile time." ;; This will be superseded by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) - (push `(block ,bblock) comp-limple)) + (comp-emit `(block ,bblock))) (defun comp-pop (n) "Pop N elements from the meta-stack." @@ -245,12 +249,12 @@ VAL is known at compile time." (defun comp-limplify-listn (n) "Limplify list N." - (comp-emit-call `(call Fcons ,(comp-slot) + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) (comp-pop 1) - (comp-emit-call `(call Fcons + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-n (1+ (comp-sp))))))) @@ -265,31 +269,31 @@ VAL is known at compile time." :const-vld t :constant (cadr inst))))) ('byte-varset - (comp-emit-call `(call set_internal - ,(make-comp-mvar - :const-vld t - :constant (cadr inst)) - ,(comp-slot)))) + (comp-emit `(call set_internal + ,(make-comp-mvar + :const-vld t + :constant (cadr inst)) + ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 1) - (comp-emit-call `(callref Fplus 2 ,(comp-sp)))) + (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) ('byte-cons (comp-pop 1) - (comp-emit-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) ('byte-car - (comp-emit-call `(call Fcar ,(comp-slot)))) + (comp-emit-set-call `(call Fcar ,(comp-slot)))) ('byte-cdr - (comp-emit-call `(call Fcdr ,(comp-slot)))) + (comp-emit-set-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe - (comp-emit-call `(call Fcar_safe ,(comp-slot)))) + (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe - (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) + (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) ('byte-length - (comp-emit-call `(call Flength ,(comp-slot)))) + (comp-emit-set-call `(call Flength ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -299,7 +303,7 @@ VAL is known at compile time." ('byte-list4 (comp-limplify-listn 4)) ('byte-return - (push (list 'return (comp-slot)) comp-limple) + (comp-emit (list 'return (comp-slot))) `(return ,(comp-slot))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) diff --git a/src/comp.c b/src/comp.c index 25598aa20c1..f164bf892a5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -976,12 +976,10 @@ emit_limple_call (Lisp_Object arg1) if (calle[0] == 'F') { /* - Ex: (= #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - Ex: (= #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) */ ptrdiff_t nargs = list_length (call_args); @@ -994,10 +992,9 @@ emit_limple_call (Lisp_Object arg1) else if (!strcmp (calle, "set_internal")) { /* - Ex: (set #s(comp-mvar 8 1 nil nil nil) - (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil))) + Ex: (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ eassert (list_length (call_args) == 2); @@ -1008,14 +1005,26 @@ emit_limple_call (Lisp_Object arg1) gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - gcc_jit_block_add_eval ( - comp.block, - NULL, - emit_call ("set_internal", comp.void_type , 4, gcc_args)); - - return NULL; + return emit_call ("set_internal", comp.void_type , 4, gcc_args); } - error ("LIMPLE inconsiste call"); + error ("LIMPLE call is inconsistet"); +} + +static gcc_jit_rvalue * +emit_limple_call_ref (Lisp_Object arg1) +{ + /* Ex: (callref Fplus 2 0). */ + + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); + EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + gcc_jit_rvalue *gcc_args[2] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; + + return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } static void @@ -1032,53 +1041,35 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qjump)) { - /* Unconditional branch. */ + /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } + else if (EQ (op, Qcall)) + { + gcc_jit_block_add_eval (comp.block, + NULL, + emit_limple_call (inst)); + } else if (EQ (op, Qset)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); if (EQ (Ftype_of (arg1), Qcomp_mvar)) - { - /* - Ex: (= #s(comp-mvar 6 2 nil nil nil) - #s(comp-mvar 6 0 nil nil nil)). - */ - res = emit_mvar_val (arg1); - } + res = emit_mvar_val (arg1); else if (EQ (FIRST (arg1), Qcall)) - { - res = emit_limple_call (arg1); - } + res = emit_limple_call (arg1); else if (EQ (FIRST (arg1), Qcallref)) - { - /* Ex: (= #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ - - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); - EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); - gcc_jit_rvalue *gcc_args[2] = - { gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address ( - comp.frame[base_ptr], - NULL) }; - res = emit_call (calle, comp.lisp_obj_type, 2, gcc_args); - } + res = emit_limple_call_ref (arg1); else - { - error ("LIMPLE inconsistent arg1 for op ="); - } - if (res) - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + error ("LIMPLE inconsistent arg1 for op ="); + eassert (res); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qsetpar)) { @@ -1105,7 +1096,7 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcomment)) { - /* Ex: (comment "Function: foo"). */ + /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } else if (EQ (op, Qreturn)) From 2e20dca7a090b3821e78451f83930b689f5499c7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 17:08:15 +0200 Subject: [PATCH 0188/1452] add discard aref aset --- lisp/emacs-lisp/comp.el | 21 ++++++++++++++++++--- test/src/comp-tests.el | 16 ++++++++-------- 2 files changed, 26 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1094acf1ea3..712cade3829 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -198,12 +198,14 @@ To be used when ncall-conv is nil.") (push x comp-limple)) (defun comp-emit-set-call (call) - "Emit CALL assigning the result the the current slot frame.." + "Emit CALL assigning the result the the current slot frame. +If the calle function is known to have a return type propagate it." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :type (alist-get (cadr call) - comp-known-ret-types))) + :type (when (> comp-speed 0) + (alist-get (cadr call) + comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) (defun comp-push-call (call) @@ -262,6 +264,8 @@ VAL is known at compile time." "Limplify LAP instruction INST accumulating in `comp-limple'." (let ((op (car inst))) (pcase op + ('byte-discard + (comp-pop 1)) ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref @@ -281,6 +285,17 @@ VAL is known at compile time." ('byte-plus (comp-pop 1) (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-aref + (comp-pop 1) + (comp-emit-set-call `(call Faref + ,(comp-slot) + ,(comp-slot-next)))) + ('byte-aset + (comp-pop 2) + (comp-emit-set-call `(call Faset + ,(comp-slot) + ,(comp-slot-next) + ,(comp-slot-n (+ 2 (comp-sp)))))) ('byte-cons (comp-pop 1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 64edddf4c04..00bb2e09321 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -113,15 +113,15 @@ (should (= (comp-tests-length-f) 3))) -;; (ert-deftest comp-tests-aref-aset () -;; "Testing aref and aset." -;; (defun comp-tests-aref-aset-f () -;; (let ((vec [1 2 3])) -;; (aset vec 2 100) -;; (aref vec 2))) -;; (native-compile #'comp-tests-aref-aset-f) +(ert-deftest comp-tests-aref-aset () + "Testing aref and aset." + (defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (aset vec 2 100) + (aref vec 2))) + (native-compile #'comp-tests-aref-aset-f) -;; (should (= (comp-tests-aref-aset-f) 100))) + (should (= (comp-tests-aref-aset-f) 100))) ;; (ert-deftest comp-tests-symbol-value () ;; "Testing aref and aset." From fdbdf3da7f0dc09bb04a919b1840652b327b64b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 17:24:44 +0200 Subject: [PATCH 0189/1452] symbol-value +1 test --- lisp/emacs-lisp/comp.el | 9 ++++++--- test/src/comp-tests.el | 14 +++++++------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 712cade3829..2f3c6899337 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,6 +37,8 @@ (defconst comp-debug t) +(defvar comp-speed 2) + (defconst comp-passes '(comp-recuparate-lap comp-limplify) "Passes to be executed in order.") @@ -268,15 +270,16 @@ VAL is known at compile time." (comp-pop 1)) ('byte-dup (comp-push-slot-n (comp-sp))) + ('byte-symbol-value + (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) ('byte-varref (comp-push-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t :constant (cadr inst))))) ('byte-varset (comp-emit `(call set_internal - ,(make-comp-mvar - :const-vld t - :constant (cadr inst)) + ,(make-comp-mvar :const-vld t + :constant (cadr inst)) ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 00bb2e09321..1030900752d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -123,14 +123,14 @@ (should (= (comp-tests-aref-aset-f) 100))) -;; (ert-deftest comp-tests-symbol-value () -;; "Testing aref and aset." -;; (defvar comp-tests-var2 3) -;; (defun comp-tests-symbol-value-f () -;; (symbol-value 'comp-tests-var2)) -;; (native-compile #'comp-tests-symbol-value-f) +(ert-deftest comp-tests-symbol-value () + "Testing aref and aset." + (defvar comp-tests-var2 3) + (defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + (native-compile #'comp-tests-symbol-value-f) -;; (should (= (comp-tests-symbol-value-f) 3))) + (should (= (comp-tests-symbol-value-f) 3))) ;; (ert-deftest comp-tests-concat () ;; "Testing concatX opcodes." From 4a0379bdb41a6044978d0b5ffb2a5ece1984e404 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jul 2019 18:28:00 +0200 Subject: [PATCH 0190/1452] reworking comp.el --- lisp/emacs-lisp/comp.el | 50 +++++++++++++++++++---------------------- 1 file changed, 23 insertions(+), 27 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f3c6899337..5731a00b2d3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -210,16 +210,10 @@ If the calle function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) -(defun comp-push-call (call) - "Increase sp and call `comp-emit-set-call' to emit CALL." - (cl-incf (comp-sp)) - (comp-emit-set-call call)) - -(defun comp-push-slot-n (n) - "Push slot number N into frame." +(defun comp-copy-slot-n (n) + "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) - (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -229,10 +223,8 @@ If the calle function is known to have a return type propagate it." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-push-const (val) - "Push VAL into frame. -VAL is known at compile time." - (cl-incf (comp-sp)) +(defun comp-set-const (val) + "Set constant VAL to current slot." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) @@ -247,9 +239,9 @@ VAL is known at compile time." (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) (comp-emit `(block ,bblock))) -(defun comp-pop (n) - "Pop N elements from the meta-stack." - (cl-decf (comp-sp) n)) +(defun comp-stack-adjust (n) + "Move sp by N." + (cl-incf (comp-sp) n)) (defun comp-limplify-listn (n) "Limplify list N." @@ -257,7 +249,7 @@ VAL is known at compile time." ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-n (1+ (comp-sp))))))) @@ -267,40 +259,44 @@ VAL is known at compile time." (let ((op (car inst))) (pcase op ('byte-discard - (comp-pop 1)) + (comp-stack-adjust -1)) ('byte-dup - (comp-push-slot-n (comp-sp))) + (comp-stack-adjust 1) + (comp-copy-slot-n (1- (comp-sp)))) ('byte-symbol-value (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) ('byte-varref - (comp-push-call `(call Fsymbol_value ,(make-comp-mvar - :const-vld t - :constant (cadr inst))))) + (comp-stack-adjust 1) + (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar + :const-vld t + :constant (cadr inst))))) ('byte-varset (comp-emit `(call set_internal ,(make-comp-mvar :const-vld t :constant (cadr inst)) ,(comp-slot)))) ('byte-constant - (comp-push-const (cadr inst))) + (comp-stack-adjust 1) + (comp-set-const (cadr inst))) ('byte-stack-ref - (comp-push-slot-n (- (comp-sp) (cdr inst)))) + (comp-stack-adjust 1) + (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) ('byte-plus - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) ('byte-aref - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(call Faref ,(comp-slot) ,(comp-slot-next)))) ('byte-aset - (comp-pop 2) + (comp-stack-adjust -2) (comp-emit-set-call `(call Faset ,(comp-slot) ,(comp-slot-next) ,(comp-slot-n (+ 2 (comp-sp)))))) ('byte-cons - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) ('byte-car (comp-emit-set-call `(call Fcar ,(comp-slot)))) From 210a3c0b3ad2a944bfed4e87a5039a9e4e14329a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 09:53:06 +0200 Subject: [PATCH 0191/1452] comp-op-case in place plus other rework --- lisp/emacs-lisp/comp.el | 246 +++++++++++++++++++++++++++++++--------- 1 file changed, 192 insertions(+), 54 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5731a00b2d3..3c6ce6e5828 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,6 +54,16 @@ ;; allocating memory? (these are technically not side effect free) ) +(eval-when-compile + (defconst comp-op-stack-info + (cl-loop with h = (make-hash-table) + for k across byte-code-vector + for v across byte-stack+-info + when k + do (puthash k v h) + finally return h) + "Hash table lap-op -> stack adjustment.")) + (cl-defstruct comp-args (min nil :type number :documentation "Minimum number of arguments allowed") @@ -183,8 +193,19 @@ To be used when ncall-conv is nil.") "Current stack pointer." '(comp-limple-frame-sp comp-frame)) +(defmacro comp-with-sp (sp &rest body) + "Execute BODY setting the stack pointer to SP. +Restore the original value afterwads." + (declare (debug (form body)) + (indent 1)) + `(let ((orig-sp (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) orig-sp))) + (defmacro comp-slot-n (n) "Slot N into the meta-stack." + (declare (debug (form))) `(aref (comp-limple-frame-frame comp-frame) ,n)) (defmacro comp-slot () @@ -245,81 +266,198 @@ If the calle function is known to have a return type propagate it." (defun comp-limplify-listn (n) "Limplify list N." - (comp-emit-set-call `(call Fcons ,(comp-slot) - ,(make-comp-mvar :const-vld t - :constant nil))) - (dotimes (_ (1- n)) - (comp-stack-adjust -1) + (comp-with-sp (1- n) (comp-emit-set-call `(call Fcons - ,(comp-slot) - ,(comp-slot-n (1+ (comp-sp))))))) + ,(comp-slot) + ,(make-comp-mvar :const-vld t + :constant nil)))) + (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) + do (comp-with-sp sp + (comp-emit-set-call `(call Fcons + ,(comp-slot) + ,(comp-slot-next)))))) + +(defmacro comp-op-case (&rest cases) + "Expand CASES to the corresponding pcase." + (declare (debug (body)) + (indent defun)) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + if body + collect `(',op + (comp-emit-annotation ,(concat "LAP op " op-name)) + (comp-stack-adjust ,(if sp-delta sp-delta 0)) + (progn ,@body)) + else + collect `(',op (error ,(concat "Unsupported LAP op " + op-name)))) + (_ (error "Unexpected LAP op %s" (symbol-name op))))) (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." (let ((op (car inst))) - (pcase op - ('byte-discard - (comp-stack-adjust -1)) - ('byte-dup - (comp-stack-adjust 1) - (comp-copy-slot-n (1- (comp-sp)))) - ('byte-symbol-value - (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) - ('byte-varref - (comp-stack-adjust 1) + (comp-op-case + (byte-stack-ref + (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) + (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t :constant (cadr inst))))) - ('byte-varset + (byte-varset (comp-emit `(call set_internal ,(make-comp-mvar :const-vld t :constant (cadr inst)) ,(comp-slot)))) - ('byte-constant - (comp-stack-adjust 1) - (comp-set-const (cadr inst))) - ('byte-stack-ref - (comp-stack-adjust 1) - (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) - ('byte-plus - (comp-stack-adjust -1) - (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-aref - (comp-stack-adjust -1) + (byte-varbind) + (byte-call) + (byte-unbind) + (byte-pophandler) + (byte-pushconditioncase) + (byte-pushcatch) + (byte-nth) + (byte-symbolp) + (byte-consp) + (byte-stringp) + (byte-listp) + (byte-eq) + (byte-memq) + (byte-not) + (byte-car + (comp-emit-set-call `(call Fcar ,(comp-slot)))) + (byte-cdr + (comp-emit-set-call `(call Fcdr ,(comp-slot)))) + (byte-cons + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (byte-list1 + (comp-limplify-listn 1)) + (byte-list2 + (comp-limplify-listn 2)) + (byte-list3 + (comp-limplify-listn 3)) + (byte-list4 + (comp-limplify-listn 4)) + (byte-length + (comp-emit-set-call `(call Flength ,(comp-slot)))) + (byte-aref (comp-emit-set-call `(call Faref ,(comp-slot) ,(comp-slot-next)))) - ('byte-aset - (comp-stack-adjust -2) + (byte-aset (comp-emit-set-call `(call Faset ,(comp-slot) ,(comp-slot-next) ,(comp-slot-n (+ 2 (comp-sp)))))) - ('byte-cons - (comp-stack-adjust -1) - (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) - ('byte-car - (comp-emit-set-call `(call Fcar ,(comp-slot)))) - ('byte-cdr - (comp-emit-set-call `(call Fcdr ,(comp-slot)))) - ('byte-car-safe + (byte-symbol-value + (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) + (byte-symbol-function) + (byte-set) + (byte-fset) + (byte-get) + (byte-substring) + (byte-concat2) + (byte-concat3) + (byte-concat4) + (byte-sub1) + (byte-add1) + (byte-eqlsign) + (byte-gtr) + (byte-lss) + (byte-leq) + (byte-geq) + (byte-diff) + (byte-negate) + (byte-plus + (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) + (byte-max) + (byte-min) + (byte-mult) + (byte-point) + (byte-goto-char) + (byte-insert) + (byte-point-max) + (byte-point-min) + (byte-char-after) + (byte-following-char) + (byte-preceding-char) + (byte-current-column) + (byte-indent-to) + (byte-scan-buffer-OBSOLETE) + (byte-eolp) + (byte-eobp) + (byte-bolp) + (byte-bobp) + (byte-current-buffer) + (byte-set-buffer) + (byte-save-current-buffer) + (byte-set-mark-OBSOLETE) + (byte-interactive-p-OBSOLETE) + (byte-forward-char) + (byte-forward-word) + (byte-skip-chars-forward) + (byte-skip-chars-backward) + (byte-forward-line) + (byte-char-syntax) + (byte-buffer-substring) + (byte-delete-region) + (byte-narrow-to-region) + (byte-widen) + (byte-end-of-line) + (byte-constant2) + (byte-goto) + (byte-goto-if-nil) + (byte-goto-if-not-nil) + (byte-goto-if-nil-else-pop) + (byte-goto-if-not-nil-else-pop) + (byte-return + (comp-emit (list 'return (comp-slot-next))) + `(return ,(comp-slot-next))) + (byte-discard t) + (byte-dup + (comp-copy-slot-n (1- (comp-sp)))) + (byte-save-excursion) + (byte-save-window-excursion-OBSOLETE) + (byte-save-restriction) + (byte-catch) + (byte-unwind-protect) + (byte-condition-case) + (byte-temp-output-buffer-setup-OBSOLETE) + (byte-temp-output-buffer-show-OBSOLETE) + (byte-unbind-all) + (byte-set-marker) + (byte-match-beginning) + (byte-match-end) + (byte-upcase) + (byte-downcase) + (byte-string=) + (byte-string<) + (byte-equal) + (byte-nthcdr) + (byte-elt) + (byte-member) + (byte-assq) + (byte-nreverse) + (byte-setcar) + (byte-setcdr) + (byte-car-safe (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) - ('byte-cdr-safe + (byte-cdr-safe (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) - ('byte-length - (comp-emit-set-call `(call Flength ,(comp-slot)))) - ('byte-list1 - (comp-limplify-listn 1)) - ('byte-list2 - (comp-limplify-listn 2)) - ('byte-list3 - (comp-limplify-listn 3)) - ('byte-list4 - (comp-limplify-listn 4)) - ('byte-return - (comp-emit (list 'return (comp-slot))) - `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op)))))) + (byte-nconc) + (byte-quo) + (byte-rem) + (byte-numberp) + (byte-integerp) + (byte-listN) + (byte-concatN) + (byte-insertN) + (byte-stack-set) + (byte-stack-set2) + (byte-discardN) + (byte-switch) + (byte-constant + (comp-set-const (cadr inst)))))) (defun comp-limplify (func) "Given FUNC and return compute its LIMPLE ir." From ac297b67bb5fbd4488023ca693a1dc62f012da5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 10:57:46 +0200 Subject: [PATCH 0192/1452] concat support --- lisp/emacs-lisp/comp.el | 27 +++++++++++++++++---------- test/src/comp-tests.el | 14 +++++++------- 2 files changed, 24 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3c6ce6e5828..ddebc295b4d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -297,18 +297,21 @@ If the calle function is known to have a return type propagate it." (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." - (let ((op (car inst))) + (let ((op (car inst)) + (arg (if (consp (cdr inst)) + (cadr inst) + (cdr inst)))) (comp-op-case (byte-stack-ref (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t - :constant (cadr inst))))) + :constant arg)))) (byte-varset (comp-emit `(call set_internal ,(make-comp-mvar :const-vld t - :constant (cadr inst)) + :constant arg) ,(comp-slot)))) (byte-varbind) (byte-call) @@ -356,9 +359,12 @@ If the calle function is known to have a return type propagate it." (byte-fset) (byte-get) (byte-substring) - (byte-concat2) - (byte-concat3) - (byte-concat4) + (byte-concat2 + (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) + (byte-concat3 + (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) + (byte-concat4 + (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) (byte-sub1) (byte-add1) (byte-eqlsign) @@ -411,8 +417,7 @@ If the calle function is known to have a return type propagate it." (byte-goto-if-nil-else-pop) (byte-goto-if-not-nil-else-pop) (byte-return - (comp-emit (list 'return (comp-slot-next))) - `(return ,(comp-slot-next))) + (comp-emit (list 'return (comp-slot-next)))) (byte-discard t) (byte-dup (comp-copy-slot-n (1- (comp-sp)))) @@ -450,14 +455,16 @@ If the calle function is known to have a return type propagate it." (byte-numberp) (byte-integerp) (byte-listN) - (byte-concatN) + (byte-concatN + (comp-stack-adjust (- (1- arg))) + (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) (byte-insertN) (byte-stack-set) (byte-stack-set2) (byte-discardN) (byte-switch) (byte-constant - (comp-set-const (cadr inst)))))) + (comp-set-const arg))))) (defun comp-limplify (func) "Given FUNC and return compute its LIMPLE ir." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1030900752d..d3b2929abfc 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -132,14 +132,14 @@ (should (= (comp-tests-symbol-value-f) 3))) -;; (ert-deftest comp-tests-concat () -;; "Testing concatX opcodes." -;; (defun comp-tests-concat-f (x) -;; (concat "a" "b" "c" "d" -;; (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) -;; (native-compile #'comp-tests-concat-f) +(ert-deftest comp-tests-concat () + "Testing concatX opcodes." + (defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + (native-compile #'comp-tests-concat-f) -;; (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) ;; (ert-deftest comp-tests-ffuncall () ;; "Test calling conventions." From e1d945421522f5b944b35e70cc0a535acc942230 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 11:15:18 +0200 Subject: [PATCH 0193/1452] basic funcall --- lisp/emacs-lisp/comp.el | 4 +- test/src/comp-tests.el | 81 +++++++++++++++++++++-------------------- 2 files changed, 44 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ddebc295b4d..20ea3d2fb33 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -314,7 +314,9 @@ If the calle function is known to have a return type propagate it." :constant arg) ,(comp-slot)))) (byte-varbind) - (byte-call) + (byte-call + (comp-stack-adjust (- arg)) + (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) (byte-unbind) (byte-pophandler) (byte-pushconditioncase) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d3b2929abfc..8f65ee6b53c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -141,64 +141,65 @@ (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) -;; (ert-deftest comp-tests-ffuncall () -;; "Test calling conventions." -;; (defun comp-tests-ffuncall-callee-f (x y z) -;; (list x y z)) -;; (defun comp-tests-ffuncall-caller-f () -;; (comp-tests-ffuncall-callee-f 1 2 3)) +(ert-deftest comp-tests-ffuncall () + "Test calling conventions." + (defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + (defun comp-tests-ffuncall-caller-f () + (comp-tests-ffuncall-callee-f 1 2 3)) -;; (native-compile #'comp-tests-ffuncall-caller-f) + (native-compile #'comp-tests-ffuncall-caller-f) -;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) -;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) -;; (list a b c d)) -;; (native-compile #'comp-tests-ffuncall-callee-optional-f) + ;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + ;; (list a b c d)) + ;; (native-compile #'comp-tests-ffuncall-callee-optional-f) -;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) -;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) -;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) + ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) + ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) -;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) -;; (list a b c)) -;; (native-compile #'comp-tests-ffuncall-callee-rest-f) + ;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + ;; (list a b c)) + ;; (native-compile #'comp-tests-ffuncall-callee-rest-f) -;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) -;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) -;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) + ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) + ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) -;; (defun comp-tests-ffuncall-native-f () -;; "Call a primitive with no dedicate op." -;; (make-vector 1 nil)) + ;; (defun comp-tests-ffuncall-native-f () + ;; "Call a primitive with no dedicate op." + ;; (make-vector 1 nil)) -;; (native-compile #'comp-tests-ffuncall-native-f) + ;; (native-compile #'comp-tests-ffuncall-native-f) -;; (should (equal (comp-tests-ffuncall-native-f) [nil])) + ;; (should (equal (comp-tests-ffuncall-native-f) [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-native-rest-f () + ;; "Call a primitive with no dedicate op with &rest." + ;; (vector 1 2 3)) -;; (native-compile #'comp-tests-ffuncall-native-rest-f) + ;; (native-compile #'comp-tests-ffuncall-native-rest-f) -;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + ;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) -;; (defun comp-tests-ffuncall-apply-many-f (x) -;; (apply #'list x)) + ;; (defun comp-tests-ffuncall-apply-many-f (x) + ;; (apply #'list x)) -;; (native-compile #'comp-tests-ffuncall-apply-many-f) + ;; (native-compile #'comp-tests-ffuncall-apply-many-f) -;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) -;; (defun comp-tests-ffuncall-lambda-f (x) -;; (let ((fun (lambda (x) -;; (1+ x)))) -;; (funcall fun x))) + ;; (defun comp-tests-ffuncall-lambda-f (x) + ;; (let ((fun (lambda (x) + ;; (1+ x)))) + ;; (funcall fun x))) -;; (native-compile #'comp-tests-ffuncall-lambda-f) + ;; (native-compile #'comp-tests-ffuncall-lambda-f) -;; (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + ;; (should (= (comp-tests-ffuncall-lambda-f 1) 2)) + ) ;; (ert-deftest comp-tests-jump-table () ;; "Testing jump tables" From 1deb54f5c9c0b4f3c594e4f4aa76b42a67643976 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 14:39:29 +0200 Subject: [PATCH 0194/1452] adding conditionals --- lisp/emacs-lisp/comp.el | 115 ++++++++++++++++++++++++++++++++-------- src/comp.c | 10 ++++ 2 files changed, 104 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 20ea3d2fb33..e2c8fe427e3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -21,8 +21,8 @@ ;; along with GNU Emacs. If not, see . ;;; Commentary: -;; This code is an attempt to make a Carrera out of a turbocharged VW Bug. -;; Or, to put it another way to make the pig fly. +;; This code is an attempt to make the pig fly. +;; Or, to put it another way to make a Carrera out of a turbocharged VW Bug. ;;; Code: @@ -90,6 +90,9 @@ To be used when ncall-conv is nil.") (frame-size nil :type 'number) (blocks () :type list :documentation "List of basic block") + (lap-block (make-hash-table :test #'equal) :type 'hash-table + :documentation "Key value to convert from LAP label number to +LIMPLE basic block") (limple-cnt -1 :type 'number :documentation "Counter to create ssa limple vars")) @@ -108,11 +111,13 @@ To be used when ncall-conv is nil.") :documentation "When non nil is used for type propagation")) (cl-defstruct (comp-limple-frame (:copier nil)) - "A LIMPLE func." + "This structure is used during the limplify pass." (sp 0 :type 'fixnum :documentation "Current stack pointer") (frame nil :type 'vector - :documentation "Meta-stack used to flat LAP")) + :documentation "Meta-stack used to flat LAP") + (block-sp (make-hash-table) :type 'hash-table + :documentation "Key is the basic block value is the stack pointer")) (defun comp-limple-frame-new-frame (size) "Return a clean frame of meta variables of size SIZE." @@ -195,13 +200,14 @@ To be used when ncall-conv is nil.") (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. -Restore the original value afterwads." +Restore the original value afterwards." (declare (debug (form body)) - (indent 1)) - `(let ((orig-sp (comp-sp))) - (setf (comp-sp) ,sp) - (progn ,@body) - (setf (comp-sp) orig-sp))) + (indent defun)) + (let ((sym (gensym))) + `(let ((,sym (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) ,sym)))) (defmacro comp-slot-n (n) "Slot N into the meta-stack." @@ -235,6 +241,7 @@ If the calle function is known to have a return type propagate it." "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) + ;; FIXME should the id increase? (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -252,14 +259,26 @@ If the calle function is known to have a return type propagate it." (comp-emit (list 'setimm (comp-slot) val))) (defun comp-emit-block (bblock) - "Push basic block BBLOCK." - (push bblock (comp-func-blocks comp-func)) + "Emit basic block BBLOCK." + (cl-pushnew bblock (comp-func-blocks comp-func) :test #'eq) ;; Every new block we are forced to wipe out all the frame. - ;; This will be superseded by proper flow analysis. + ;; This will be optimized by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) + ;; If we are landing here form a recorded branch adjust sp accordingly. + (if-let ((new-sp (gethash bblock (comp-limple-frame-block-sp comp-frame)))) + (setf (comp-sp) new-sp)) (comp-emit `(block ,bblock))) +(defmacro comp-with-fall-through-block (bb &rest body) + "Create a basic block BB that is used to fall through after executing BODY." + (declare (debug (form body)) + (indent defun)) + `(let ((,bb (comp-new-block-sym))) + (push ,bb (comp-func-blocks comp-func)) + (progn ,@body) + (comp-emit-block ,bb))) + (defun comp-stack-adjust (n) "Move sp by N." (cl-incf (comp-sp) n)) @@ -277,8 +296,22 @@ If the calle function is known to have a return type propagate it." ,(comp-slot) ,(comp-slot-next)))))) +(defun comp-new-block-sym () + "Return a symbol naming the next new basic block." + (intern (format "bb_%s" (length (comp-func-blocks comp-func))))) + +(defun comp-lap-to-limple-bb (n) + "Given the LAP label N return the limple basic block." + (let ((hash (comp-func-lap-block comp-func))) + (if-let ((bb (gethash n hash))) + ;; If was already created return it. + bb + (let ((name (comp-new-block-sym))) + (puthash n name hash) + name)))) + (defmacro comp-op-case (&rest cases) - "Expand CASES to the corresponding pcase." + "Expand CASES into the corresponding pcase." (declare (debug (body)) (indent defun)) `(pcase op @@ -287,8 +320,11 @@ If the calle function is known to have a return type propagate it." for op-name = (symbol-name op) if body collect `(',op - (comp-emit-annotation ,(concat "LAP op " op-name)) - (comp-stack-adjust ,(if sp-delta sp-delta 0)) + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ,(when sp-delta + `(comp-stack-adjust ,sp-delta)) (progn ,@body)) else collect `(',op (error ,(concat "Unsupported LAP op " @@ -302,6 +338,8 @@ If the calle function is known to have a return type propagate it." (cadr inst) (cdr inst)))) (comp-op-case + (TAG + (comp-emit-block (comp-lap-to-limple-bb arg))) (byte-stack-ref (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) (byte-varref @@ -413,11 +451,46 @@ If the calle function is known to have a return type propagate it." (byte-widen) (byte-end-of-line) (byte-constant2) - (byte-goto) - (byte-goto-if-nil) - (byte-goto-if-not-nil) - (byte-goto-if-nil-else-pop) - (byte-goto-if-not-nil-else-pop) + (byte-goto + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'jump target)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))) + )) + (byte-goto-if-nil + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + bb + target)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (byte-goto-if-not-nil + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + target + bb)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (byte-goto-if-nil-else-pop + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + bb + target)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (comp-stack-adjust -1)))) + (byte-goto-if-not-nil-else-pop + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + target + bb)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (comp-stack-adjust -1)))) (byte-return (comp-emit (list 'return (comp-slot-next)))) (byte-discard t) diff --git a/src/comp.c b/src/comp.c index f164bf892a5..e407c079b63 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1046,6 +1046,15 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } + else if (EQ (op, Qcond_jump)) + { + /* Conditional branch. */ + gcc_jit_rvalue *test = emit_mvar_val (arg0); + gcc_jit_block *target1 = retrive_block (THIRD (inst)); + gcc_jit_block *target2 = retrive_block (FORTH (inst)); + + emit_cond_jump (emit_NILP (test), target2, target1); + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, @@ -2091,6 +2100,7 @@ syms_of_comp (void) DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); + DEFSYM (Qcond_jump, "cond-jump"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 988a5133dc86e28e4b097d2c8d64d25e37bb6c5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 17:21:34 +0200 Subject: [PATCH 0195/1452] block to hash --- lisp/emacs-lisp/comp.el | 39 +++++++++++++++++++++++++-------------- src/comp.c | 17 ++++++++++++++--- 2 files changed, 39 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e2c8fe427e3..6f4b94d308b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,6 +74,13 @@ To be used when ncall-conv is nil.") :documentation "If t the signature is: (ptrdiff_t nargs, Lisp_Object *args)")) +(cl-defstruct (comp-block (:copier nil)) + "A basic block." + (sp nil + :documentation "When non nil indicates its the sp value") + (closed nil :type 'boolean + :documentation "If the block was already closed")) + (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." (symbol-name nil @@ -88,8 +95,9 @@ To be used when ncall-conv is nil.") :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) (frame-size nil :type 'number) - (blocks () :type list - :documentation "List of basic block") + (blocks (make-hash-table) :type 'hash-table + :documentation "Key is the basic block symbol value is a comp-block +structure") (lap-block (make-hash-table :test #'equal) :type 'hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block") @@ -258,26 +266,31 @@ If the calle function is known to have a return type propagate it." :constant val)) (comp-emit (list 'setimm (comp-slot) val))) -(defun comp-emit-block (bblock) - "Emit basic block BBLOCK." - (cl-pushnew bblock (comp-func-blocks comp-func) :test #'eq) +(defun comp-emit-block (block-name) + "Emit basic block BLOCK-NAME." + (unless (gethash block-name (comp-func-blocks comp-func)) + (puthash block-name + (make-comp-block :sp (comp-sp)) + (comp-func-blocks comp-func))) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. - (if-let ((new-sp (gethash bblock (comp-limple-frame-block-sp comp-frame)))) - (setf (comp-sp) new-sp)) - (comp-emit `(block ,bblock))) + (setf (comp-sp) + (comp-block-sp (gethash block-name (comp-func-blocks comp-func)))) + (comp-emit `(block ,block-name))) (defmacro comp-with-fall-through-block (bb &rest body) "Create a basic block BB that is used to fall through after executing BODY." (declare (debug (form body)) (indent defun)) `(let ((,bb (comp-new-block-sym))) - (push ,bb (comp-func-blocks comp-func)) - (progn ,@body) - (comp-emit-block ,bb))) + (puthash ,bb + (make-comp-block :sp (comp-sp)) + (comp-func-blocks comp-func)) + (progn ,@body) + (comp-emit-block ,bb))) (defun comp-stack-adjust (n) "Move sp by N." @@ -298,7 +311,7 @@ If the calle function is known to have a return type propagate it." (defun comp-new-block-sym () "Return a symbol naming the next new basic block." - (intern (format "bb_%s" (length (comp-func-blocks comp-func))))) + (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) (defun comp-lap-to-limple-bb (n) "Given the LAP label N return the limple basic block." @@ -562,8 +575,6 @@ If the calle function is known to have a return type propagate it." (comp-emit-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) - ;; Prologue block must be first - (setf (comp-func-blocks func) (reverse (comp-func-blocks func))) (when comp-debug (cl-prettyprint (comp-func-ir func))) func)) diff --git a/src/comp.c b/src/comp.c index e407c079b63..c97fe404cad 100644 --- a/src/comp.c +++ b/src/comp.c @@ -212,7 +212,7 @@ retrive_block (Lisp_Object symbol) } static void -declare_block (char *block_name) +declare_block (const char * block_name) { gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); Lisp_Object key = make_string (block_name, strlen (block_name)); @@ -1977,7 +1977,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + /* EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) @@ -2015,8 +2015,19 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - /* Pre declare all basic blocks. */ + /* Pre declare all basic blocks to gcc. + The "entry" block must be declared as first. */ + declare_block ("entry"); Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); + Lisp_Object entry_block = Fgethash (intern ("entry"), blocks, Qnil); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block = HASH_VALUE (ht, i); + if (!EQ (block, entry_block)) + declare_block ((char *) SDATA (SYMBOL_NAME (HASH_KEY (ht, i)))); + } + while (CONSP (blocks)) { char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); From af7bfaad6a6efa67cab0855b93ebdd920548a007 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 17:33:18 +0200 Subject: [PATCH 0196/1452] rename comp-limple-frame comp-limplify --- lisp/emacs-lisp/comp.el | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6f4b94d308b..2135abf1651 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -118,8 +118,8 @@ LIMPLE basic block") (type nil :documentation "When non nil is used for type propagation")) -(cl-defstruct (comp-limple-frame (:copier nil)) - "This structure is used during the limplify pass." +(cl-defstruct (comp-limplify (:copier nil)) + "This is a support structure used during the limplify pass." (sp 0 :type 'fixnum :documentation "Current stack pointer") (frame nil :type 'vector @@ -127,7 +127,7 @@ LIMPLE basic block") (block-sp (make-hash-table) :type 'hash-table :documentation "Key is the basic block value is the stack pointer")) -(defun comp-limple-frame-new-frame (size) +(defun comp-limplify-new-frame (size) "Return a clean frame of meta variables of size SIZE." (let ((v (make-vector size nil))) (cl-loop for i below size @@ -204,7 +204,7 @@ LIMPLE basic block") (defmacro comp-sp () "Current stack pointer." - '(comp-limple-frame-sp comp-frame)) + '(comp-limplify-sp comp-frame)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. @@ -220,7 +220,7 @@ Restore the original value afterwards." (defmacro comp-slot-n (n) "Slot N into the meta-stack." (declare (debug (form))) - `(aref (comp-limple-frame-frame comp-frame) ,n)) + `(aref (comp-limplify-frame comp-frame) ,n)) (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." @@ -274,8 +274,8 @@ If the calle function is known to have a return type propagate it." (comp-func-blocks comp-func))) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. - (setf (comp-limple-frame-frame comp-frame) - (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) + (setf (comp-limplify-frame comp-frame) + (comp-limplify-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name (comp-func-blocks comp-func)))) @@ -468,7 +468,7 @@ If the calle function is known to have a return type propagate it." (comp-with-fall-through-block bb (let ((target (comp-lap-to-limple-bb (cl-third inst)))) (comp-emit (list 'jump target)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))) )) (byte-goto-if-nil (comp-with-fall-through-block bb @@ -477,7 +477,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) bb target)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) (byte-goto-if-not-nil (comp-with-fall-through-block bb (let ((target (comp-lap-to-limple-bb (cl-third inst)))) @@ -485,7 +485,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) target bb)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) (byte-goto-if-nil-else-pop (comp-with-fall-through-block bb (let ((target (comp-lap-to-limple-bb (cl-third inst)))) @@ -493,7 +493,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) bb target)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) (comp-stack-adjust -1)))) (byte-goto-if-not-nil-else-pop (comp-with-fall-through-block bb @@ -502,7 +502,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) target bb)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) (comp-stack-adjust -1)))) (byte-return (comp-emit (list 'return (comp-slot-next)))) @@ -558,9 +558,9 @@ If the calle function is known to have a return type propagate it." "Given FUNC and return compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) - (comp-frame (make-comp-limple-frame + (comp-frame (make-comp-limplify :sp -1 - :frame (comp-limple-frame-new-frame frame-size))) + :frame (comp-limplify-new-frame frame-size))) (comp-limple ())) ;; Prologue (comp-emit-block 'entry) From 8c149505a08ddec931b54e358f4d43e847920861 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 18:36:57 +0200 Subject: [PATCH 0197/1452] conditionals working --- lisp/emacs-lisp/comp.el | 132 +++++++++++++++++++++------------------- src/comp.c | 1 - test/src/comp-tests.el | 30 ++++----- 3 files changed, 84 insertions(+), 79 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2135abf1651..61e35842ae0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,7 +77,8 @@ To be used when ncall-conv is nil.") (cl-defstruct (comp-block (:copier nil)) "A basic block." (sp nil - :documentation "When non nil indicates its the sp value") + :documentation "When non nil indicates its the sp value while entering +into it") (closed nil :type 'boolean :documentation "If the block was already closed")) @@ -119,13 +120,13 @@ LIMPLE basic block") :documentation "When non nil is used for type propagation")) (cl-defstruct (comp-limplify (:copier nil)) - "This is a support structure used during the limplify pass." + "Support structure used during the limplification." (sp 0 :type 'fixnum - :documentation "Current stack pointer") + :documentation "Current stack pointer while walking LAP") (frame nil :type 'vector :documentation "Meta-stack used to flat LAP") - (block-sp (make-hash-table) :type 'hash-table - :documentation "Key is the basic block value is the stack pointer")) + (block-name nil :type 'symbol + :documentation "Current basic block name")) (defun comp-limplify-new-frame (size) "Return a clean frame of meta variables of size SIZE." @@ -266,31 +267,60 @@ If the calle function is known to have a return type propagate it." :constant val)) (comp-emit (list 'setimm (comp-slot) val))) +(defun comp-mark-block-closed () + "Mark current basic block as closed." + (setf (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + (comp-func-blocks comp-func))) + t)) + +(defun comp-emit-jump (target) + "Emit an unconditional branch to block TARGET." + (comp-emit (list 'jump target)) + (comp-mark-block-closed)) + (defun comp-emit-block (block-name) "Emit basic block BLOCK-NAME." - (unless (gethash block-name (comp-func-blocks comp-func)) - (puthash block-name - (make-comp-block :sp (comp-sp)) - (comp-func-blocks comp-func))) - ;; Every new block we are forced to wipe out all the frame. - ;; This will be optimized by proper flow analysis. - (setf (comp-limplify-frame comp-frame) - (comp-limplify-new-frame (comp-func-frame-size comp-func))) - ;; If we are landing here form a recorded branch adjust sp accordingly. - (setf (comp-sp) - (comp-block-sp (gethash block-name (comp-func-blocks comp-func)))) - (comp-emit `(block ,block-name))) + (let ((blocks (comp-func-blocks comp-func))) + ;; In case does not exist register it into comp-func-blocks. + (unless (gethash block-name blocks) + (puthash block-name + (make-comp-block :sp (comp-sp)) + blocks)) + ;; If we are abandoning an non closed basic block close it with a fall + ;; through. + (when (and (not (eq block-name 'entry)) + (not (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + blocks)))) + (comp-emit-jump block-name)) + ;; Every new block we are forced to wipe out all the frame. + ;; This will be optimized by proper flow analysis. + (setf (comp-limplify-frame comp-frame) + (comp-limplify-new-frame (comp-func-frame-size comp-func))) + ;; If we are landing here form a recorded branch adjust sp accordingly. + (setf (comp-sp) + (comp-block-sp (gethash block-name blocks))) + (comp-emit `(block ,block-name)) + (setf (comp-limplify-block-name comp-frame) block-name))) -(defmacro comp-with-fall-through-block (bb &rest body) - "Create a basic block BB that is used to fall through after executing BODY." - (declare (debug (form body)) - (indent defun)) - `(let ((,bb (comp-new-block-sym))) - (puthash ,bb - (make-comp-block :sp (comp-sp)) - (comp-func-blocks comp-func)) - (progn ,@body) - (comp-emit-block ,bb))) +(defun comp-emit-cond-jump (discard-n lap-label negated) + "Emit a conditional jump to LAP-LABEL. +Discard DISCARD-N slots afterward. +If NEGATED non nil negate the test condition." + (let ((bb (comp-new-block-sym)) + (blocks (comp-func-blocks comp-func))) + (puthash bb + (make-comp-block :sp (- (comp-sp) discard-n)) + blocks) + (progn + (let ((target (comp-lap-to-limple-bb lap-label))) + (comp-emit (if negated + (list 'cond-jump (comp-slot-next) target bb) + (list 'cond-jump (comp-slot-next) bb target))) + (puthash target + (make-comp-block :sp (comp-sp)) + blocks) + (comp-mark-block-closed))) + (comp-emit-block bb))) (defun comp-stack-adjust (n) "Move sp by N." @@ -465,47 +495,23 @@ If the calle function is known to have a return type propagate it." (byte-end-of-line) (byte-constant2) (byte-goto - (comp-with-fall-through-block bb + (comp-with-fall-through-block bb 0 (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'jump target)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))) - )) + (comp-emit-jump target) + (puthash target + (make-comp-block :sp (comp-sp)) + (comp-func-blocks comp-func))))) (byte-goto-if-nil - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - bb - target)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) + (comp-emit-cond-jump 0 (cl-third inst) nil)) (byte-goto-if-not-nil - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - target - bb)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) + (comp-emit-cond-jump 0 (cl-third inst) t)) (byte-goto-if-nil-else-pop - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - bb - target)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) - (comp-stack-adjust -1)))) + (comp-emit-cond-jump 1 (cl-third inst) nil)) (byte-goto-if-not-nil-else-pop - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - target - bb)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) - (comp-stack-adjust -1)))) + (comp-emit-cond-jump 1 (cl-third inst) t)) (byte-return - (comp-emit (list 'return (comp-slot-next)))) + (comp-emit (list 'return (comp-slot-next))) + (comp-mark-block-closed)) (byte-discard t) (byte-dup (comp-copy-slot-n (1- (comp-sp)))) @@ -570,7 +576,7 @@ If the calle function is known to have a return type propagate it." do (progn (cl-incf (comp-sp)) (push `(setpar ,(comp-slot) ,i) comp-limple))) - (push '(jump body) comp-limple) + (comp-emit-jump 'body) ;; Body (comp-emit-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) diff --git a/src/comp.c b/src/comp.c index c97fe404cad..03a9e4b286d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1044,7 +1044,6 @@ emit_limple_inst (Lisp_Object inst) /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); gcc_jit_block_end_with_jump (comp.block, NULL, target); - comp.block = target; } else if (EQ (op, Qcond_jump)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8f65ee6b53c..e27e585ea50 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -214,22 +214,22 @@ ;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) ;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) -;; (ert-deftest comp-tests-conditionals () -;; "Testing conditionals." -;; (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)) -;; (native-compile #'comp-tests-conditionals-1-f) -;; (native-compile #'comp-tests-conditionals-2-f) +(ert-deftest comp-tests-conditionals () + "Testing conditionals." + (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)) + (native-compile #'comp-tests-conditionals-1-f) + (native-compile #'comp-tests-conditionals-2-f) -;; (should (= (comp-tests-conditionals-1-f t) 1)) -;; (should (= (comp-tests-conditionals-1-f nil) 2)) -;; (should (= (comp-tests-conditionals-2-f t) 1340)) -;; (should (eq (comp-tests-conditionals-2-f nil) nil))) + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) ;; (ert-deftest comp-tests-fixnum () ;; "Testing some fixnum inline operation." From 15e4c44564829f2eb3a7845ae94e064540ac1a4c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 20:54:53 +0200 Subject: [PATCH 0198/1452] some code massage --- lisp/emacs-lisp/comp.el | 70 ++++++++++++++++++++--------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 61e35842ae0..849b15f4225 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -66,69 +66,69 @@ (cl-defstruct comp-args (min nil :type number - :documentation "Minimum number of arguments allowed") + :documentation "Minimum number of arguments allowed.") (max nil :documentation "Maximum number of arguments allowed -To be used when ncall-conv is nil.") +To be used when ncall-conv is nil..") (ncall-conv nil :type boolean :documentation "If t the signature is: -(ptrdiff_t nargs, Lisp_Object *args)")) +(ptrdiff_t nargs, Lisp_Object *args).")) (cl-defstruct (comp-block (:copier nil)) "A basic block." (sp nil :documentation "When non nil indicates its the sp value while entering -into it") +into it.") (closed nil :type 'boolean - :documentation "If the block was already closed")) + :documentation "If the block was already closed.")) (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." (symbol-name nil - :documentation "Function symbol's name") + :documentation "Function symbol's name.") (c-func-name nil :type 'string - :documentation "The function name in the native world") + :documentation "The function name in the native world.") (func nil - :documentation "Original form") + :documentation "Original form.") (byte-func nil - :documentation "Byte compiled version") + :documentation "Byte compiled version.") (ir nil - :documentation "Current intermediate rappresentation") + :documentation "Current intermediate rappresentation.") (args nil :type 'comp-args) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table :documentation "Key is the basic block symbol value is a comp-block -structure") +structure.") (lap-block (make-hash-table :test #'equal) :type 'hash-table :documentation "Key value to convert from LAP label number to -LIMPLE basic block") +LIMPLE basic block.") (limple-cnt -1 :type 'number - :documentation "Counter to create ssa limple vars")) + :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type number - :documentation "SSA number") + :documentation "SSA number.") (slot nil :type fixnum - :documentation "Slot position") + :documentation "Slot position.") (const-vld nil - :documentation "Valid signal for the following slot") + :documentation "Valid signal for the following slot.") (constant nil :documentation "When const-vld non nil this is used for constant - propagation") + propagation.") (type nil - :documentation "When non nil is used for type propagation")) + :documentation "When non nil is used for type propagation.")) (cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during the limplification." + "Support structure used during limplification." (sp 0 :type 'fixnum - :documentation "Current stack pointer while walking LAP") + :documentation "Current stack pointer while walking LAP.") (frame nil :type 'vector - :documentation "Meta-stack used to flat LAP") + :documentation "Meta-stack used to flat LAP.") (block-name nil :type 'symbol - :documentation "Current basic block name")) + :documentation "Current basic block name.")) -(defun comp-limplify-new-frame (size) +(defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." (let ((v (make-vector size nil))) (cl-loop for i below size @@ -194,7 +194,7 @@ LIMPLE basic block") ;; (apply f (mapcar #'comp-mvar-constant args))))) ;; Special vars used during limplifications -(defvar comp-frame) +(defvar comp-pass) (defvar comp-limple) (defvar comp-func) @@ -205,7 +205,7 @@ LIMPLE basic block") (defmacro comp-sp () "Current stack pointer." - '(comp-limplify-sp comp-frame)) + '(comp-limplify-sp comp-pass)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. @@ -221,7 +221,7 @@ Restore the original value afterwards." (defmacro comp-slot-n (n) "Slot N into the meta-stack." (declare (debug (form))) - `(aref (comp-limplify-frame comp-frame) ,n)) + `(aref (comp-limplify-frame comp-pass) ,n)) (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." @@ -269,7 +269,7 @@ If the calle function is known to have a return type propagate it." (defun comp-mark-block-closed () "Mark current basic block as closed." - (setf (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + (setf (comp-block-closed (gethash (comp-limplify-block-name comp-pass) (comp-func-blocks comp-func))) t)) @@ -289,18 +289,18 @@ If the calle function is known to have a return type propagate it." ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) - (not (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + (not (comp-block-closed (gethash (comp-limplify-block-name comp-pass) blocks)))) (comp-emit-jump block-name)) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. - (setf (comp-limplify-frame comp-frame) - (comp-limplify-new-frame (comp-func-frame-size comp-func))) + (setf (comp-limplify-frame comp-pass) + (comp-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name blocks))) (comp-emit `(block ,block-name)) - (setf (comp-limplify-block-name comp-frame) block-name))) + (setf (comp-limplify-block-name comp-pass) block-name))) (defun comp-emit-cond-jump (discard-n lap-label negated) "Emit a conditional jump to LAP-LABEL. @@ -561,12 +561,12 @@ If NEGATED non nil negate the test condition." (comp-set-const arg))))) (defun comp-limplify (func) - "Given FUNC and return compute its LIMPLE ir." + "Given FUNC compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) - (comp-frame (make-comp-limplify - :sp -1 - :frame (comp-limplify-new-frame frame-size))) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame frame-size))) (comp-limple ())) ;; Prologue (comp-emit-block 'entry) From 721d1102986ad16bc71dc7a460ad08cbbe3ae979 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 21:10:56 +0200 Subject: [PATCH 0199/1452] improve comp-c-func-name --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 849b15f4225..116a1c24456 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -150,7 +150,7 @@ LIMPLE basic block.") (human-readable (replace-regexp-in-string "-" "_" orig-name)) (human-readable (replace-regexp-in-string - (rx (not (any "a-z_"))) "" human-readable))) + (rx (not (any "0-9a-z_"))) "" human-readable))) (concat "F" crypted "_" human-readable))) (defun comp-decrypt-lambda-list (x) From 5aee49d203aeae2dabd1263736c0c6bf799f4f8e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 21:26:20 +0200 Subject: [PATCH 0200/1452] byte-varbind byte-unbind --- lisp/emacs-lisp/comp.el | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 116a1c24456..10fe10fed20 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -394,11 +394,20 @@ If NEGATED non nil negate the test condition." ,(make-comp-mvar :const-vld t :constant arg) ,(comp-slot)))) - (byte-varbind) + (byte-varbind + (comp-emit `(call specbind + ,(make-comp-mvar :const-vld t + :constant arg) + ,(comp-slot-next)))) (byte-call (comp-stack-adjust (- arg)) (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) - (byte-unbind) + (byte-unbind + (comp-emit `(call unbind_to + ,(make-comp-mvar :const-vld t + :constant arg) + ,(make-comp-mvar :const-vld t + :constant nil)))) (byte-pophandler) (byte-pushconditioncase) (byte-pushcatch) From 53947aa60b193ec9a34442d4492ddee9ea36ff30 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 20:25:42 +0200 Subject: [PATCH 0201/1452] add comp-emit-set-call-subr macro --- lisp/emacs-lisp/comp.el | 48 ++++++++++++++++++++++++++++------------- 1 file changed, 33 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 10fe10fed20..f115292dbf9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -246,6 +246,28 @@ If the calle function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) +(defmacro comp-emit-set-call-subr (subr-name &optional c-fun-name) + "Emit a call for SUBR-NAME using C-FUN-NAME. +If C-FUN-NAME is nil will be guessed from SUBR-NAME." + (let* ((arity (subr-arity (symbol-function subr-name))) + (minarg (car arity)) + (maxarg (cdr arity))) + (unless c-fun-name + (setq c-fun-name + (intern (concat "F" + (replace-regexp-in-string + "-" "_" + (symbol-name subr-name)))))) + (if (eq maxarg 'many) + (progn + (cl-assert (= minarg 0)) + `(error "To be implemented")) + (cl-assert (= minarg maxarg)) + `(let ((c-fun-name ',c-fun-name) + (slots (cl-loop for i from 0 below ,maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) + (defun comp-copy-slot-n (n) "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) @@ -260,7 +282,7 @@ If the calle function is known to have a return type propagate it." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-set-const (val) +(defun comp-emit-set-const (val) "Set constant VAL to current slot." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t @@ -354,7 +376,8 @@ If NEGATED non nil negate the test condition." name)))) (defmacro comp-op-case (&rest cases) - "Expand CASES into the corresponding pcase." + "Expand CASES into the corresponding pcase. +This is responsible for generating the proper stack adjustment when known." (declare (debug (body)) (indent defun)) `(pcase op @@ -420,11 +443,11 @@ If NEGATED non nil negate the test condition." (byte-memq) (byte-not) (byte-car - (comp-emit-set-call `(call Fcar ,(comp-slot)))) + (comp-emit-set-call-subr car)) (byte-cdr - (comp-emit-set-call `(call Fcdr ,(comp-slot)))) + (comp-emit-set-call-subr cdr)) (byte-cons - (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (comp-emit-set-call-subr cons)) (byte-list1 (comp-limplify-listn 1)) (byte-list2 @@ -434,18 +457,13 @@ If NEGATED non nil negate the test condition." (byte-list4 (comp-limplify-listn 4)) (byte-length - (comp-emit-set-call `(call Flength ,(comp-slot)))) + (comp-emit-set-call-subr length)) (byte-aref - (comp-emit-set-call `(call Faref - ,(comp-slot) - ,(comp-slot-next)))) + (comp-emit-set-call-subr aref)) (byte-aset - (comp-emit-set-call `(call Faset - ,(comp-slot) - ,(comp-slot-next) - ,(comp-slot-n (+ 2 (comp-sp)))))) + (comp-emit-set-call-subr aset)) (byte-symbol-value - (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) + (comp-emit-set-call-subr symbol-value)) (byte-symbol-function) (byte-set) (byte-fset) @@ -567,7 +585,7 @@ If NEGATED non nil negate the test condition." (byte-discardN) (byte-switch) (byte-constant - (comp-set-const arg))))) + (comp-emit-set-const arg))))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." From f9723f947a919f70aeb54a9cb6515a4ead3c90d3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 21:02:01 +0200 Subject: [PATCH 0202/1452] fix goto --- lisp/emacs-lisp/comp.el | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f115292dbf9..f4718fb538b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -259,9 +259,7 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." "-" "_" (symbol-name subr-name)))))) (if (eq maxarg 'many) - (progn - (cl-assert (= minarg 0)) - `(error "To be implemented")) + (error "Not implemented") (cl-assert (= minarg maxarg)) `(let ((c-fun-name ',c-fun-name) (slots (cl-loop for i from 0 below ,maxarg @@ -272,7 +270,7 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) - ;; FIXME should the id increase? + ;; Should the id increased here? (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -377,7 +375,8 @@ If NEGATED non nil negate the test condition." (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. -This is responsible for generating the proper stack adjustment when known." +This is responsible for generating the proper stack adjustment when known and +the annotation emission." (declare (debug (body)) (indent defun)) `(pcase op @@ -522,12 +521,15 @@ This is responsible for generating the proper stack adjustment when known." (byte-end-of-line) (byte-constant2) (byte-goto - (comp-with-fall-through-block bb 0 - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit-jump target) - (puthash target - (make-comp-block :sp (comp-sp)) - (comp-func-blocks comp-func))))) + (let ((bb (comp-new-block-sym)) + (blocks (comp-func-blocks comp-func)) + (target (comp-lap-to-limple-bb (cl-third inst)))) + (puthash bb (make-comp-block :sp (comp-sp)) blocks) + (comp-emit-jump target) + (puthash target + (make-comp-block :sp (comp-sp)) + blocks) + (comp-emit-block bb))) (byte-goto-if-nil (comp-emit-cond-jump 0 (cl-third inst) nil)) (byte-goto-if-not-nil From 099f9159c4312ad17e51fd3c9571cf525fc01b15 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Jul 2019 23:35:04 +0200 Subject: [PATCH 0203/1452] rework comp.el --- lisp/emacs-lisp/comp.el | 122 +++++++++++++++++++++------------------- 1 file changed, 65 insertions(+), 57 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f4718fb538b..f13a3fd1487 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -249,22 +249,27 @@ If the calle function is known to have a return type propagate it." (defmacro comp-emit-set-call-subr (subr-name &optional c-fun-name) "Emit a call for SUBR-NAME using C-FUN-NAME. If C-FUN-NAME is nil will be guessed from SUBR-NAME." - (let* ((arity (subr-arity (symbol-function subr-name))) - (minarg (car arity)) - (maxarg (cdr arity))) - (unless c-fun-name - (setq c-fun-name - (intern (concat "F" - (replace-regexp-in-string - "-" "_" - (symbol-name subr-name)))))) - (if (eq maxarg 'many) - (error "Not implemented") - (cl-assert (= minarg maxarg)) - `(let ((c-fun-name ',c-fun-name) - (slots (cl-loop for i from 0 below ,maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) + (let ((subr (symbol-function subr-name)) + (subr-str (symbol-name subr-name))) + (cl-assert (subrp subr) nil + "%s not a subr" subr-str) + (let* ((arity (subr-arity subr)) + (minarg (car arity)) + (maxarg (cdr arity))) + (unless c-fun-name + (setq c-fun-name + (intern (concat "F" + (replace-regexp-in-string + "-" "_" + subr-str))))) + (cl-assert (not (eq maxarg 'many)) nil + "%s contains may args" subr-name) + (cl-assert (= minarg maxarg) (minarg maxarg) + "args %d %d differs for %s" subr-name) + `(let ((c-fun-name ',c-fun-name) + (slots (cl-loop for i from 0 below ,maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) (defun comp-copy-slot-n (n) "Set current slot with slot number N as source." @@ -379,22 +384,29 @@ This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) (indent defun)) - `(pcase op - ,@(cl-loop for (op . body) in cases - for sp-delta = (gethash op comp-op-stack-info) - for op-name = (symbol-name op) - if body - collect `(',op - ,(unless (eq op 'TAG) - `(comp-emit-annotation - ,(concat "LAP op " op-name))) - ,(when sp-delta - `(comp-stack-adjust ,sp-delta)) - (progn ,@body)) - else - collect `(',op (error ,(concat "Unsupported LAP op " - op-name)))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))) + (cl-flet ((op-to-fun (x) + ;;Given the LAP op strip "byte-" + (intern (replace-regexp-in-string "byte-" "" x)))) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + for body-eff = (if (eq (car body) 'auto) + (list `(comp-emit-set-call-subr + ,(op-to-fun op-name))) + body) + if body + collect `(',op + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ,(when sp-delta + `(comp-stack-adjust ,sp-delta)) + (progn ,@body-eff)) + else + collect `(',op (error ,(concat "Unsupported LAP op " + op-name)))) + (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." @@ -436,17 +448,14 @@ the annotation emission." (byte-nth) (byte-symbolp) (byte-consp) - (byte-stringp) - (byte-listp) - (byte-eq) - (byte-memq) + (byte-stringp auto) + (byte-listp auto) + (byte-eq auto) + (byte-memq auto) (byte-not) - (byte-car - (comp-emit-set-call-subr car)) - (byte-cdr - (comp-emit-set-call-subr cdr)) - (byte-cons - (comp-emit-set-call-subr cons)) + (byte-car auto) + (byte-cdr auto) + (byte-cons auto) (byte-list1 (comp-limplify-listn 1)) (byte-list2 @@ -455,18 +464,14 @@ the annotation emission." (comp-limplify-listn 3)) (byte-list4 (comp-limplify-listn 4)) - (byte-length - (comp-emit-set-call-subr length)) - (byte-aref - (comp-emit-set-call-subr aref)) - (byte-aset - (comp-emit-set-call-subr aset)) - (byte-symbol-value - (comp-emit-set-call-subr symbol-value)) + (byte-length auto) + (byte-aref auto) + (byte-aset auto) + (byte-symbol-value auto) (byte-symbol-function) - (byte-set) - (byte-fset) - (byte-get) + (byte-set auto) + (byte-fset auto) + (byte-get auto) (byte-substring) (byte-concat2 (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) @@ -476,7 +481,10 @@ the annotation emission." (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) (byte-sub1) (byte-add1) - (byte-eqlsign) + (byte-eqlsign + (comp-emit-set-call `(call Fstring_equal + ,(comp-slot) + ,(comp-slot-next)))) (byte-gtr) (byte-lss) (byte-leq) @@ -489,12 +497,12 @@ the annotation emission." (byte-min) (byte-mult) (byte-point) - (byte-goto-char) + (byte-goto-char auto) (byte-insert) (byte-point-max) (byte-point-min) (byte-char-after) - (byte-following-char) + (byte-following-char auto) (byte-preceding-char) (byte-current-column) (byte-indent-to) @@ -541,7 +549,7 @@ the annotation emission." (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) - (byte-discard t) + (byte-discard 'pass) (byte-dup (comp-copy-slot-n (1- (comp-sp)))) (byte-save-excursion) From c87027e054ec247f3c7b80b2159cfcc633bfab7c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 15 Jul 2019 00:58:03 +0200 Subject: [PATCH 0204/1452] adding some ops --- lisp/emacs-lisp/comp.el | 64 +++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f13a3fd1487..186ec1ca571 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,7 +37,9 @@ (defconst comp-debug t) +;; FIXME these has to be removed (defvar comp-speed 2) +(defvar byte-compile-lap-output) (defconst comp-passes '(comp-recuparate-lap comp-limplify) @@ -262,8 +264,8 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." (replace-regexp-in-string "-" "_" subr-str))))) - (cl-assert (not (eq maxarg 'many)) nil - "%s contains may args" subr-name) + (cl-assert (not (or (eq maxarg 'many) (eq maxarg 'unevalled))) nil + "%s contains %s arg" subr-name maxarg ) (cl-assert (= minarg maxarg) (minarg maxarg) "args %d %d differs for %s" subr-name) `(let ((c-fun-name ',c-fun-name) @@ -385,7 +387,7 @@ the annotation emission." (declare (debug (body)) (indent defun)) (cl-flet ((op-to-fun (x) - ;;Given the LAP op strip "byte-" + ;; Given the LAP op strip "byte-" to have the subr name. (intern (replace-regexp-in-string "byte-" "" x)))) `(pcase op ,@(cl-loop for (op . body) in cases @@ -445,9 +447,9 @@ the annotation emission." (byte-pophandler) (byte-pushconditioncase) (byte-pushcatch) - (byte-nth) - (byte-symbolp) - (byte-consp) + (byte-nth auto) + (byte-symbolp auto) + (byte-consp auto) (byte-stringp auto) (byte-listp auto) (byte-eq auto) @@ -468,7 +470,7 @@ the annotation emission." (byte-aref auto) (byte-aset auto) (byte-symbol-value auto) - (byte-symbol-function) + (byte-symbol-function auto) (byte-set auto) (byte-fset auto) (byte-get auto) @@ -496,23 +498,23 @@ the annotation emission." (byte-max) (byte-min) (byte-mult) - (byte-point) + (byte-point auto) (byte-goto-char auto) (byte-insert) - (byte-point-max) - (byte-point-min) + (byte-point-max auto) + (byte-point-min auto) (byte-char-after) (byte-following-char auto) - (byte-preceding-char) - (byte-current-column) + (byte-preceding-char auto) + (byte-current-column auto) (byte-indent-to) (byte-scan-buffer-OBSOLETE) - (byte-eolp) - (byte-eobp) - (byte-bolp) - (byte-bobp) - (byte-current-buffer) - (byte-set-buffer) + (byte-eolp auto) + (byte-eobp auto) + (byte-bolp auto) + (byte-bobp auto) + (byte-current-buffer auto) + (byte-set-buffer auto) (byte-save-current-buffer) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) @@ -521,9 +523,9 @@ the annotation emission." (byte-skip-chars-forward) (byte-skip-chars-backward) (byte-forward-line) - (byte-char-syntax) - (byte-buffer-substring) - (byte-delete-region) + (byte-char-syntax auto) + (byte-buffer-substring auto) + (byte-delete-region auto) (byte-narrow-to-region) (byte-widen) (byte-end-of-line) @@ -569,13 +571,13 @@ the annotation emission." (byte-string=) (byte-string<) (byte-equal) - (byte-nthcdr) - (byte-elt) - (byte-member) - (byte-assq) - (byte-nreverse) - (byte-setcar) - (byte-setcdr) + (byte-nthcdr auto) + (byte-elt auto) + (byte-member auto) + (byte-assq auto) + (byte-nreverse auto) + (byte-setcar auto) + (byte-setcdr auto) (byte-car-safe (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) (byte-cdr-safe @@ -583,8 +585,8 @@ the annotation emission." (byte-nconc) (byte-quo) (byte-rem) - (byte-numberp) - (byte-integerp) + (byte-numberp auto) + (byte-integerp auto) (byte-listN) (byte-concatN (comp-stack-adjust (- (1- arg))) @@ -609,7 +611,7 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (cl-loop for i below (comp-args-mandatory (comp-func-args func)) + (cl-loop for i below (comp-args-min (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(setpar ,(comp-slot) ,i) comp-limple))) From 13811eba32c8d43126e3d137ddcedbdab4dd81c6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Jul 2019 17:35:30 +0200 Subject: [PATCH 0205/1452] better generated code --- src/comp.c | 36 ++++++++++++++++++++++++++++++------ 1 file changed, 30 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 03a9e4b286d..152a0e61808 100644 --- a/src/comp.c +++ b/src/comp.c @@ -35,6 +35,15 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 +/* + If 1 always favorite the emission of direct constants when these are know + instead of the corresponding frame slot access. + This has to prove to have some perf advantage but certainly makes the + generated code C-like code more bloated. +*/ + +#define CONST_PROP_MAX 0 + #define STR(s) #s #define FIRST(x) \ @@ -958,12 +967,27 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { - if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) - return - gcc_jit_lvalue_as_rvalue( - comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + if (CONST_PROP_MAX) + { + if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) + return + gcc_jit_lvalue_as_rvalue( + comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + else + return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); + } else - return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); + { + if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) + { + /* If the slot is not specified this must be a constant. */ + eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); + return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); + } + return + gcc_jit_lvalue_as_rvalue( + comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + } } static gcc_jit_rvalue * @@ -1007,7 +1031,7 @@ emit_limple_call (Lisp_Object arg1) SET_INTERNAL_SET); return emit_call ("set_internal", comp.void_type , 4, gcc_args); } - error ("LIMPLE call is inconsistet"); + error ("LIMPLE call is inconsistent"); } static gcc_jit_rvalue * From fb9711df98be83c357321761d06e902e5410da79 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Jul 2019 17:57:01 +0200 Subject: [PATCH 0206/1452] uncommenting some tests --- test/src/comp-tests.el | 41 ++++++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e27e585ea50..d11cf8657c6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -168,38 +168,37 @@ ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) - ;; (defun comp-tests-ffuncall-native-f () - ;; "Call a primitive with no dedicate op." - ;; (make-vector 1 nil)) + (defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) - ;; (native-compile #'comp-tests-ffuncall-native-f) + (native-compile #'comp-tests-ffuncall-native-f) - ;; (should (equal (comp-tests-ffuncall-native-f) [nil])) + (should (equal (comp-tests-ffuncall-native-f) [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-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) - ;; (native-compile #'comp-tests-ffuncall-native-rest-f) + (native-compile #'comp-tests-ffuncall-native-rest-f) - ;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) - ;; (defun comp-tests-ffuncall-apply-many-f (x) - ;; (apply #'list x)) + (defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) - ;; (native-compile #'comp-tests-ffuncall-apply-many-f) + (native-compile #'comp-tests-ffuncall-apply-many-f) - ;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) - ;; (defun comp-tests-ffuncall-lambda-f (x) - ;; (let ((fun (lambda (x) - ;; (1+ x)))) - ;; (funcall fun x))) + (defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) - ;; (native-compile #'comp-tests-ffuncall-lambda-f) + (native-compile #'comp-tests-ffuncall-lambda-f) - ;; (should (= (comp-tests-ffuncall-lambda-f 1) 2)) - ) + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) ;; (ert-deftest comp-tests-jump-table () ;; "Testing jump tables" From a556a2ef5b45a25ff5df9a7cf3dc50e1ec46224b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 15:49:30 +0200 Subject: [PATCH 0207/1452] improve comp-op-case --- lisp/emacs-lisp/comp.el | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 186ec1ca571..99e71a0d58d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -248,11 +248,13 @@ If the calle function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) -(defmacro comp-emit-set-call-subr (subr-name &optional c-fun-name) +(defmacro comp-emit-set-call-subr (subr-name sp-delta &optional c-fun-name) "Emit a call for SUBR-NAME using C-FUN-NAME. -If C-FUN-NAME is nil will be guessed from SUBR-NAME." +SP-DELTA is the stack adjustment. +If C-FUN-NAME is nil it will be guessed from SUBR-NAME." (let ((subr (symbol-function subr-name)) - (subr-str (symbol-name subr-name))) + (subr-str (symbol-name subr-name)) + (nargs (1+ (- sp-delta)))) (cl-assert (subrp subr) nil "%s not a subr" subr-str) (let* ((arity (subr-arity subr)) @@ -264,14 +266,19 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." (replace-regexp-in-string "-" "_" subr-str))))) - (cl-assert (not (or (eq maxarg 'many) (eq maxarg 'unevalled))) nil - "%s contains %s arg" subr-name maxarg ) - (cl-assert (= minarg maxarg) (minarg maxarg) - "args %d %d differs for %s" subr-name) - `(let ((c-fun-name ',c-fun-name) - (slots (cl-loop for i from 0 below ,maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) + (cl-assert (not (eq maxarg 'unevalled)) nil + "%s contains unevalled arg" subr-name) + (if (eq maxarg 'many) + ;; callref case. + `(comp-emit-set-call (list 'callref ',c-fun-name ,nargs (comp-sp))) + ;; Normal call. + (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) + (nargs maxarg minarg) + "Incoherent stack adjustment %d, maxarg %d minarg %d") + `(let* ((c-fun-name ',c-fun-name) + (slots (cl-loop for i from 0 below ,maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call `(call ,c-fun-name ,@slots))))))) (defun comp-copy-slot-n (n) "Set current slot with slot number N as source." @@ -395,16 +402,17 @@ the annotation emission." for op-name = (symbol-name op) for body-eff = (if (eq (car body) 'auto) (list `(comp-emit-set-call-subr - ,(op-to-fun op-name))) + ,(op-to-fun op-name) + ,sp-delta)) body) if body collect `(',op ,(unless (eq op 'TAG) `(comp-emit-annotation ,(concat "LAP op " op-name))) - ,(when sp-delta + ,(when (and sp-delta (not (eq 0 sp-delta))) `(comp-stack-adjust ,sp-delta)) - (progn ,@body-eff)) + ,@body-eff) else collect `(',op (error ,(concat "Unsupported LAP op " op-name)))) From f78257006c46ac537aba00658b11a75a11bd1fce Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 16:34:37 +0200 Subject: [PATCH 0208/1452] add a bunch of ops --- lisp/emacs-lisp/comp.el | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99e71a0d58d..fceea59860a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -284,7 +284,7 @@ If C-FUN-NAME is nil it will be guessed from SUBR-NAME." "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) - ;; Should the id increased here? + ;; FIXME id should encrease here. (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -482,7 +482,7 @@ the annotation emission." (byte-set auto) (byte-fset auto) (byte-get auto) - (byte-substring) + (byte-substring auto) (byte-concat2 (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) (byte-concat3 @@ -503,19 +503,19 @@ the annotation emission." (byte-negate) (byte-plus (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) - (byte-max) - (byte-min) + (byte-max auto) + (byte-min auto) (byte-mult) (byte-point auto) (byte-goto-char auto) - (byte-insert) + (byte-insert auto) (byte-point-max auto) (byte-point-min auto) - (byte-char-after) + (byte-char-after auto) (byte-following-char auto) (byte-preceding-char auto) (byte-current-column auto) - (byte-indent-to) + (byte-indent-to auto) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) @@ -526,17 +526,17 @@ the annotation emission." (byte-save-current-buffer) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) - (byte-forward-char) - (byte-forward-word) - (byte-skip-chars-forward) - (byte-skip-chars-backward) - (byte-forward-line) + (byte-forward-char auto) + (byte-forward-word auto) + (byte-skip-chars-forward auto) + (byte-skip-chars-backward auto) + (byte-forward-line auto) (byte-char-syntax auto) (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region) (byte-widen) - (byte-end-of-line) + (byte-end-of-line auto) (byte-constant2) (byte-goto (let ((bb (comp-new-block-sym)) @@ -571,14 +571,14 @@ the annotation emission." (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) (byte-unbind-all) - (byte-set-marker) - (byte-match-beginning) - (byte-match-end) - (byte-upcase) - (byte-downcase) + (byte-set-marker auto) + (byte-match-beginning auto) + (byte-match-end auto) + (byte-upcase auto) + (byte-downcase auto) (byte-string=) (byte-string<) - (byte-equal) + (byte-equal auto) (byte-nthcdr auto) (byte-elt auto) (byte-member auto) @@ -590,7 +590,7 @@ the annotation emission." (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) (byte-cdr-safe (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) - (byte-nconc) + (byte-nconc auto) (byte-quo) (byte-rem) (byte-numberp auto) From c7341aad72ee4cfca5c989ef982f07fbd14d8837 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 16:44:40 +0200 Subject: [PATCH 0209/1452] improve comp-op-case again --- lisp/emacs-lisp/comp.el | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fceea59860a..89a35d1fe54 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -393,18 +393,26 @@ This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) (indent defun)) - (cl-flet ((op-to-fun (x) - ;; Given the LAP op strip "byte-" to have the subr name. - (intern (replace-regexp-in-string "byte-" "" x)))) + (cl-labels ((op-to-fun (x) + ;; Given the LAP op strip "byte-" to have the subr name. + (intern (replace-regexp-in-string "byte-" "" x))) + (body-eff (body op-name sp-delta) + ;; Given the original body BODY compute the effective one. + (pcase (car body) + ('auto + (list `(comp-emit-set-call-subr + ,(op-to-fun op-name) + ,sp-delta))) + ((pred symbolp) + (list `(comp-emit-set-call-subr + ,(car body) + ,sp-delta + ,(cadr body)))) + (_ body)))) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) for op-name = (symbol-name op) - for body-eff = (if (eq (car body) 'auto) - (list `(comp-emit-set-call-subr - ,(op-to-fun op-name) - ,sp-delta)) - body) if body collect `(',op ,(unless (eq op 'TAG) @@ -412,7 +420,7 @@ the annotation emission." ,(concat "LAP op " op-name))) ,(when (and sp-delta (not (eq 0 sp-delta))) `(comp-stack-adjust ,sp-delta)) - ,@body-eff) + ,@(body-eff body op-name sp-delta)) else collect `(',op (error ,(concat "Unsupported LAP op " op-name)))) From 45a4510738a0878267fca5fdd687981c70209023 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 17:22:13 +0200 Subject: [PATCH 0210/1452] adding ops --- lisp/emacs-lisp/comp.el | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 89a35d1fe54..6bc293e5963 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,23 +497,19 @@ the annotation emission." (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) (byte-concat4 (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) - (byte-sub1) - (byte-add1) - (byte-eqlsign - (comp-emit-set-call `(call Fstring_equal - ,(comp-slot) - ,(comp-slot-next)))) - (byte-gtr) - (byte-lss) - (byte-leq) - (byte-geq) - (byte-diff) - (byte-negate) - (byte-plus - (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) + (byte-sub1 1+ Fadd1) + (byte-add1 1- Fsub1) + (byte-eqlsign string-equal Fstring-equal) + (byte-gtr > Fgtr) + (byte-lss < Flss) + (byte-leq <= Fleq) + (byte-geq >= Fgeq) + (byte-diff - Fmius) + (byte-negate null Fnull) + (byte-plus + Fplus) (byte-max auto) (byte-min auto) - (byte-mult) + (byte-mult * Ftimes) (byte-point auto) (byte-goto-char auto) (byte-insert auto) From 231c71706b3b5eec8038986f54198a8983ae83c0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 17:35:57 +0200 Subject: [PATCH 0211/1452] Add other ops --- lisp/emacs-lisp/comp.el | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6bc293e5963..cdbae343873 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -398,6 +398,8 @@ the annotation emission." (intern (replace-regexp-in-string "byte-" "" x))) (body-eff (body op-name sp-delta) ;; Given the original body BODY compute the effective one. + ;; When BODY is auto guess function name form the LAP bytecode + ;; name. Othewise expect lname fnname. (pcase (car body) ('auto (list `(comp-emit-set-call-subr @@ -415,9 +417,11 @@ the annotation emission." for op-name = (symbol-name op) if body collect `(',op + ;; Log all LAP ops except the TAG one. ,(unless (eq op 'TAG) `(comp-emit-annotation ,(concat "LAP op " op-name))) + ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) `(comp-stack-adjust ,sp-delta)) ,@(body-eff body op-name sp-delta)) @@ -470,7 +474,7 @@ the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not) + (byte-not null Fnull) (byte-car auto) (byte-cdr auto) (byte-cons auto) @@ -497,15 +501,15 @@ the annotation emission." (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) (byte-concat4 (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) - (byte-sub1 1+ Fadd1) - (byte-add1 1- Fsub1) - (byte-eqlsign string-equal Fstring-equal) + (byte-sub1 1- Fsub1) + (byte-add1 1+ Fadd1) + (byte-eqlsign = Feqlsign) (byte-gtr > Fgtr) (byte-lss < Flss) (byte-leq <= Fleq) (byte-geq >= Fgeq) - (byte-diff - Fmius) - (byte-negate null Fnull) + (byte-diff - Fminus) + (byte-negate - Fminus) (byte-plus + Fplus) (byte-max auto) (byte-min auto) @@ -580,8 +584,8 @@ the annotation emission." (byte-match-end auto) (byte-upcase auto) (byte-downcase auto) - (byte-string=) - (byte-string<) + (byte-string= string-equal Fstring_equal) + (byte-string< string-lessp Fstring_lessp) (byte-equal auto) (byte-nthcdr auto) (byte-elt auto) @@ -590,13 +594,11 @@ the annotation emission." (byte-nreverse auto) (byte-setcar auto) (byte-setcdr auto) - (byte-car-safe - (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) - (byte-cdr-safe - (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) + (byte-car-safe auto) + (byte-cdr-safe auto) (byte-nconc auto) - (byte-quo) - (byte-rem) + (byte-quo / Fquo) + (byte-rem % Frem) (byte-numberp auto) (byte-integerp auto) (byte-listN) From 13651c52ca6c90265fe568a62db1f81152cfbfa7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 17:50:51 +0200 Subject: [PATCH 0212/1452] uncommenting some test --- test/src/comp-tests.el | 262 ++++++++++++++++++++--------------------- 1 file changed, 131 insertions(+), 131 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d11cf8657c6..938bf53c014 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -230,109 +230,109 @@ (should (= (comp-tests-conditionals-2-f t) 1340)) (should (eq (comp-tests-conditionals-2-f nil) nil))) -;; (ert-deftest comp-tests-fixnum () -;; "Testing some fixnum inline operation." -;; (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)) +(ert-deftest comp-tests-fixnum () + "Testing some fixnum inline operation." + (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)) -;; (native-compile #'comp-tests-fixnum-1-minus-f) -;; (native-compile #'comp-tests-fixnum-1-plus-f) -;; (native-compile #'comp-tests-fixnum-minus-f) + (native-compile #'comp-tests-fixnum-1-minus-f) + (native-compile #'comp-tests-fixnum-1-plus-f) + (native-compile #'comp-tests-fixnum-minus-f) -;; (should (= (comp-tests-fixnum-1-minus-f 10) 9)) -;; (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) -;; (1- most-negative-fixnum))) -;; (should (equal (condition-case err -;; (comp-tests-fixnum-1-minus-f 'a) -;; (error err)) -;; '(wrong-type-argument number-or-marker-p a))) -;; (should (= (comp-tests-fixnum-1-plus-f 10) 11)) -;; (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) -;; (1+ most-positive-fixnum))) -;; (should (equal (condition-case err -;; (comp-tests-fixnum-1-plus-f 'a) -;; (error err)) -;; '(wrong-type-argument number-or-marker-p a))) -;; (should (= (comp-tests-fixnum-minus-f 10) -10)) -;; (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) -;; (- most-negative-fixnum))) -;; (should (equal (condition-case err -;; (comp-tests-fixnum-minus-f 'a) -;; (error err)) -;; '(wrong-type-argument number-or-marker-p a)))) + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1-minus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1-plus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-minus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a)))) -;; (ert-deftest comp-tests-arith-comp () -;; "Testing arithmetic comparisons." -;; (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)) +(ert-deftest comp-tests-arith-comp () + "Testing arithmetic comparisons." + (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)) -;; (native-compile #'comp-tests-eqlsign-f) -;; (native-compile #'comp-tests-gtr-f) -;; (native-compile #'comp-tests-lss-f) -;; (native-compile #'comp-tests-les-f) -;; (native-compile #'comp-tests-geq-f) + (native-compile #'comp-tests-eqlsign-f) + (native-compile #'comp-tests-gtr-f) + (native-compile #'comp-tests-lss-f) + (native-compile #'comp-tests-les-f) + (native-compile #'comp-tests-geq-f) -;; (should (eq (comp-tests-eqlsign-f 4 3) nil)) -;; (should (eq (comp-tests-eqlsign-f 3 3) t)) -;; (should (eq (comp-tests-eqlsign-f 2 3) nil)) -;; (should (eq (comp-tests-gtr-f 4 3) t)) -;; (should (eq (comp-tests-gtr-f 3 3) nil)) -;; (should (eq (comp-tests-gtr-f 2 3) nil)) -;; (should (eq (comp-tests-lss-f 4 3) nil)) -;; (should (eq (comp-tests-lss-f 3 3) nil)) -;; (should (eq (comp-tests-lss-f 2 3) t)) -;; (should (eq (comp-tests-les-f 4 3) nil)) -;; (should (eq (comp-tests-les-f 3 3) t)) -;; (should (eq (comp-tests-les-f 2 3) t)) -;; (should (eq (comp-tests-geq-f 4 3) t)) -;; (should (eq (comp-tests-geq-f 3 3) t)) -;; (should (eq (comp-tests-geq-f 2 3) nil))) + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) -;; (ert-deftest comp-tests-setcarcdr () -;; "Testing setcar setcdr." -;; (defun comp-tests-setcar-f (x y) -;; (setcar x y) -;; x) -;; (defun comp-tests-setcdr-f (x y) -;; (setcdr x y) -;; x) +(ert-deftest comp-tests-setcarcdr () + "Testing setcar setcdr." + (defun comp-tests-setcar-f (x y) + (setcar x y) + x) + (defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) -;; (native-compile #'comp-tests-setcar-f) -;; (native-compile #'comp-tests-setcdr-f) + (native-compile #'comp-tests-setcar-f) + (native-compile #'comp-tests-setcdr-f) -;; (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) -;; (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) -;; (should (equal (condition-case -;; err -;; (comp-tests-setcar-f 3 10) -;; (error err)) -;; '(wrong-type-argument consp 3))) -;; (should (equal (condition-case -;; err -;; (comp-tests-setcdr-f 3 10) -;; (error err)) -;; '(wrong-type-argument consp 3)))) + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (condition-case + err + (comp-tests-setcar-f 3 10) + (error err)) + '(wrong-type-argument consp 3))) + (should (equal (condition-case + err + (comp-tests-setcdr-f 3 10) + (error err)) + '(wrong-type-argument consp 3)))) ;; (ert-deftest comp-tests-bubble-sort () ;; "Run bubble sort." @@ -355,44 +355,44 @@ ;; (should (equal (comp-bubble-sort-f list1) ;; (sort list2 #'<))))) -;; (ert-deftest comp-tests-list-inline () -;; "Test some inlined list functions." -;; (defun comp-tests-consp-f (x) -;; ;; Bconsp -;; (consp x)) -;; (defun comp-tests-car-f (x) -;; ;; Bsetcar -;; (setcar x 3)) +(ert-deftest comp-tests-list-inline () + "Test some inlined list functions." + (defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) + (defun comp-tests-car-f (x) + ;; Bsetcar + (setcar x 3)) -;; (native-compile #'comp-tests-consp-f) -;; (native-compile #'comp-tests-car-f) + (native-compile #'comp-tests-consp-f) + (native-compile #'comp-tests-car-f) -;; (should (eq (comp-tests-consp-f '(1)) t)) -;; (should (eq (comp-tests-consp-f 1) nil)) -;; (let ((x (cons 1 2))) -;; (should (= (comp-tests-car-f x) 3)) -;; (should (equal x '(3 . 2))))) + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-car-f x) 3)) + (should (equal x '(3 . 2))))) -;; (ert-deftest comp-tests-num-inline () -;; "Test some inlined number functions." -;; (defun comp-tests-integerp-f (x) -;; ;; Bintegerp -;; (integerp x)) -;; (defun comp-tests-numberp-f (x) -;; ;; Bnumberp -;; (numberp x)) +(ert-deftest comp-tests-num-inline () + "Test some inlined number functions." + (defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) + (defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) -;; (native-compile #'comp-tests-integerp-f) -;; (native-compile #'comp-tests-numberp-f) + (native-compile #'comp-tests-integerp-f) + (native-compile #'comp-tests-numberp-f) -;; (should (eq (comp-tests-integerp-f 1) t)) -;; (should (eq (comp-tests-integerp-f '(1)) nil)) -;; (should (eq (comp-tests-integerp-f 3.5) nil)) -;; (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) -;; (should (eq (comp-tests-numberp-f 1) t)) -;; (should (eq (comp-tests-numberp-f 'a) nil)) -;; (should (eq (comp-tests-numberp-f 3.5) t))) + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) ;; (ert-deftest comp-tests-stack () ;; "Test some stack operation." @@ -467,11 +467,11 @@ ;; (should (= (catch 'foo ;; (comp-tests-throw-f 3))))) -;; (ert-deftest comp-tests-gc () -;; "Try to do some longer computation to let the gc kick in." -;; (dotimes (_ 100000) -;; (comp-tests-cons-cdr-f 3)) +(ert-deftest comp-tests-gc () + "Try to do some longer computation to let the gc kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) -;; (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-cdr-f 3) 3))) ;;; comp-tests.el ends here From 8da012e224276e42c15d613c0aac3ce3e1a3d939 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 18:50:41 +0200 Subject: [PATCH 0213/1452] ops --- lisp/emacs-lisp/comp.el | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cdbae343873..91aad45bc69 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -601,17 +601,24 @@ the annotation emission." (byte-rem % Frem) (byte-numberp auto) (byte-integerp auto) - (byte-listN) + (byte-listN + (comp-stack-adjust (- (1- arg))) + (comp-emit-set-call `(callref Flist ,arg ,(comp-sp)))) (byte-concatN (comp-stack-adjust (- (1- arg))) (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) - (byte-insertN) + (byte-insertN + (comp-stack-adjust (- (1- arg))) + (comp-emit-set-call `(callref Finsert ,arg ,(comp-sp)))) (byte-stack-set) (byte-stack-set2) (byte-discardN) (byte-switch) (byte-constant - (comp-emit-set-const arg))))) + (comp-emit-set-const arg)) + (byte-discardN-preserve-tos + (comp-stack-adjust (- arg)) + (comp-copy-slot-n (+ arg (comp-sp))))))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." From 80826b8220c6f26609ce916ceee3a0bd143a1b41 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 18:50:52 +0200 Subject: [PATCH 0214/1452] uncomment test --- test/src/comp-tests.el | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 938bf53c014..e2a9b1ce49c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -394,27 +394,27 @@ (should (eq (comp-tests-numberp-f 'a) nil)) (should (eq (comp-tests-numberp-f 3.5) t))) -;; (ert-deftest comp-tests-stack () -;; "Test some stack operation." -;; (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)) +(ert-deftest comp-tests-stack () + "Test some stack operation." + (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)) -;; (native-compile #'comp-tests-discardn-f) -;; (native-compile #'comp-tests-insertn-f) + (native-compile #'comp-tests-discardn-f) + (native-compile #'comp-tests-insertn-f) -;; (should (= (comp-tests-discardn-f 10) 2)) + (should (= (comp-tests-discardn-f 10) 2)) -;; (should (string= (with-temp-buffer -;; (comp-tests-insertn-f "a" "b" "c" "d") -;; (buffer-string)) -;; "abcd"))) + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) ;; (ert-deftest comp-tests-non-locals () ;; "Test non locals." From d025ce26f849ae8429f5250eeaf6f4915befe804 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 19:26:30 +0200 Subject: [PATCH 0215/1452] stackset --- lisp/emacs-lisp/comp.el | 39 ++++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 91aad45bc69..9151c304a16 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -280,15 +280,17 @@ If C-FUN-NAME is nil it will be guessed from SUBR-NAME." collect (comp-slot-n (+ i (comp-sp)))))) (comp-emit-set-call `(call ,c-fun-name ,@slots))))))) -(defun comp-copy-slot-n (n) - "Set current slot with slot number N as source." - (let ((src-slot (comp-slot-n n))) - (cl-assert src-slot) - ;; FIXME id should encrease here. - (setf (comp-slot) - (copy-sequence src-slot)) - (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (comp-emit (list 'set (comp-slot) src-slot)))) +(defun comp-copy-slot (src-n &optional dst-n) + "Set slot number DST-N to slot number SRC-N as source. +If DST-N is specified use it otherwise assume it to be the current slot." + (comp-with-sp (if dst-n dst-n (comp-sp)) + (let ((src-slot (comp-slot-n src-n))) + (cl-assert src-slot) + ;; FIXME id should encrease here. + (setf (comp-slot) + (copy-sequence src-slot)) + (setf (comp-mvar-slot (comp-slot)) (comp-sp)) + (comp-emit (list 'set (comp-slot) src-slot))))) (defun comp-emit-annotation (str) "Emit annotation STR." @@ -440,7 +442,7 @@ the annotation emission." (TAG (comp-emit-block (comp-lap-to-limple-bb arg))) (byte-stack-ref - (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) + (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t @@ -569,7 +571,7 @@ the annotation emission." (comp-mark-block-closed)) (byte-discard 'pass) (byte-dup - (comp-copy-slot-n (1- (comp-sp)))) + (comp-copy-slot (1- (comp-sp)))) (byte-save-excursion) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction) @@ -602,23 +604,26 @@ the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (comp-stack-adjust (- (1- arg))) + (comp-stack-adjust (- 1 arg)) (comp-emit-set-call `(callref Flist ,arg ,(comp-sp)))) (byte-concatN - (comp-stack-adjust (- (1- arg))) + (comp-stack-adjust (- 1 arg)) (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) (byte-insertN - (comp-stack-adjust (- (1- arg))) + (comp-stack-adjust (- 1 arg)) (comp-emit-set-call `(callref Finsert ,arg ,(comp-sp)))) - (byte-stack-set) + (byte-stack-set + (comp-with-sp (1+ (comp-sp)) + (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) (byte-stack-set2) - (byte-discardN) + (byte-discardN + (comp-stack-adjust (- arg))) (byte-switch) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos (comp-stack-adjust (- arg)) - (comp-copy-slot-n (+ arg (comp-sp))))))) + (comp-copy-slot (+ arg (comp-sp))))))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." From 6e1e1bdc2c6ee45ac12283f8e8096723d60d93a1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 20 Jul 2019 19:56:54 +0200 Subject: [PATCH 0216/1452] fix goto --- lisp/emacs-lisp/comp.el | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9151c304a16..8b3c3d20629 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -549,15 +549,7 @@ the annotation emission." (byte-end-of-line auto) (byte-constant2) (byte-goto - (let ((bb (comp-new-block-sym)) - (blocks (comp-func-blocks comp-func)) - (target (comp-lap-to-limple-bb (cl-third inst)))) - (puthash bb (make-comp-block :sp (comp-sp)) blocks) - (comp-emit-jump target) - (puthash target - (make-comp-block :sp (comp-sp)) - blocks) - (comp-emit-block bb))) + (comp-emit-jump (comp-lap-to-limple-bb (cl-third inst)))) (byte-goto-if-nil (comp-emit-cond-jump 0 (cl-third inst) nil)) (byte-goto-if-not-nil From e25cf441152746a4686ab7adca8d3302e0740189 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 09:48:52 +0200 Subject: [PATCH 0217/1452] fix comp-emit-cond-jump --- lisp/emacs-lisp/comp.el | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8b3c3d20629..a3c2db4283f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -338,24 +338,24 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit `(block ,block-name)) (setf (comp-limplify-block-name comp-pass) block-name))) -(defun comp-emit-cond-jump (discard-n lap-label negated) +(defun comp-emit-cond-jump (target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL. -Discard DISCARD-N slots afterward. +TARGET-OFFSET is the positive offset on the SP when branching to the target +block. If NEGATED non nil negate the test condition." - (let ((bb (comp-new-block-sym)) - (blocks (comp-func-blocks comp-func))) + (let ((blocks (comp-func-blocks comp-func)) + (bb (comp-new-block-sym))) ;; Fall through block (puthash bb - (make-comp-block :sp (- (comp-sp) discard-n)) + (make-comp-block :sp (comp-sp)) blocks) - (progn - (let ((target (comp-lap-to-limple-bb lap-label))) - (comp-emit (if negated - (list 'cond-jump (comp-slot-next) target bb) - (list 'cond-jump (comp-slot-next) bb target))) - (puthash target - (make-comp-block :sp (comp-sp)) - blocks) - (comp-mark-block-closed))) + (let ((target (comp-lap-to-limple-bb lap-label))) + (comp-emit (if negated + (list 'cond-jump (comp-slot-next) target bb) + (list 'cond-jump (comp-slot-next) bb target))) + (puthash target + (make-comp-block :sp (+ target-offset (comp-sp))) + blocks) + (comp-mark-block-closed)) (comp-emit-block bb))) (defun comp-stack-adjust (n) From 7726cb254503c2c3d082ffb8aed9c12cbeeec12e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 09:50:18 +0200 Subject: [PATCH 0218/1452] bubble sort works again --- test/src/comp-tests.el | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e2a9b1ce49c..4462f35246a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -334,26 +334,26 @@ (error err)) '(wrong-type-argument consp 3)))) -;; (ert-deftest comp-tests-bubble-sort () -;; "Run bubble sort." -;; (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)) +(ert-deftest comp-tests-bubble-sort () + "Run bubble sort." + (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)) -;; (native-compile #'comp-bubble-sort-f) + (native-compile #'comp-bubble-sort-f) -;; (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) -;; (list2 (copy-sequence list1))) -;; (should (equal (comp-bubble-sort-f list1) -;; (sort list2 #'<))))) + (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) (ert-deftest comp-tests-list-inline () "Test some inlined list functions." From 759a15d446b7f728d2d146cb1bfd6d722df9e998 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 11:38:26 +0200 Subject: [PATCH 0219/1452] adding non locals --- lisp/emacs-lisp/comp.el | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a3c2db4283f..62b80a0a5ac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -466,8 +466,25 @@ the annotation emission." :constant arg) ,(make-comp-mvar :const-vld t :constant nil)))) - (byte-pophandler) - (byte-pushconditioncase) + (byte-pophandler + (comp-emit '(pop-handler))) + (byte-pushconditioncase + (let ((blocks (comp-func-blocks comp-func)) + (fall-bb (comp-new-block-sym))) ;; Fall through block + (puthash fall-bb + (make-comp-block :sp (comp-sp)) + blocks) + (let ((target (comp-lap-to-limple-bb (cl-third inst))) + (handler-type (cdr (last inst)))) + (comp-emit (list 'push-handler (comp-slot-next) + handler-type + target + fall-bb)) + (puthash target + (make-comp-block :sp (comp-sp)) + blocks) + (comp-mark-block-closed)) + (comp-emit-block fall-bb))) (byte-pushcatch) (byte-nth auto) (byte-symbolp auto) From 976357769fe33e36afb37d5cd663587f46e88d0e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 12:11:45 +0200 Subject: [PATCH 0220/1452] rework arg parsing on the C side --- src/comp.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 152a0e61808..edc35cf8b0e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1055,7 +1055,8 @@ static void emit_limple_inst (Lisp_Object inst) { Lisp_Object op = XCAR (inst); - Lisp_Object arg0 = SECOND (inst); + Lisp_Object args = XCDR (inst); + Lisp_Object arg0 = XCAR (args); gcc_jit_rvalue *res; if (EQ (op, Qblock)) @@ -1071,10 +1072,10 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcond_jump)) { - /* Conditional branch. */ + /* Conditional branch. */ gcc_jit_rvalue *test = emit_mvar_val (arg0); - gcc_jit_block *target1 = retrive_block (THIRD (inst)); - gcc_jit_block *target2 = retrive_block (FORTH (inst)); + gcc_jit_block *target1 = retrive_block (SECOND (args)); + gcc_jit_block *target2 = retrive_block (THIRD (args)); emit_cond_jump (emit_NILP (test), target2, target1); } @@ -1087,7 +1088,7 @@ emit_limple_inst (Lisp_Object inst) else if (EQ (op, Qset)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); - Lisp_Object arg1 = THIRD (inst); + Lisp_Object arg1 = SECOND (args); if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); @@ -1107,7 +1108,7 @@ emit_limple_inst (Lisp_Object inst) { /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); - EMACS_UINT param_n = XFIXNUM (THIRD (inst)); + EMACS_UINT param_n = XFIXNUM (SECOND (args)); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); @@ -1119,7 +1120,7 @@ emit_limple_inst (Lisp_Object inst) else if (EQ (op, Qsetimm)) { /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ - Lisp_Object arg1 = THIRD (inst); + Lisp_Object arg1 = SECOND (args); EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_block_add_assignment (comp.block, NULL, From a2cf65d2030c7856d029e43fec378efe42934400 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 13:57:51 +0200 Subject: [PATCH 0221/1452] separate code --- lisp/emacs-lisp/comp.el | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 62b80a0a5ac..877111653bc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -121,6 +121,9 @@ LIMPLE basic block.") (type nil :documentation "When non nil is used for type propagation.")) + +;;; Limplification pass specific code. + (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during limplification." (sp 0 :type 'fixnum @@ -659,6 +662,9 @@ the annotation emission." (cl-prettyprint (comp-func-ir func))) func)) + +;;; Entry points. + (defun native-compile (fun) "FUN is the function definition to be compiled into native code." (if-let ((f (symbol-function fun))) From 868b6b454ea75361a706ab57b45b6a49b124231d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 15:20:39 +0200 Subject: [PATCH 0222/1452] separate basic blocks --- lisp/emacs-lisp/comp.el | 146 +++++++++++++++++++++++----------------- src/comp.c | 39 +++++------ 2 files changed, 101 insertions(+), 84 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 877111653bc..558bed3187f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -41,11 +41,15 @@ (defvar comp-speed 2) (defvar byte-compile-lap-output) -(defconst comp-passes '(comp-recuparate-lap +(defvar comp-pass nil + "Every pass has the right to bind what it likes here.") + +(defconst comp-passes '(comp-spill-lap comp-limplify) "Passes to be executed in order.") -(defconst comp-known-ret-types '((Fcons . cons))) +(defconst comp-known-ret-types '((Fcons . cons)) + "Alist used for type propagation.") (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior @@ -70,22 +74,25 @@ (min nil :type number :documentation "Minimum number of arguments allowed.") (max nil - :documentation "Maximum number of arguments allowed -To be used when ncall-conv is nil..") + :documentation "Maximum number of arguments allowed. +To be used when ncall-conv is nil.") (ncall-conv nil :type boolean :documentation "If t the signature is: (ptrdiff_t nargs, Lisp_Object *args).")) (cl-defstruct (comp-block (:copier nil)) "A basic block." + ;; The first two slots are used during limplification. (sp nil - :documentation "When non nil indicates its the sp value while entering + :documentation "When non nil indicates the sp value while entering into it.") (closed nil :type 'boolean - :documentation "If the block was already closed.")) + :documentation "If the block was already closed.") + (insns () :type list + :documentation "List of instructions.")) (cl-defstruct (comp-func (:copier nil)) - "Internal rapresentation for a function." + "LIMPLE representation of a function." (symbol-name nil :documentation "Function symbol's name.") (c-func-name nil :type 'string @@ -94,8 +101,8 @@ into it.") :documentation "Original form.") (byte-func nil :documentation "Byte compiled version.") - (ir nil - :documentation "Current intermediate rappresentation.") + (lap () :type list + :documentation "Lap assembly representation.") (args nil :type 'comp-args) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table @@ -104,7 +111,7 @@ structure.") (lap-block (make-hash-table :test #'equal) :type 'hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block.") - (limple-cnt -1 :type 'number + (ssa-cnt -1 :type 'number :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) @@ -121,9 +128,6 @@ LIMPLE basic block.") (type nil :documentation "When non nil is used for type propagation.")) - -;;; Limplification pass specific code. - (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during limplification." (sp 0 :type 'fixnum @@ -133,17 +137,22 @@ LIMPLE basic block.") (block-name nil :type 'symbol :documentation "Current basic block name.")) -(defun comp-new-frame (size) - "Return a clean frame of meta variables of size SIZE." - (let ((v (make-vector size nil))) - (cl-loop for i below size - do (aset v i (make-comp-mvar :slot i))) - v)) +(defun comp-pretty-print-func (func) + "Pretty print function FUNC in the current buffer." + (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) + (cl-loop for bb being each hash-values of (comp-func-blocks func) + using (hash-key block-name) + do (progn + (insert (concat "\n<" (symbol-name block-name) ">")) + (cl-prettyprint (comp-block-insns bb))))) + + +;;; spill-lap pass specific code. (defun comp-c-func-name (symbol-function) "Given SYMBOL-FUNCTION return a name suitable for the native code." ;; Unfortunatelly not all symbol names are valid as C function names... - ;; Nassi's algorithm. + ;; Nassi's algorithm here: (let* ((orig-name (symbol-name symbol-function)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 @@ -170,26 +179,28 @@ LIMPLE basic block.") (make-comp-args :min mandatory :ncall-conv t)))) -(defun comp-recuparate-lap (func) - "Byte compile and recuparate LAP rapresentation for FUNC." - ;; FIXME block timers here, otherwise we could spill the wrong LAP. - (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) - (when comp-debug - (cl-prettyprint byte-compile-lap-output)) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (if (fixnump lambda-list) - (setf (comp-func-args func) - (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) - (error "Can't native compile a non lexical scoped function"))) - (setf (comp-func-ir func) byte-compile-lap-output) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) - func) +(defun comp-spill-lap (func) + "Byte compile and spill the LAP rapresentation for FUNC." + (let (byte-compile-lap-output) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) + (when comp-debug + (cl-prettyprint byte-compile-lap-output)) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (if (fixnump lambda-list) + (setf (comp-func-args func) + (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (error "Can't native compile a non lexical scoped function"))) + (setf (comp-func-lap func) byte-compile-lap-output) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + func)) -(declare-function comp-init-ctxt "comp.c") -(declare-function comp-release-ctxt "comp.c") -(declare-function comp-add-func-to-ctxt "comp.c") -(declare-function comp-compile-and-load-ctxt "comp.c") + +;;; Limplification pass specific code. + +;; Special vars used during limplifications +(defvar comp-block) +(defvar comp-func) ;; (defun comp-opt-call (inst) ;; "Optimize if possible a side-effect-free call in INST." @@ -198,13 +209,15 @@ LIMPLE basic block.") ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) -;; Special vars used during limplifications -(defvar comp-pass) -(defvar comp-limple) -(defvar comp-func) +(defun comp-new-frame (size) + "Return a clean frame of meta variables of size SIZE." + (let ((v (make-vector size nil))) + (cl-loop for i below size + do (aset v i (make-comp-mvar :slot i))) + v)) (cl-defun make-comp-mvar (&key slot const-vld constant type) - (make--comp-mvar :id (cl-incf (comp-func-limple-cnt comp-func)) + (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -236,9 +249,9 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-emit (x) - "Emit X into current LIMPLE ir.." - (push x comp-limple)) +(defun comp-emit (insn) + "Emit INSN into current basic block." + (push insn (comp-block-insns comp-block))) (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. @@ -328,9 +341,12 @@ If DST-N is specified use it otherwise assume it to be the current slot." ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) - (not (comp-block-closed (gethash (comp-limplify-block-name comp-pass) - blocks)))) + (not (comp-block-closed + (gethash (comp-limplify-block-name comp-pass) + blocks)))) (comp-emit-jump block-name)) + ;; Set this a currently compiled block. + (setf comp-block (gethash block-name blocks)) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. (setf (comp-limplify-frame comp-pass) @@ -338,7 +354,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name blocks))) - (comp-emit `(block ,block-name)) (setf (comp-limplify-block-name comp-pass) block-name))) (defun comp-emit-cond-jump (target-offset lap-label negated) @@ -436,7 +451,7 @@ the annotation emission." (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST accumulating in `comp-limple'." + "Limplify LAP instruction INST pushng it in the proper basic block." (let ((op (car inst)) (arg (if (consp (cdr inst)) (cadr inst) @@ -644,7 +659,7 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) - (comp-limple ())) + (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " @@ -652,28 +667,37 @@ the annotation emission." (cl-loop for i below (comp-args-min (comp-func-args func)) do (progn (cl-incf (comp-sp)) - (push `(setpar ,(comp-slot) ,i) comp-limple))) + (comp-emit `(setpar ,(comp-slot) ,i)))) (comp-emit-jump 'body) ;; Body (comp-emit-block 'body) - (mapc #'comp-limplify-lap-inst (comp-func-ir func)) - (setf (comp-func-ir func) (reverse comp-limple)) + (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + ;; Reverse insns into all basic blocks. + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (reverse (comp-block-insns bb)))) (when comp-debug - (cl-prettyprint (comp-func-ir func))) + (comp-pretty-print-func func)) func)) ;;; Entry points. -(defun native-compile (fun) - "FUN is the function definition to be compiled into native code." - (if-let ((f (symbol-function fun))) +(declare-function comp-init-ctxt "comp.c") +(declare-function comp-release-ctxt "comp.c") +(declare-function comp-add-func-to-ctxt "comp.c") +(declare-function comp-compile-and-load-ctxt "comp.c") + +(defun native-compile (func-symbol-name) + "FUNC-SYMBOL-NAME is the function name to be compiled into native code." + (if-let ((f (symbol-function func-symbol-name))) (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) - (let ((func (make-comp-func :symbol-name fun + (let ((func (make-comp-func :symbol-name func-symbol-name :func f - :c-func-name (comp-c-func-name fun)))) + :c-func-name (comp-c-func-name + func-symbol-name)))) (mapc (lambda (pass) (funcall pass func)) comp-passes) diff --git a/src/comp.c b/src/comp.c index edc35cf8b0e..ef72edd4990 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1052,19 +1052,14 @@ emit_limple_call_ref (Lisp_Object arg1) } static void -emit_limple_inst (Lisp_Object inst) +emit_limple_insn (Lisp_Object insn) { - Lisp_Object op = XCAR (inst); - Lisp_Object args = XCDR (inst); + Lisp_Object op = XCAR (insn); + Lisp_Object args = XCDR (insn); Lisp_Object arg0 = XCAR (args); gcc_jit_rvalue *res; - if (EQ (op, Qblock)) - { - /* Search for the already defined block and make it current. */ - comp.block = retrive_block (arg0); - } - else if (EQ (op, Qjump)) + if (EQ (op, Qjump)) { /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); @@ -1083,7 +1078,7 @@ emit_limple_inst (Lisp_Object inst) { gcc_jit_block_add_eval (comp.block, NULL, - emit_limple_call (inst)); + emit_limple_call (insn)); } else if (EQ (op, Qset)) { @@ -2052,20 +2047,19 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, declare_block ((char *) SDATA (SYMBOL_NAME (HASH_KEY (ht, i)))); } - while (CONSP (blocks)) + for (ptrdiff_t i = 0; i < ht->count; i++) { - char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); - declare_block (block_name); - blocks = XCDR (blocks); - } + Lisp_Object block_name = HASH_KEY (ht, i); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = FUNCALL1 (comp-block-insns, block); - Lisp_Object limple = FUNCALL1 (comp-func-ir, func); - - while (CONSP (limple)) - { - Lisp_Object inst = XCAR (limple); - emit_limple_inst (inst); - limple = XCDR (limple); + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } } comp.funcs = Fcons (func, comp.funcs); @@ -2126,7 +2120,6 @@ syms_of_comp (void) { /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); - DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); From 8b22849a5cef3e81e8b81cf7f32c186471607e06 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jul 2019 22:02:17 +0200 Subject: [PATCH 0223/1452] pushconditioncase working --- lisp/emacs-lisp/comp.el | 22 ++++---- src/comp.c | 121 +++++++++++++++++++++++++++++++++++----- test/src/comp-tests.el | 90 +++++++++++++++--------------- 3 files changed, 165 insertions(+), 68 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 558bed3187f..35a59dbe607 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -488,21 +488,21 @@ the annotation emission." (comp-emit '(pop-handler))) (byte-pushconditioncase (let ((blocks (comp-func-blocks comp-func)) - (fall-bb (comp-new-block-sym))) ;; Fall through block - (puthash fall-bb + (guarded-bb (comp-new-block-sym))) + (puthash guarded-bb (make-comp-block :sp (comp-sp)) blocks) - (let ((target (comp-lap-to-limple-bb (cl-third inst))) + (let ((handler-bb (comp-lap-to-limple-bb (cl-third inst))) (handler-type (cdr (last inst)))) (comp-emit (list 'push-handler (comp-slot-next) handler-type - target - fall-bb)) - (puthash target - (make-comp-block :sp (comp-sp)) + handler-bb + guarded-bb)) + (puthash handler-bb + (make-comp-block :sp (1+ (comp-sp))) blocks) - (comp-mark-block-closed)) - (comp-emit-block fall-bb))) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) (byte-pushcatch) (byte-nth auto) (byte-symbolp auto) @@ -668,9 +668,9 @@ the annotation emission." do (progn (cl-incf (comp-sp)) (comp-emit `(setpar ,(comp-slot) ,i)))) - (comp-emit-jump 'body) + (comp-emit-jump 'bb_1) ;; Body - (comp-emit-block 'body) + (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) ;; Reverse insns into all basic blocks. (cl-loop for bb being the hash-value in (comp-func-blocks func) diff --git a/src/comp.c b/src/comp.c index ef72edd4990..93d0f81dbc8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -948,18 +948,6 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } -/* static gcc_jit_rvalue * */ -/* emit_call_n_ref (const char *f_name, unsigned nargs, */ -/* gcc_jit_lvalue *base_arg) */ -/* { */ -/* gcc_jit_rvalue *args[] = */ -/* { gcc_jit_context_new_rvalue_from_int(comp.ctxt, */ -/* comp.ptrdiff_type, */ -/* nargs), */ -/* gcc_jit_lvalue_get_address (base_arg, NULL) }; */ -/* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ -/* } */ - /* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it from frame. */ @@ -1051,14 +1039,86 @@ emit_limple_call_ref (Lisp_Object arg1) return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } +/* Register an handler for a non local exit. */ + +static void +emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + EMACS_UINT clobber_slot) +{ + /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ + + static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ + gcc_jit_rvalue *args[2]; + + /* struct handler *c = push_handler (POP, type); */ + gcc_jit_lvalue *c = + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + format_string ("c_%u", + pushhandler_n)); + args[0] = handler; + args[1] = handler_type; + gcc_jit_block_add_assignment ( + comp.block, + NULL, + c, + emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_jmp_field), + NULL); + + gcc_jit_rvalue *res; +#ifdef HAVE__SETJMP + res = emit_call ("_setjmp", comp.int_type, 1, args); +#else + res = emit_call ("setjmp", comp.int_type, 1, args); +#endif + emit_cond_jump (res, handler_bb, guarded_bb); + + /* This emit the handler part. */ + + comp.block = handler_bb; + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + comp.frame[clobber_slot], + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field))); + ++pushhandler_n; +} + static void emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0 = XCAR (args); + Lisp_Object arg0; gcc_jit_rvalue *res; + if (CONSP (args)) + arg0 = XCAR (args); + if (EQ (op, Qjump)) { /* Unconditional branch. */ @@ -1074,6 +1134,39 @@ emit_limple_insn (Lisp_Object insn) emit_cond_jump (emit_NILP (test), target2, target1); } + else if (EQ (op, Qpush_handler)) + { + EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_rvalue *handler = emit_mvar_val (arg0); + gcc_jit_rvalue *handler_type = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + XFIXNUM (SECOND (args))); + gcc_jit_block *handler_bb = retrive_block (THIRD (args)); + gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); + emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, + clobber_slot); + } + else if (EQ (op, Qpop_handler)) + { + /* current_thread->m_handlerlist = + current_thread->m_handlerlist->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, @@ -2129,6 +2222,8 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4462f35246a..871dede23a6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -416,56 +416,58 @@ (buffer-string)) "abcd"))) -;; (ert-deftest comp-tests-non-locals () -;; "Test non locals." -;; (defun comp-tests-err-arith-f () -;; (/ 1 0)) -;; (defun comp-tests-err-foo-f () -;; (error "foo")) +(ert-deftest comp-tests-non-locals () + "Test non locals." + (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! + (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-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-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-catch-f (f) + ;; (catch 'foo + ;; (funcall f))) -;; (defun comp-tests-throw-f (x) -;; (throw 'foo x)) + ;; (defun comp-tests-throw-f (x) + ;; (throw 'foo x)) -;; (native-compile #'comp-tests-condition-case-0-f) -;; (native-compile #'comp-tests-condition-case-1-f) -;; (native-compile #'comp-tests-catch-f) -;; (native-compile #'comp-tests-throw-f) + (native-compile #'comp-tests-condition-case-0-f) + (native-compile #'comp-tests-condition-case-1-f) + ;; (native-compile #'comp-tests-catch-f) + ;; (native-compile #'comp-tests-throw-f) -;; (should (string= (comp-tests-condition-case-0-f) -;; "arith-error Arithmetic error catched")) -;; (should (string= (comp-tests-condition-case-1-f) -;; "error foo catched")) -;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) -;; (should (= (catch 'foo -;; (comp-tests-throw-f 3))))) + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched"))) + ;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + ;; (should (= (catch 'foo + ;; (comp-tests-throw-f 3)))) + ) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." From 1b72dad74f2e193e8da8de58ef8c46341897269a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Jul 2019 11:08:53 +0200 Subject: [PATCH 0224/1452] catch works --- lisp/emacs-lisp/comp.el | 60 ++++++++++++++++++++++------------------- src/comp.c | 11 +++++++- test/src/comp-tests.el | 23 ++++++++-------- 3 files changed, 53 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 35a59dbe607..005a7d0eb08 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -407,6 +407,24 @@ If NEGATED non nil negate the test condition." (puthash n name hash) name)))) +(defun comp-emit-handler (guarded-label handler-type) + "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." + (let ((blocks (comp-func-blocks comp-func)) + (guarded-bb (comp-new-block-sym))) + (puthash guarded-bb + (make-comp-block :sp (comp-sp)) + blocks) + (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-emit (list 'push-handler (comp-slot-next) + handler-type + handler-bb + guarded-bb)) + (puthash handler-bb + (make-comp-block :sp (1+ (comp-sp))) + blocks) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -450,12 +468,12 @@ the annotation emission." op-name)))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) -(defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST pushng it in the proper basic block." - (let ((op (car inst)) - (arg (if (consp (cdr inst)) - (cadr inst) - (cdr inst)))) +(defun comp-limplify-lap-inst (insn) + "Limplify LAP instruction INSN pushng it in the proper basic block." + (let ((op (car insn)) + (arg (if (consp (cdr insn)) + (cadr insn) + (cdr insn)))) (comp-op-case (TAG (comp-emit-block (comp-lap-to-limple-bb arg))) @@ -487,23 +505,9 @@ the annotation emission." (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase - (let ((blocks (comp-func-blocks comp-func)) - (guarded-bb (comp-new-block-sym))) - (puthash guarded-bb - (make-comp-block :sp (comp-sp)) - blocks) - (let ((handler-bb (comp-lap-to-limple-bb (cl-third inst))) - (handler-type (cdr (last inst)))) - (comp-emit (list 'push-handler (comp-slot-next) - handler-type - handler-bb - guarded-bb)) - (puthash handler-bb - (make-comp-block :sp (1+ (comp-sp))) - blocks) - (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) - (byte-pushcatch) + (comp-emit-handler (cl-third insn) 'condition-case)) + (byte-pushcatch + (comp-emit-handler (cl-third insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -584,15 +588,15 @@ the annotation emission." (byte-end-of-line auto) (byte-constant2) (byte-goto - (comp-emit-jump (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump 0 (cl-third inst) nil)) + (comp-emit-cond-jump 0 (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump 0 (cl-third inst) t)) + (comp-emit-cond-jump 0 (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump 1 (cl-third inst) nil)) + (comp-emit-cond-jump 1 (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump 1 (cl-third inst) t)) + (comp-emit-cond-jump 1 (cl-third insn) t)) (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) diff --git a/src/comp.c b/src/comp.c index 93d0f81dbc8..6436a5db712 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1138,10 +1138,17 @@ emit_limple_insn (Lisp_Object insn) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); + int h_num; + if (EQ (SECOND (args), Qcatcher)) + h_num = CATCHER; + else if (EQ (SECOND (args), Qcondition_case)) + h_num = CONDITION_CASE; + else + eassert (false); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, - XFIXNUM (SECOND (args))); + h_num); gcc_jit_block *handler_bb = retrive_block (THIRD (args)); gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, @@ -2224,6 +2231,8 @@ syms_of_comp (void) DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qcondition_case, "condition-case"); + DEFSYM (Qcatcher, "catcher"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 871dede23a6..ed3a9b2f9d0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -448,26 +448,25 @@ (error-message-string err) " catched")))) - ;; (defun comp-tests-catch-f (f) - ;; (catch 'foo - ;; (funcall f))) + (defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) - ;; (defun comp-tests-throw-f (x) - ;; (throw 'foo x)) + (defun comp-tests-throw-f (x) + (throw 'foo x)) (native-compile #'comp-tests-condition-case-0-f) (native-compile #'comp-tests-condition-case-1-f) - ;; (native-compile #'comp-tests-catch-f) - ;; (native-compile #'comp-tests-throw-f) + (native-compile #'comp-tests-catch-f) + (native-compile #'comp-tests-throw-f) (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) (should (string= (comp-tests-condition-case-1-f) - "error foo catched"))) - ;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) - ;; (should (= (catch 'foo - ;; (comp-tests-throw-f 3)))) - ) + "error foo catched")) + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3)))))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." From 79f7d40fa850806450621f2fa4c73974399bd7f9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Aug 2019 16:15:37 +0200 Subject: [PATCH 0225/1452] better make-comp-mvar --- lisp/emacs-lisp/comp.el | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 005a7d0eb08..69f43822948 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -140,8 +140,8 @@ LIMPLE basic block.") (defun comp-pretty-print-func (func) "Pretty print function FUNC in the current buffer." (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) - (cl-loop for bb being each hash-values of (comp-func-blocks func) - using (hash-key block-name) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) do (progn (insert (concat "\n<" (symbol-name block-name) ">")) (cl-prettyprint (comp-block-insns bb))))) @@ -216,7 +216,7 @@ LIMPLE basic block.") do (aset v i (make-comp-mvar :slot i))) v)) -(cl-defun make-comp-mvar (&key slot const-vld constant type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -315,7 +315,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :const-vld t :constant val)) (comp-emit (list 'setimm (comp-slot) val))) @@ -385,8 +384,7 @@ If NEGATED non nil negate the test condition." (comp-with-sp (1- n) (comp-emit-set-call `(call Fcons ,(comp-slot) - ,(make-comp-mvar :const-vld t - :constant nil)))) + ,(make-comp-mvar :constant nil)))) (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) do (comp-with-sp sp (comp-emit-set-call `(call Fcons @@ -481,27 +479,22 @@ the annotation emission." (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar - :const-vld t :constant arg)))) (byte-varset (comp-emit `(call set_internal - ,(make-comp-mvar :const-vld t - :constant arg) + ,(make-comp-mvar :constant arg) ,(comp-slot)))) (byte-varbind (comp-emit `(call specbind - ,(make-comp-mvar :const-vld t - :constant arg) + ,(make-comp-mvar :constant arg) ,(comp-slot-next)))) (byte-call (comp-stack-adjust (- arg)) (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) (byte-unbind (comp-emit `(call unbind_to - ,(make-comp-mvar :const-vld t - :constant arg) - ,(make-comp-mvar :const-vld t - :constant nil)))) + ,(make-comp-mvar :constant arg) + ,(make-comp-mvar :constant nil)))) (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase @@ -672,7 +665,6 @@ the annotation emission." do (progn (cl-incf (comp-sp)) (comp-emit `(setpar ,(comp-slot) ,i)))) - (comp-emit-jump 'bb_1) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) From bebe5a9791f7db3f088e0c07b2fd68e1d21bb161 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Aug 2019 17:08:55 +0200 Subject: [PATCH 0226/1452] add limple switch support --- lisp/emacs-lisp/comp.el | 33 +++++++++++++++++++++++---------- src/comp.c | 9 +++++---- test/src/comp-tests.el | 21 +++++++++++---------- 3 files changed, 39 insertions(+), 24 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 69f43822948..4841753172f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -355,11 +355,11 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-block-sp (gethash block-name blocks))) (setf (comp-limplify-block-name comp-pass) block-name))) -(defun comp-emit-cond-jump (target-offset lap-label negated) - "Emit a conditional jump to LAP-LABEL. +(defun comp-emit-cond-jump (a b target-offset lap-label negated) + "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non nil negate the test condition." +If NEGATED non nil negate the tested condition." (let ((blocks (comp-func-blocks comp-func)) (bb (comp-new-block-sym))) ;; Fall through block (puthash bb @@ -367,8 +367,8 @@ If NEGATED non nil negate the test condition." blocks) (let ((target (comp-lap-to-limple-bb lap-label))) (comp-emit (if negated - (list 'cond-jump (comp-slot-next) target bb) - (list 'cond-jump (comp-slot-next) bb target))) + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target))) (puthash target (make-comp-block :sp (+ target-offset (comp-sp))) blocks) @@ -423,6 +423,14 @@ If NEGATED non nil negate the test condition." (comp-mark-block-closed) (comp-emit-block guarded-bb)))) +(defun comp-emit-switch (var m-hash) + "Emit a limple for a lap jump table given VAR and M-HASH." + (cl-assert (comp-mvar-const-vld m-hash)) + (cl-loop for test being each hash-keys of (comp-mvar-constant m-hash) + using (hash-value target-label) + for m-test = (make-comp-mvar :constant test) + do (comp-emit-cond-jump var m-test 0 target-label nil))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -583,13 +591,17 @@ the annotation emission." (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump 0 (cl-third insn) nil)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump 0 (cl-third insn) t)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump 1 (cl-third insn) nil)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump 1 (cl-third insn) t)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (cl-third insn) t)) (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) @@ -642,7 +654,8 @@ the annotation emission." (byte-stack-set2) (byte-discardN (comp-stack-adjust (- arg))) - (byte-switch) + (byte-switch + (comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos diff --git a/src/comp.c b/src/comp.c index 6436a5db712..e4483ea4206 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,11 +1128,12 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *test = emit_mvar_val (arg0); - gcc_jit_block *target1 = retrive_block (SECOND (args)); - gcc_jit_block *target2 = retrive_block (THIRD (args)); + gcc_jit_rvalue *a = emit_mvar_val (arg0); + gcc_jit_rvalue *b = emit_mvar_val (SECOND (args)); + gcc_jit_block *target1 = retrive_block (THIRD (args)); + gcc_jit_block *target2 = retrive_block (FORTH (args)); - emit_cond_jump (emit_NILP (test), target2, target1); + emit_cond_jump (emit_EQ (a, b), target2, target1); } else if (EQ (op, Qpush_handler)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ed3a9b2f9d0..58846ed50d0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -200,18 +200,19 @@ (should (= (comp-tests-ffuncall-lambda-f 1) 2))) -;; (ert-deftest comp-tests-jump-table () -;; "Testing jump tables" -;; (defun comp-tests-jump-table-1-f (x) -;; (pcase x -;; ('x 'a) -;; ('y 'b) -;; (_ 'c))) +(ert-deftest comp-tests-jump-table () + "Testing jump tables" + (defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + (native-compile #'comp-tests-jump-table-1-f) -;; (should (eq (comp-tests-jump-table-1-f 'x) 'a)) -;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) -;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) (ert-deftest comp-tests-conditionals () "Testing conditionals." From 318c4772af4fa04fd8dc498bdc252b691b3cdab5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Aug 2019 19:42:57 +0200 Subject: [PATCH 0227/1452] fix comp-limplify-listn --- lisp/emacs-lisp/comp.el | 2 +- test/src/comp-tests.el | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4841753172f..71d747428d8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -381,7 +381,7 @@ If NEGATED non nil negate the tested condition." (defun comp-limplify-listn (n) "Limplify list N." - (comp-with-sp (1- n) + (comp-with-sp (+ (comp-sp) n -1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :constant nil)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 58846ed50d0..9fbff7639e9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -45,6 +45,8 @@ "Testing cons car cdr." (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)) @@ -59,12 +61,14 @@ (cdr-safe x)) (native-compile #'comp-tests-list-f) + (native-compile #'comp-tests-list2-f) (native-compile #'comp-tests-car-f) (native-compile #'comp-tests-cdr-f) (native-compile #'comp-tests-car-safe-f) (native-compile #'comp-tests-cdr-safe-f) (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) (should (= (condition-case err From c77ad1866d0e559db41118ad5a2c306c81fa3c21 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Aug 2019 19:14:35 +0200 Subject: [PATCH 0228/1452] add incoming &optional args support --- lisp/emacs-lisp/comp.el | 7 +++---- src/comp.c | 10 +++++----- test/src/comp-tests.el | 12 ++++++------ 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 71d747428d8..71dd016ab0d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -674,10 +674,9 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (cl-loop for i below (comp-args-min (comp-func-args func)) - do (progn - (cl-incf (comp-sp)) - (comp-emit `(setpar ,(comp-slot) ,i)))) + (cl-loop for i below (comp-args-max (comp-func-args func)) + do (cl-incf (comp-sp)) + do (comp-emit `(setpar ,(comp-slot) ,i))) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) diff --git a/src/comp.c b/src/comp.c index e4483ea4206..c7f68c7078e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2096,14 +2096,14 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); - EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - /* EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ - bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); + /* EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); */ + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) { comp.func = - emit_func_declare (c_name, comp.lisp_obj_type, min_args, + emit_func_declare (c_name, comp.lisp_obj_type, max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); } else @@ -2204,7 +2204,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); + x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); x->s.symbol_name = symbol_name; defsubr(x); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9fbff7639e9..7cf2a12f4a2 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -156,13 +156,13 @@ (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) - ;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) - ;; (list a b c d)) - ;; (native-compile #'comp-tests-ffuncall-callee-optional-f) + (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + (native-compile #'comp-tests-ffuncall-callee-optional-f) - ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) ;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) ;; (list a b c)) From 63bcc81d1df8524b20dab1fd45b2cba4d822a786 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Aug 2019 20:14:50 +0200 Subject: [PATCH 0229/1452] add incoming &rest arg support --- lisp/emacs-lisp/comp.el | 10 ++- src/comp.c | 150 ++++++++++++++++++++++++++++++++-------- test/src/comp-tests.el | 13 ++-- 3 files changed, 134 insertions(+), 39 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 71dd016ab0d..9e62f88896c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -669,14 +669,18 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) + (args-min (comp-args-min (comp-func-args func))) (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (cl-loop for i below (comp-args-max (comp-func-args func)) - do (cl-incf (comp-sp)) - do (comp-emit `(setpar ,(comp-slot) ,i))) + (if (not (comp-args-ncall-conv (comp-func-args func))) + (cl-loop for i below (comp-args-max (comp-func-args func)) + do (cl-incf (comp-sp)) + do (comp-emit `(setpar ,(comp-slot) ,i))) + (comp-emit `(ncall-prolog ,args-min)) + (cl-incf (comp-sp) (1+ args-min))) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) diff --git a/src/comp.c b/src/comp.c index c7f68c7078e..5a5ac69e622 100644 --- a/src/comp.c +++ b/src/comp.c @@ -404,34 +404,34 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ -/* static gcc_jit_rvalue * */ -/* emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, */ -/* int size_of_ptr_ref, gcc_jit_rvalue *i) */ -/* { */ -/* emit_comment ("ptr_arithmetic"); */ +static gcc_jit_rvalue * +emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, + int size_of_ptr_ref, gcc_jit_rvalue *i) +{ + emit_comment ("ptr_arithmetic"); -/* gcc_jit_rvalue *offset = */ -/* gcc_jit_context_new_binary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_MULT, */ -/* comp.uintptr_type, */ -/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ -/* comp.uintptr_type, */ -/* size_of_ptr_ref), */ -/* emit_cast (comp.uintptr_type, i)); */ + gcc_jit_rvalue *offset = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.uintptr_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + size_of_ptr_ref), + emit_cast (comp.uintptr_type, i)); -/* return */ -/* emit_cast ( */ -/* ptr_type, */ -/* gcc_jit_context_new_binary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_PLUS, */ -/* comp.uintptr_type, */ -/* emit_cast (comp.uintptr_type, ptr), */ -/* offset)); */ -/* } */ + return + emit_cast ( + ptr_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + offset)); +} INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) @@ -978,6 +978,75 @@ emit_mvar_val (Lisp_Object mvar) } } +static void +emit_ncall_prolog (EMACS_UINT n) +{ + /* + nargs will be known at runtime therfore we emit: + + prologue: + local[0] = *args; + ++args; + . + . + . + local[min_args - 1] = *args; + ++args; + local[min_args] = list (nargs - min_args, args); + bb_1: + . + . + . + */ + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + gcc_jit_rvalue *min_args = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + n); + + for (ptrdiff_t i = 0; i < n; ++i) + { + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[i], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference ( + gcc_jit_lvalue_as_rvalue (args), + NULL))); + + gcc_jit_block_add_assignment (comp.block, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); + } + + /* + rest arguments + */ + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + min_args), + gcc_jit_lvalue_as_rvalue (args) }; + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[n], + emit_call ("Flist", comp.lisp_obj_type, 2, + list_args)); +} + + static gcc_jit_rvalue * emit_limple_call (Lisp_Object arg1) { @@ -1202,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetpar)) { - /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ + /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); EMACS_UINT param_n = XFIXNUM (SECOND (args)); gcc_jit_rvalue *param = @@ -1213,6 +1282,11 @@ emit_limple_insn (Lisp_Object insn) comp.frame[slot_n], param); } + else if (EQ (op, Qncall_prolog)) + { + /* Ex: (ncall-prolog 2). */ + emit_ncall_prolog (XFIXNUM (arg0)); + } else if (EQ (op, Qsetimm)) { /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ @@ -2108,7 +2182,21 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, } else { - error ("Not supported for now"); + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + comp.func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, 2, param, 0); } gcc_jit_lvalue *frame_array = @@ -2204,7 +2292,10 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + if (NILP (FUNCALL1 (comp-args-ncall-conv, args))) + x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + else + x->s.max_args = MANY; x->s.symbol_name = symbol_name; defsubr(x); @@ -2226,6 +2317,7 @@ syms_of_comp (void) DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qsetpar, "setpar"); + DEFSYM (Qncall_prolog, "ncall-prolog"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 7cf2a12f4a2..96362ecf6e5 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -164,13 +164,13 @@ (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) - ;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) - ;; (list a b c)) - ;; (native-compile #'comp-tests-ffuncall-callee-rest-f) + (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + (native-compile #'comp-tests-ffuncall-callee-rest-f) - ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." @@ -291,7 +291,6 @@ ;; Bgeq (>= x y)) - (native-compile #'comp-tests-eqlsign-f) (native-compile #'comp-tests-gtr-f) (native-compile #'comp-tests-lss-f) From dba7034ea10fb394b0dcf91256b7df094218119f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Aug 2019 18:41:41 +0200 Subject: [PATCH 0230/1452] insert page breaks --- src/comp.c | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5a5ac69e622..7ca0aec45d3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -948,6 +948,11 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } + +/*************************************/ +/* Code emittes by LIMPLE statemes. */ +/*************************************/ + /* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it from frame. */ @@ -979,7 +984,7 @@ emit_mvar_val (Lisp_Object mvar) } static void -emit_ncall_prolog (EMACS_UINT n) +emit_limple_ncall_prolog (EMACS_UINT n) { /* nargs will be known at runtime therfore we emit: @@ -1046,7 +1051,6 @@ emit_ncall_prolog (EMACS_UINT n) list_args)); } - static gcc_jit_rvalue * emit_limple_call (Lisp_Object arg1) { @@ -1285,7 +1289,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qncall_prolog)) { /* Ex: (ncall-prolog 2). */ - emit_ncall_prolog (XFIXNUM (arg0)); + emit_limple_ncall_prolog (XFIXNUM (arg0)); } else if (EQ (op, Qsetimm)) { @@ -1310,6 +1314,11 @@ emit_limple_insn (Lisp_Object insn) } } + +/****************************************************************/ +/* Inline function definition and lisp data structure follows. */ +/****************************************************************/ + /* struct Lisp_Cons definition. */ static void @@ -1998,6 +2007,11 @@ define_bool_to_lisp_obj (void) } + +/**********************************/ +/* Entry points exposed to lisp. */ +/**********************************/ + DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) @@ -2341,11 +2355,14 @@ syms_of_comp (void) } + /******************************************************************************/ /* Helper functions called from the runtime. */ /* These can't be statics till shared mechanism is used to solve relocations. */ /******************************************************************************/ +/* TODO: cleanup */ + Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); From 6465002b8a51d065a662cb589e8e1cf0a78ad160 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Aug 2019 21:54:51 +0200 Subject: [PATCH 0231/1452] add tromeys tests --- test/src/comp-tests.el | 280 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 280 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 96362ecf6e5..332dd3f8c0f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -479,4 +479,284 @@ (should (= (comp-tests-cons-cdr-f 3) 3))) +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +(defun comp-test-apply (func &rest args) + (unless (subrp (symbol-function func)) + (native-compile func)) + (apply func args)) + +;; Test Bconsp. +(defun comp-test-consp (x) (consp x)) + +(ert-deftest comp-consp () + (should-not (comp-test-apply 'comp-test-consp 23)) + (should-not (comp-test-apply 'comp-test-consp nil)) + (should (comp-test-apply 'comp-test-consp '(1 . 2)))) + +;; Test Blistp. +(defun comp-test-listp (x) (listp x)) + +(ert-deftest comp-listp () + (should-not (comp-test-apply 'comp-test-listp 23)) + (should (comp-test-apply 'comp-test-listp nil)) + (should (comp-test-apply 'comp-test-listp '(1 . 2)))) + +;; Test Bstringp. +(defun comp-test-stringp (x) (stringp x)) + +(ert-deftest comp-stringp () + (should-not (comp-test-apply 'comp-test-stringp 23)) + (should-not (comp-test-apply 'comp-test-stringp nil)) + (should (comp-test-apply 'comp-test-stringp "hi"))) + +;; Test Bsymbolp. +(defun comp-test-symbolp (x) (symbolp x)) + +(ert-deftest comp-symbolp () + (should-not (comp-test-apply 'comp-test-symbolp 23)) + (should-not (comp-test-apply 'comp-test-symbolp "hi")) + (should (comp-test-apply 'comp-test-symbolp 'whatever))) + +;; Test Bintegerp. +(defun comp-test-integerp (x) (integerp x)) + +(ert-deftest comp-integerp () + (should (comp-test-apply 'comp-test-integerp 23)) + (should-not (comp-test-apply 'comp-test-integerp 57.5)) + (should-not (comp-test-apply 'comp-test-integerp "hi")) + (should-not (comp-test-apply 'comp-test-integerp 'whatever))) + +;; Test Bnumberp. +(defun comp-test-numberp (x) (numberp x)) + +(ert-deftest comp-numberp () + (should (comp-test-apply 'comp-test-numberp 23)) + (should (comp-test-apply 'comp-test-numberp 57.5)) + (should-not (comp-test-apply 'comp-test-numberp "hi")) + (should-not (comp-test-apply 'comp-test-numberp 'whatever))) + +;; Test Badd1. +(defun comp-test-add1 (x) (1+ x)) + +(ert-deftest comp-add1 () + (should (eq (comp-test-apply 'comp-test-add1 23) 24)) + (should (eq (comp-test-apply 'comp-test-add1 -17) -16)) + (should (eql (comp-test-apply 'comp-test-add1 1.0) 2.0)) + (should-error (comp-test-apply 'comp-test-add1 nil) + :type 'wrong-type-argument)) + +;; Test Bsub1. +(defun comp-test-sub1 (x) (1- x)) + +(ert-deftest comp-sub1 () + (should (eq (comp-test-apply 'comp-test-sub1 23) 22)) + (should (eq (comp-test-apply 'comp-test-sub1 -17) -18)) + (should (eql (comp-test-apply 'comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-apply 'comp-test-sub1 nil) + :type 'wrong-type-argument)) + +;; Test Bneg. +(defun comp-test-negate (x) (- x)) + +(ert-deftest comp-negate () + (should (eq (comp-test-apply 'comp-test-negate 23) -23)) + (should (eq (comp-test-apply 'comp-test-negate -17) 17)) + (should (eql (comp-test-apply 'comp-test-negate 1.0) -1.0)) + (should-error (comp-test-apply 'comp-test-negate nil) + :type 'wrong-type-argument)) + +;; Test Bnot. +(defun comp-test-not (x) (not x)) + +(ert-deftest comp-not () + (should (eq (comp-test-apply 'comp-test-not 23) nil)) + (should (eq (comp-test-apply 'comp-test-not nil) t)) + (should (eq (comp-test-apply 'comp-test-not t) nil))) + +;; 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)) + +(ert-deftest comp-bobp-and-eobp () + (with-temp-buffer + (should (comp-test-apply 'comp-test-bobp)) + (should (comp-test-apply 'comp-test-eobp)) + (insert "hi") + (goto-char (point-min)) + (should (eq (comp-test-apply 'comp-test-point-min) (point-min))) + (should (eq (comp-test-apply 'comp-test-point) (point-min))) + (should (comp-test-apply 'comp-test-bobp)) + (should-not (comp-test-apply 'comp-test-eobp)) + (goto-char (point-max)) + (should (eq (comp-test-apply 'comp-test-point-max) (point-max))) + (should (eq (comp-test-apply 'comp-test-point) (point-max))) + (should-not (comp-test-apply 'comp-test-bobp)) + (should (comp-test-apply 'comp-test-eobp)))) + +;; Test Bcar and Bcdr. +(defun comp-test-car (x) (car x)) +(defun comp-test-cdr (x) (cdr x)) + +(ert-deftest comp-car-cdr () + (let ((pair '(1 . b))) + (should (eq (comp-test-apply 'comp-test-car pair) 1)) + (should (eq (comp-test-apply 'comp-test-car nil) nil)) + (should-error (comp-test-apply 'comp-test-car 23) + :type 'wrong-type-argument) + (should (eq (comp-test-apply 'comp-test-cdr pair) 'b)) + (should (eq (comp-test-apply 'comp-test-cdr nil) nil)) + (should-error (comp-test-apply 'comp-test-cdr 23) + :type 'wrong-type-argument))) + +;; Test Bcar_safe and Bcdr_safe. +(defun comp-test-car-safe (x) (car-safe x)) +(defun comp-test-cdr-safe (x) (cdr-safe x)) + +(ert-deftest comp-car-cdr-safe () + (let ((pair '(1 . b))) + (should (eq (comp-test-apply 'comp-test-car-safe pair) 1)) + (should (eq (comp-test-apply 'comp-test-car-safe nil) nil)) + (should (eq (comp-test-apply 'comp-test-car-safe 23) nil)) + (should (eq (comp-test-apply 'comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-apply 'comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-apply 'comp-test-cdr-safe 23) nil)))) + +;; Test Beq. +(defun comp-test-eq (x y) (eq x y)) + +(ert-deftest comp-eq () + (should (comp-test-apply 'comp-test-eq 'a 'a)) + (should (comp-test-apply 'comp-test-eq 5 5)) + (should-not (comp-test-apply 'comp-test-eq 'a 'b)) + (should-not (comp-test-apply 'comp-test-eq "x" "x"))) + +;; Test Bgotoifnil. +(defun comp-test-if (x y) (if x x y)) + +(ert-deftest comp-if () + (should (eq (comp-test-apply 'comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-apply 'comp-test-if 0 23) 0)) + (should (eq (comp-test-apply 'comp-test-if nil 'b) 'b))) + +;; Test Bgotoifnilelsepop. +(defun comp-test-and (x y) (and x y)) + +(ert-deftest comp-and () + (should (eq (comp-test-apply 'comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-apply 'comp-test-and 0 23) 23)) + (should (eq (comp-test-apply 'comp-test-and nil 'b) nil))) + +;; Test Bgotoifnonnilelsepop. +(defun comp-test-or (x y) (or x y)) + +(ert-deftest comp-or () + (should (eq (comp-test-apply 'comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-apply 'comp-test-or 0 23) 0)) + (should (eq (comp-test-apply 'comp-test-or nil 'b) 'b))) + +;; Test Bsave_excursion. +(defun comp-test-save-excursion () + (save-excursion + (insert "XYZ"))) + +;; Test Bcurrent_buffer. +(defun comp-test-current-buffer () (current-buffer)) + +(ert-deftest comp-save-excursion () + (with-temp-buffer + (comp-test-apply 'comp-test-save-excursion) + (should (eq (point) (point-min))) + (should (eq (comp-test-apply 'comp-test-current-buffer) (current-buffer))))) + +;; Test Bgtr. +(defun comp-test-> (a b) + (> a b)) + +(ert-deftest comp-> () + (should (eq (comp-test-apply 'comp-test-> 0 23) nil)) + (should (eq (comp-test-apply 'comp-test-> 23 0) t))) + +;; Test Bpushcatch. +(defun comp-test-catch (&rest l) + (catch 'done + (dolist (v l) + (when (> v 23) + (throw 'done v))))) + +(ert-deftest comp-catch () + (should (eq (comp-test-apply 'comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-apply 'comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) + +;; Test Bmemq. +(defun comp-test-memq (val list) + (memq val list)) + +(ert-deftest comp-memq () + (should (equal (comp-test-apply 'comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-apply 'comp-test-memq 72 '(5 4 3 2 1 0)) nil))) + +;; Test BlistN. +(defun comp-test-listN (x) + (list x x x x x x x x x x x x x x x x)) + +(ert-deftest comp-listN () + (should (equal (comp-test-apply 'comp-test-listN 57) + '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) + +;; Test BconcatN. +(defun comp-test-concatN (x) + (concat x x x x x x)) + +(ert-deftest comp-concatN () + (should (equal (comp-test-apply 'comp-test-concatN "x") "xxxxxx"))) + +;; Test optional and rest arguments. +(defun comp-test-opt-rest (a &optional b &rest c) + (list a b c)) + +(ert-deftest comp-opt-rest () + (should (equal (comp-test-apply 'comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-apply 'comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 56 57 58) + '(1 2 (56 57 58))))) + +;; Test for too many arguments. +(defun comp-test-opt (a &optional b) + (cons a b)) + +(ert-deftest comp-opt () + (should (equal (comp-test-apply 'comp-test-opt 23) '(23))) + (should (equal (comp-test-apply 'comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-apply 'comp-test-opt) + :type 'wrong-number-of-arguments) + (should-error (comp-test-apply 'comp-test-opt nil 24 97) + :type 'wrong-number-of-arguments)) + +;; 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))) + +(ert-deftest comp-unwind-protect () + (comp-test-unwind-protect 'ignore) + (should (eq comp-test-up-val 999)) + (condition-case nil + (comp-test-unwind-protect (lambda () (error "HI"))) + (error + nil)) + (should (eq comp-test-up-val 999))) + ;;; comp-tests.el ends here From f46bfdf3234548f664824b7c96838d3f918950d7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Aug 2019 23:06:28 +0200 Subject: [PATCH 0232/1452] fix max_args --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 7ca0aec45d3..16089beee1e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2185,11 +2185,11 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); /* EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); */ - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) { + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); comp.func = emit_func_declare (c_name, comp.lisp_obj_type, max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); From b3dc6e8f06892869e0dcf39fd226b63752ce6cf9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Aug 2019 23:56:12 +0200 Subject: [PATCH 0233/1452] fix gcc interruption --- src/comp.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 16089beee1e..54078e89bfc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include #include "lisp.h" @@ -2280,9 +2281,14 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp_speed); - /* Gcc doesn't like being interrupted. */ + /* Gcc doesn't like being interrupted at all. */ sigset_t oldset; - block_atimers (&oldset); + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); if (COMP_DEBUG) gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); From a5e428a638718223b0ab667382a8493a135db0ca Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Aug 2019 22:00:35 +0200 Subject: [PATCH 0234/1452] rework tests --- test/src/comp-tests.el | 283 ++++++++++++++++++----------------------- 1 file changed, 126 insertions(+), 157 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 332dd3f8c0f..e959e265228 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -27,19 +27,42 @@ (require 'ert) (require 'comp) +;; (require 'cl-lib) -(setq garbage-collection-messages t) +(defun comp-test-apply (func &rest args) + (unless (subrp (symbol-function func)) + (native-compile func)) + (apply func args)) + +(defun comp-mashup (&rest args) + "Mash-up ARGS and return a symbol." + (intern (apply #'concat + (mapcar (lambda (x) + (cl-etypecase x + (symbol (symbol-name x)) + (string x))) + args)))) + +;; (setq garbage-collection-messages t) (defvar comp-tests-var1 3) -(ert-deftest comp-tests-varref () +;; (defmacro comp-ert-deftest (name &rest body) +;; (declare (indent defun)) +;; `(progn +;; ,@(cl-loop for speed from 0 to 3 +;; for test-name = (comp-mashup name "-speed-" +;; (number-to-string speed)) +;; collect `(ert-deftest ,test-name () +;; (let ((comp-speed ,speed)) +;; ,body))))) + +(ert-deftest comp-tests-varref () "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) - (native-compile #'comp-tests-varref-f) - - (should (= (comp-tests-varref-f) 3))) + (should (= (comp-test-apply #'comp-tests-varref-f) 3))) (ert-deftest comp-tests-list () "Testing cons car cdr." @@ -60,52 +83,42 @@ ;; Bcdr_safe (cdr-safe x)) - (native-compile #'comp-tests-list-f) - (native-compile #'comp-tests-list2-f) - (native-compile #'comp-tests-car-f) - (native-compile #'comp-tests-cdr-f) - (native-compile #'comp-tests-car-safe-f) - (native-compile #'comp-tests-cdr-safe-f) - - (should (equal (comp-tests-list-f) '(1 2 3))) - (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) - (should (= (comp-tests-car-f '(1 . 2)) 1)) - (should (null (comp-tests-car-f nil))) + (should (equal (comp-test-apply #'comp-tests-list-f) '(1 2 3))) + (should (equal (comp-test-apply #'comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-test-apply #'comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-test-apply #'comp-tests-car-f nil))) (should (= (condition-case err - (comp-tests-car-f 3) + (comp-test-apply #'comp-tests-car-f 3) (error 10)) 10)) - (should (= (comp-tests-cdr-f '(1 . 2)) 2)) - (should (null (comp-tests-cdr-f nil))) + (should (= (comp-test-apply #'comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-test-apply #'comp-tests-cdr-f nil))) (should (= (condition-case err - (comp-tests-cdr-f 3) + (comp-test-apply #'comp-tests-cdr-f 3) (error 10)) 10)) - (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) - (should (null (comp-tests-car-safe-f 'a))) - (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) - (should (null (comp-tests-cdr-safe-f 'a)))) + (should (= (comp-test-apply #'comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-test-apply #'comp-tests-car-safe-f 'a))) + (should (= (comp-test-apply #'comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-test-apply #'comp-tests-cdr-safe-f 'a)))) (ert-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." (defun comp-tests-cons-car-f () (car (cons 1 2))) - (native-compile #'comp-tests-cons-car-f) (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) - (native-compile #'comp-tests-cons-cdr-f) - (should (= (comp-tests-cons-car-f) 1)) - (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-test-apply #'comp-tests-cons-car-f) 1)) + (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) (ert-deftest comp-tests-varset () "Testing varset." (defun comp-tests-varset-f () (setq comp-tests-var1 55)) - (native-compile #'comp-tests-varset-f) - (comp-tests-varset-f) + (comp-test-apply #'comp-tests-varset-f) (should (= comp-tests-var1 55))) @@ -113,98 +126,91 @@ "Testing length." (defun comp-tests-length-f () (length '(1 2 3))) - (native-compile #'comp-tests-length-f) - (should (= (comp-tests-length-f) 3))) + (should (= (comp-test-apply #'comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref-aset () +(ert-deftest comp-tests-aref-aset () "Testing aref and aset." (defun comp-tests-aref-aset-f () (let ((vec [1 2 3])) (aset vec 2 100) (aref vec 2))) - (native-compile #'comp-tests-aref-aset-f) - (should (= (comp-tests-aref-aset-f) 100))) + (should (= (comp-test-apply #'comp-tests-aref-aset-f) 100))) -(ert-deftest comp-tests-symbol-value () +(ert-deftest comp-tests-symbol-value () "Testing aref and aset." (defvar comp-tests-var2 3) (defun comp-tests-symbol-value-f () (symbol-value 'comp-tests-var2)) - (native-compile #'comp-tests-symbol-value-f) - (should (= (comp-tests-symbol-value-f) 3))) + (should (= (comp-test-apply #'comp-tests-symbol-value-f) 3))) -(ert-deftest comp-tests-concat () +(ert-deftest comp-tests-concat () "Testing concatX opcodes." (defun comp-tests-concat-f (x) (concat "a" "b" "c" "d" (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - (native-compile #'comp-tests-concat-f) - (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + (should (string= (comp-test-apply #'comp-tests-concat-f "bar") "abcdabcabfoobar"))) -(ert-deftest comp-tests-ffuncall () - "Test calling conventions." - (defun comp-tests-ffuncall-callee-f (x y z) +(defun comp-tests-ffuncall-callee-f (x y z) (list x y z)) + +(ert-deftest comp-tests-ffuncall () + "Test calling conventions." + (native-compile #'comp-tests-ffuncall-calle-f) (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) - (native-compile #'comp-tests-ffuncall-caller-f) - - (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) - (native-compile #'comp-tests-ffuncall-callee-optional-f) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2) + '(1 2 nil nil))) (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) (list a b c)) - (native-compile #'comp-tests-ffuncall-callee-rest-f) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2) + '(1 2 nil))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3 4) + '(1 2 (3 4)))) (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." (make-vector 1 nil)) - (native-compile #'comp-tests-ffuncall-native-f) - - (should (equal (comp-tests-ffuncall-native-f) [nil])) + (should (equal (comp-test-apply #'comp-tests-ffuncall-native-f) [nil])) (defun comp-tests-ffuncall-native-rest-f () "Call a primitive with no dedicate op with &rest." (vector 1 2 3)) - (native-compile #'comp-tests-ffuncall-native-rest-f) - - (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + (should (equal (comp-test-apply #'comp-tests-ffuncall-native-rest-f) [1 2 3])) (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) - (native-compile #'comp-tests-ffuncall-apply-many-f) - - (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-apply-many-f '(1 2 3)) + '(1 2 3))) (defun comp-tests-ffuncall-lambda-f (x) (let ((fun (lambda (x) (1+ x)))) (funcall fun x))) - (native-compile #'comp-tests-ffuncall-lambda-f) + (should (= (comp-test-apply #'comp-tests-ffuncall-lambda-f 1) 2))) - (should (= (comp-tests-ffuncall-lambda-f 1) 2))) - -(ert-deftest comp-tests-jump-table () +(ert-deftest comp-tests-jump-table () "Testing jump tables" (defun comp-tests-jump-table-1-f (x) (pcase x @@ -212,13 +218,11 @@ ('y 'b) (_ 'c))) - (native-compile #'comp-tests-jump-table-1-f) + (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'xxx) 'c))) - (should (eq (comp-tests-jump-table-1-f 'x) 'a)) - (should (eq (comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) - -(ert-deftest comp-tests-conditionals () +(ert-deftest comp-tests-conditionals () "Testing conditionals." (defun comp-tests-conditionals-1-f (x) ;; Generate goto-if-nil @@ -227,15 +231,13 @@ ;; Generate goto-if-nil-else-pop (when x 1340)) - (native-compile #'comp-tests-conditionals-1-f) - (native-compile #'comp-tests-conditionals-2-f) - (should (= (comp-tests-conditionals-1-f t) 1)) - (should (= (comp-tests-conditionals-1-f nil) 2)) - (should (= (comp-tests-conditionals-2-f t) 1340)) - (should (eq (comp-tests-conditionals-2-f nil) nil))) + (should (= (comp-test-apply #'comp-tests-conditionals-1-f t) 1)) + (should (= (comp-test-apply #'comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-test-apply #'comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-test-apply #'comp-tests-conditionals-2-f nil) nil))) -(ert-deftest comp-tests-fixnum () +(ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." (defun comp-tests-fixnum-1-minus-f (x) ;; Bsub1 @@ -247,33 +249,29 @@ ;; Bnegate (- x)) - (native-compile #'comp-tests-fixnum-1-minus-f) - (native-compile #'comp-tests-fixnum-1-plus-f) - (native-compile #'comp-tests-fixnum-minus-f) - - (should (= (comp-tests-fixnum-1-minus-f 10) 9)) - (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-1-plus-f 10) 11)) - (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-plus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-minus-f 10) -10)) - (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (should (= (comp-test-apply #'comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-test-apply #'comp-tests-fixnum-minus-f most-negative-fixnum) (- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a)))) -(ert-deftest comp-tests-arith-comp () +(ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." (defun comp-tests-eqlsign-f (x y) ;; Beqlsign @@ -291,27 +289,21 @@ ;; Bgeq (>= x y)) - (native-compile #'comp-tests-eqlsign-f) - (native-compile #'comp-tests-gtr-f) - (native-compile #'comp-tests-lss-f) - (native-compile #'comp-tests-les-f) - (native-compile #'comp-tests-geq-f) - - (should (eq (comp-tests-eqlsign-f 4 3) nil)) - (should (eq (comp-tests-eqlsign-f 3 3) t)) - (should (eq (comp-tests-eqlsign-f 2 3) nil)) - (should (eq (comp-tests-gtr-f 4 3) t)) - (should (eq (comp-tests-gtr-f 3 3) nil)) - (should (eq (comp-tests-gtr-f 2 3) nil)) - (should (eq (comp-tests-lss-f 4 3) nil)) - (should (eq (comp-tests-lss-f 3 3) nil)) - (should (eq (comp-tests-lss-f 2 3) t)) - (should (eq (comp-tests-les-f 4 3) nil)) - (should (eq (comp-tests-les-f 3 3) t)) - (should (eq (comp-tests-les-f 2 3) t)) - (should (eq (comp-tests-geq-f 4 3) t)) - (should (eq (comp-tests-geq-f 3 3) t)) - (should (eq (comp-tests-geq-f 2 3) nil))) + (should (eq (comp-test-apply #'comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-test-apply #'comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-test-apply #'comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-test-apply #'comp-tests-gtr-f 4 3) t)) + (should (eq (comp-test-apply #'comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-test-apply #'comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-test-apply #'comp-tests-lss-f 4 3) nil)) + (should (eq (comp-test-apply #'comp-tests-lss-f 3 3) nil)) + (should (eq (comp-test-apply #'comp-tests-lss-f 2 3) t)) + (should (eq (comp-test-apply #'comp-tests-les-f 4 3) nil)) + (should (eq (comp-test-apply #'comp-tests-les-f 3 3) t)) + (should (eq (comp-test-apply #'comp-tests-les-f 2 3) t)) + (should (eq (comp-test-apply #'comp-tests-geq-f 4 3) t)) + (should (eq (comp-test-apply #'comp-tests-geq-f 3 3) t)) + (should (eq (comp-test-apply #'comp-tests-geq-f 2 3) nil))) (ert-deftest comp-tests-setcarcdr () "Testing setcar setcdr." @@ -322,11 +314,8 @@ (setcdr x y) x) - (native-compile #'comp-tests-setcar-f) - (native-compile #'comp-tests-setcdr-f) - - (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (comp-test-apply #'comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-test-apply #'comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) (should (equal (condition-case err (comp-tests-setcar-f 3 10) @@ -334,7 +323,7 @@ '(wrong-type-argument consp 3))) (should (equal (condition-case err - (comp-tests-setcdr-f 3 10) + (comp-test-apply #'comp-tests-setcdr-f 3 10) (error err)) '(wrong-type-argument consp 3)))) @@ -352,14 +341,12 @@ (setq i (1- i))) list)) - (native-compile #'comp-bubble-sort-f) - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) -(ert-deftest comp-tests-list-inline () +(ert-deftest comp-test-apply () "Test some inlined list functions." (defun comp-tests-consp-f (x) ;; Bconsp @@ -368,13 +355,10 @@ ;; Bsetcar (setcar x 3)) - (native-compile #'comp-tests-consp-f) - (native-compile #'comp-tests-car-f) - - (should (eq (comp-tests-consp-f '(1)) t)) - (should (eq (comp-tests-consp-f 1) nil)) + (should (eq (comp-test-apply #'comp-tests-consp-f '(1)) t)) + (should (eq (comp-test-apply #'comp-tests-consp-f 1) nil)) (let ((x (cons 1 2))) - (should (= (comp-tests-car-f x) 3)) + (should (= (comp-test-apply #'comp-tests-car-f x) 3)) (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () @@ -386,17 +370,14 @@ ;; Bnumberp (numberp x)) - (native-compile #'comp-tests-integerp-f) - (native-compile #'comp-tests-numberp-f) + (should (eq (comp-test-apply #'comp-tests-integerp-f 1) t)) + (should (eq (comp-test-apply #'comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-test-apply #'comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-test-apply #'comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - (should (eq (comp-tests-integerp-f 1) t)) - (should (eq (comp-tests-integerp-f '(1)) nil)) - (should (eq (comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - - (should (eq (comp-tests-numberp-f 1) t)) - (should (eq (comp-tests-numberp-f 'a) nil)) - (should (eq (comp-tests-numberp-f 3.5) t))) + (should (eq (comp-test-apply #'comp-tests-numberp-f 1) t)) + (should (eq (comp-test-apply #'comp-tests-numberp-f 'a) nil)) + (should (eq (comp-test-apply #'comp-tests-numberp-f 3.5) t))) (ert-deftest comp-tests-stack () "Test some stack operation." @@ -410,11 +391,7 @@ ;; Binsert (insert a b c d)) - (native-compile #'comp-tests-discardn-f) - (native-compile #'comp-tests-insertn-f) - - (should (= (comp-tests-discardn-f 10) 2)) - + (should (= (comp-test-apply #'comp-tests-discardn-f 10) 2)) (should (string= (with-temp-buffer (comp-tests-insertn-f "a" "b" "c" "d") (buffer-string)) @@ -459,16 +436,13 @@ (defun comp-tests-throw-f (x) (throw 'foo x)) - (native-compile #'comp-tests-condition-case-0-f) - (native-compile #'comp-tests-condition-case-1-f) - (native-compile #'comp-tests-catch-f) - (native-compile #'comp-tests-throw-f) - - (should (string= (comp-tests-condition-case-0-f) + (should (string= (comp-test-apply #'comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) - (should (string= (comp-tests-condition-case-1-f) + (should (string= (comp-test-apply #'comp-tests-condition-case-1-f) "error foo catched")) - (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (comp-test-apply #'comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) (should (= (catch 'foo (comp-tests-throw-f 3)))))) @@ -477,17 +451,12 @@ (dotimes (_ 100000) (comp-tests-cons-cdr-f 3)) - (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; -(defun comp-test-apply (func &rest args) - (unless (subrp (symbol-function func)) - (native-compile func)) - (apply func args)) - ;; Test Bconsp. (defun comp-test-consp (x) (consp x)) From 39e224ba18485d7da68d13579c74afb2cc86f382 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 8 Aug 2019 10:54:39 +0200 Subject: [PATCH 0235/1452] clean-up unnecessary declarations --- lisp/emacs-lisp/comp.el | 5 ----- 1 file changed, 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9e62f88896c..169a124cc1a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -695,11 +695,6 @@ the annotation emission." ;;; Entry points. -(declare-function comp-init-ctxt "comp.c") -(declare-function comp-release-ctxt "comp.c") -(declare-function comp-add-func-to-ctxt "comp.c") -(declare-function comp-compile-and-load-ctxt "comp.c") - (defun native-compile (func-symbol-name) "FUNC-SYMBOL-NAME is the function name to be compiled into native code." (if-let ((f (symbol-function func-symbol-name))) From b670b2d8be07dd47274e4e771437b6c4e8649d66 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 8 Aug 2019 17:18:25 +0200 Subject: [PATCH 0236/1452] pthread_sigmask instead of unblock_atimers --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 54078e89bfc..5c5551c8da8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2322,7 +2322,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, comp.funcs = XCDR (comp.funcs); } - unblock_atimers (&oldset); + pthread_sigmask (SIG_SETMASK, &oldset, 0); return Qt; } From 7720dceba1079151c37aa0a3117ac22dac45a119 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 8 Aug 2019 17:35:25 +0200 Subject: [PATCH 0237/1452] add record_unwind_current_buffer helper_unwind_protect support --- lisp/emacs-lisp/comp.el | 8 +++++--- src/comp.c | 5 +++++ 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 169a124cc1a..7fa723fc88b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -573,7 +573,8 @@ the annotation emission." (byte-bobp auto) (byte-current-buffer auto) (byte-set-buffer auto) - (byte-save-current-buffer) + (byte-save-current-buffer + (comp-emit '(call record_unwind_current_buffer))) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) (byte-forward-char auto) @@ -603,7 +604,7 @@ the annotation emission." (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 (cl-third insn) t)) (byte-return - (comp-emit (list 'return (comp-slot-next))) + (comp-emit `(return ,(comp-slot-next))) (comp-mark-block-closed)) (byte-discard 'pass) (byte-dup @@ -612,7 +613,8 @@ the annotation emission." (byte-save-window-excursion-OBSOLETE) (byte-save-restriction) (byte-catch) - (byte-unwind-protect) + (byte-unwind-protect + (comp-emit '(call helper_unwind_protect))) (byte-condition-case) (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) diff --git a/src/comp.c b/src/comp.c index 5c5551c8da8..29fd9ce4f2e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1093,6 +1093,11 @@ emit_limple_call (Lisp_Object arg1) SET_INTERNAL_SET); return emit_call ("set_internal", comp.void_type , 4, gcc_args); } + else if (!strcmp (calle, "record_unwind_current_buffer") || + !strcmp (calle, "helper_unwind_protect")) + { + return emit_call (calle, comp.void_type, 0, NULL); + } error ("LIMPLE call is inconsistent"); } From e1757517c33d9c6428ecab8bc277aea14ec0c96f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Aug 2019 18:16:17 +0200 Subject: [PATCH 0238/1452] fix hash table weakness --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 29fd9ce4f2e..96e9c55f443 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2136,7 +2136,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, sizeof (void *), false); - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); /* Define data structures. */ @@ -2241,7 +2241,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, i)); comp.frame = frame; - comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal); /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ From 26da67d10b93e2997679e27b56a072e4767102c2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Aug 2019 18:17:05 +0200 Subject: [PATCH 0239/1452] add routine dispatcher --- src/comp.c | 126 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 74 insertions(+), 52 deletions(-) diff --git a/src/comp.c b/src/comp.c index 96e9c55f443..6552ea91c14 100644 --- a/src/comp.c +++ b/src/comp.c @@ -145,6 +145,7 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ Lisp_Object funcs; /* List of functions defined. */ + Lisp_Object routine_dispatcher; } comp_t; static comp_t comp; @@ -232,6 +233,15 @@ declare_block (const char * block_name) Fputhash (key, value, comp.func_blocks); } +static void +register_dispatch (const char *name, void *func) +{ + Lisp_Object key = make_string (name, strlen (name)); + Lisp_Object value = make_pointer_integer (XPL (func)); + Fputhash (key, value, comp.routine_dispatcher); +} + + INLINE static void emit_comment (const char *str) { @@ -241,22 +251,6 @@ emit_comment (const char *str) str); } - -/* Assignments to the meta-stack slots should be emitted usign this to always */ -/* reset annotation fields. */ - -/* static void */ -/* emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, */ -/* gcc_jit_rvalue *val) */ -/* { */ -/* gcc_jit_block_add_assignment (block->gcc_bb, */ -/* NULL, */ -/* slot->gcc_lval, */ -/* val); */ -/* slot->type = -1; */ -/* slot->const_set = false; */ -/* } */ - /* Declare a function with all args being Lisp_Object and returning a Lisp_Object. */ @@ -951,7 +945,7 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /*************************************/ -/* Code emittes by LIMPLE statemes. */ +/* Code emitted by LIMPLE statemes. */ /*************************************/ /* Emit an r-value from an mvar meta variable. @@ -984,6 +978,28 @@ emit_mvar_val (Lisp_Object mvar) } } +static gcc_jit_rvalue * +emit_set_internal (Lisp_Object args) +{ + /* + Ex: (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil)) + */ + /* TODO: Inline the most common case. */ + eassert (list_length (args) == 3); + args = XCDR (args); + int i = 0; + gcc_jit_rvalue *gcc_args[4]; + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); + gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + return emit_call ("set_internal", comp.void_type , 4, gcc_args); +} + static void emit_limple_ncall_prolog (EMACS_UINT n) { @@ -1052,46 +1068,45 @@ emit_limple_ncall_prolog (EMACS_UINT n) list_args)); } +/* This is for a regular function with arguments as m-var. */ + static gcc_jit_rvalue * -emit_limple_call (Lisp_Object arg1) +emit_simple_limple_call (Lisp_Object args) { - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - Lisp_Object call_args = XCDR (XCDR (arg1)); + /* + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) + + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) + */ int i = 0; + char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + args = XCDR (args); + ptrdiff_t nargs = list_length (args); + gcc_jit_rvalue *gcc_args[nargs]; + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_val (XCAR (args)); - if (calle[0] == 'F') + return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); +} + +/* Entry point to dispatch emission of (call fun ...). */ + +static gcc_jit_rvalue * +emit_limple_call (Lisp_Object args) +{ + Lisp_Object calle_sym = FIRST (args); + char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); + Lisp_Object emitter = Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); + + if (!NILP (emitter)) { - /* - Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil)) - */ - - ptrdiff_t nargs = list_length (call_args); - gcc_jit_rvalue *gcc_args[nargs]; - FOR_EACH_TAIL (call_args) - gcc_args[i++] = emit_mvar_val (XCAR (call_args)); - - return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = XFIXNUMPTR (emitter); + return emitter_ptr (args); } - else if (!strcmp (calle, "set_internal")) + else if (calle[0] == 'F') { - /* - Ex: (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil)) - */ - /* TODO: Inline the most common case. */ - eassert (list_length (call_args) == 2); - gcc_jit_rvalue *gcc_args[4]; - FOR_EACH_TAIL (call_args) - gcc_args[i++] = emit_mvar_val (XCAR (call_args)); - gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); - gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - SET_INTERNAL_SET); - return emit_call ("set_internal", comp.void_type , 4, gcc_args); + return emit_simple_limple_call (args); } else if (!strcmp (calle, "record_unwind_current_buffer") || !strcmp (calle, "helper_unwind_protect")) @@ -1258,7 +1273,7 @@ emit_limple_insn (Lisp_Object insn) { gcc_jit_block_add_eval (comp.block, NULL, - emit_limple_call (insn)); + emit_limple_call (args)); } else if (EQ (op, Qset)) { @@ -1268,7 +1283,7 @@ emit_limple_insn (Lisp_Object insn) if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); else if (EQ (FIRST (arg1), Qcall)) - res = emit_limple_call (arg1); + res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) res = emit_limple_call_ref (arg1); else @@ -2028,6 +2043,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, error ("Compiler context already taken."); return Qnil; } + comp.ctxt = gcc_jit_context_acquire(); comp.funcs = Qnil; @@ -2357,9 +2373,15 @@ syms_of_comp (void) defsubr (&Scomp_add_func_to_ctxt); defsubr (&Scomp_compile_and_load_ctxt); comp.func_hash = Qnil; + comp.routine_dispatcher = Qnil; staticpro (&comp.func_hash); staticpro (&comp.func_blocks); + comp.routine_dispatcher = CALLN (Fmake_hash_table, QCtest, Qequal); + register_dispatch ("set_internal", emit_set_internal); + register_dispatch ("helper_unbind_n", emit_simple_limple_call); + staticpro (&comp.routine_dispatcher); + DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); comp_speed = DEFAULT_SPEED; From a42d67628942244b0cb90276c4e0ec77e967c0bc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Aug 2019 20:21:43 +0200 Subject: [PATCH 0240/1452] change emit_limple_call_ref arg convention --- src/comp.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6552ea91c14..3a9fbe733da 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1097,7 +1097,8 @@ emit_limple_call (Lisp_Object args) { Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); - Lisp_Object emitter = Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); + Lisp_Object emitter = + Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); if (!NILP (emitter)) { @@ -1117,13 +1118,13 @@ emit_limple_call (Lisp_Object args) } static gcc_jit_rvalue * -emit_limple_call_ref (Lisp_Object arg1) +emit_limple_call_ref (Lisp_Object args) { /* Ex: (callref Fplus 2 0). */ - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); - EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + EMACS_UINT nargs = XFIXNUM (SECOND (args)); + EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); gcc_jit_rvalue *gcc_args[2] = { gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1285,7 +1286,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) - res = emit_limple_call_ref (arg1); + res = emit_limple_call_ref (XCDR (arg1)); else error ("LIMPLE inconsistent arg1 for op ="); eassert (res); From df59970cc41cee834f2432a18a098ec7de16f7ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Aug 2019 22:13:45 +0200 Subject: [PATCH 0241/1452] improve routine dispatcher --- src/comp.c | 122 ++++++++++++++++++++++++++++------------------------- 1 file changed, 65 insertions(+), 57 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3a9fbe733da..37264039edf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -152,6 +152,20 @@ static comp_t comp; FILE *logfile = NULL; + + +Lisp_Object helper_save_window_excursion (Lisp_Object v1); + +void helper_unwind_protect (Lisp_Object handler); + +Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); + +Lisp_Object helper_unbind_n (int val); + +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, + enum pvec_type code); + + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) { @@ -234,10 +248,9 @@ declare_block (const char * block_name) } static void -register_dispatch (const char *name, void *func) +register_dispatch (Lisp_Object key, void *func) { - Lisp_Object key = make_string (name, strlen (name)); - Lisp_Object value = make_pointer_integer (XPL (func)); + Lisp_Object value = make_mint_ptr (func); Fputhash (key, value, comp.routine_dispatcher); } @@ -1098,11 +1111,11 @@ emit_limple_call (Lisp_Object args) Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); Lisp_Object emitter = - Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); + Fgethash (calle_sym, comp.routine_dispatcher, Qnil); if (!NILP (emitter)) { - gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = XFIXNUMPTR (emitter); + gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); return emitter_ptr (args); } else if (calle[0] == 'F') @@ -2045,6 +2058,14 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qnil; } + if (NILP (comp.routine_dispatcher)) + { + /* Move this into syms_of_comp the day will be dumpable. */ + comp.routine_dispatcher = CALLN (Fmake_hash_table); + register_dispatch (Qset_internal, emit_set_internal); + register_dispatch (Qhelper_unbind_n, helper_unbind_n); + } + comp.ctxt = gcc_jit_context_acquire(); comp.funcs = Qnil; @@ -2349,64 +2370,12 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, return Qt; } -void -syms_of_comp (void) -{ - /* Limple instruction set. */ - DEFSYM (Qcomment, "comment"); - DEFSYM (Qjump, "jump"); - DEFSYM (Qcall, "call"); - DEFSYM (Qcallref, "callref"); - DEFSYM (Qncall, "ncall"); - DEFSYM (Qsetpar, "setpar"); - DEFSYM (Qncall_prolog, "ncall-prolog"); - DEFSYM (Qsetimm, "setimm"); - DEFSYM (Qreturn, "return"); - DEFSYM (Qcomp_mvar, "comp-mvar"); - DEFSYM (Qcond_jump, "cond-jump"); - DEFSYM (Qpush_handler, "push-handler"); - DEFSYM (Qpop_handler, "pop-handler"); - DEFSYM (Qcondition_case, "condition-case"); - DEFSYM (Qcatcher, "catcher"); - - defsubr (&Scomp_init_ctxt); - defsubr (&Scomp_release_ctxt); - defsubr (&Scomp_add_func_to_ctxt); - defsubr (&Scomp_compile_and_load_ctxt); - comp.func_hash = Qnil; - comp.routine_dispatcher = Qnil; - staticpro (&comp.func_hash); - staticpro (&comp.func_blocks); - - comp.routine_dispatcher = CALLN (Fmake_hash_table, QCtest, Qequal); - register_dispatch ("set_internal", emit_set_internal); - register_dispatch ("helper_unbind_n", emit_simple_limple_call); - staticpro (&comp.routine_dispatcher); - - DEFVAR_INT ("comp-speed", comp_speed, - doc: /* From 0 to 3. */); - comp_speed = DEFAULT_SPEED; - -} - /******************************************************************************/ /* Helper functions called from the runtime. */ /* These can't be statics till shared mechanism is used to solve relocations. */ /******************************************************************************/ -/* TODO: cleanup */ - -Lisp_Object helper_save_window_excursion (Lisp_Object v1); - -void helper_unwind_protect (Lisp_Object handler); - -Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); - -Lisp_Object helper_unbind_n (int val); - -bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, - enum pvec_type code); Lisp_Object helper_save_window_excursion (Lisp_Object v1) { @@ -2448,4 +2417,43 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, code); } +void +syms_of_comp (void) +{ + /* Limple instruction set. */ + DEFSYM (Qcomment, "comment"); + DEFSYM (Qjump, "jump"); + DEFSYM (Qcall, "call"); + DEFSYM (Qcallref, "callref"); + DEFSYM (Qncall, "ncall"); + DEFSYM (Qsetpar, "setpar"); + DEFSYM (Qncall_prolog, "ncall-prolog"); + DEFSYM (Qsetimm, "setimm"); + DEFSYM (Qreturn, "return"); + DEFSYM (Qcomp_mvar, "comp-mvar"); + DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qcondition_case, "condition-case"); + DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qset_internal, "set_internal"); + DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); + + defsubr (&Scomp_init_ctxt); + defsubr (&Scomp_release_ctxt); + defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_and_load_ctxt); + staticpro (&comp.func_hash); + staticpro (&comp.func_blocks); + comp.func_hash = Qnil; + comp.routine_dispatcher = Qnil; + + staticpro (&comp.routine_dispatcher); + comp.routine_dispatcher = Qnil; + + DEFVAR_INT ("comp-speed", comp_speed, + doc: /* From 0 to 3. */); + comp_speed = DEFAULT_SPEED; +} + #endif /* HAVE_LIBGCCJIT */ From 9273afa89034783aa26d4f5bb43cf22afce57e74 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Aug 2019 22:38:03 +0200 Subject: [PATCH 0242/1452] save C pointers as mint_ptr type to avoid corruption --- src/comp.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 37264039edf..d7326ad7035 100644 --- a/src/comp.c +++ b/src/comp.c @@ -233,7 +233,7 @@ retrive_block (Lisp_Object symbol) if (NILP (value)) error ("LIMPLE basic block inconsistency"); - return (gcc_jit_block *) XFIXNUMPTR (value); + return (gcc_jit_block *) xmint_pointer (value); } static void @@ -241,7 +241,7 @@ declare_block (const char * block_name) { gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); Lisp_Object key = make_string (block_name, strlen (block_name)); - Lisp_Object value = make_pointer_integer (XPL (block)); + Lisp_Object value = make_mint_ptr (block); if (!NILP (Fgethash (key, comp.func_blocks, Qnil))) error ("LIMPLE basic block inconsistency"); Fputhash (key, value, comp.func_blocks); @@ -302,10 +302,10 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, if (reusable) { Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = make_pointer_integer (XPL (func)); + Lisp_Object value = make_mint_ptr (func); /* Don't want to declare the same function two times. */ - if (!NILP (Fgethash (key, comp.func_hash, Qnil))) - eassert (false); + eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); + Fputhash (key, value, comp.func_hash); } @@ -326,7 +326,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, value = Fgethash (key, comp.func_hash, Qnil); eassert (!NILP (value)); } - gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); + gcc_jit_function *func = (gcc_jit_function *) xmint_pointer (value); return gcc_jit_context_new_call(comp.ctxt, NULL, From b9c228438d34b15ae2804a563d4d52b5e0de62ad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Aug 2019 23:20:40 +0200 Subject: [PATCH 0243/1452] block hash use symbol as key --- src/comp.c | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index d7326ad7035..08fa384654c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -225,11 +225,9 @@ type_to_cast_field (gcc_jit_type *type) } static gcc_jit_block * -retrive_block (Lisp_Object symbol) +retrive_block (Lisp_Object block_name) { - char *block_name = (char *) SDATA (SYMBOL_NAME (symbol)); - Lisp_Object key = make_string (block_name, strlen (block_name)); - Lisp_Object value = Fgethash (key, comp.func_blocks, Qnil); + Lisp_Object value = Fgethash (block_name, comp.func_blocks, Qnil); if (NILP (value)) error ("LIMPLE basic block inconsistency"); @@ -237,14 +235,14 @@ retrive_block (Lisp_Object symbol) } static void -declare_block (const char * block_name) +declare_block (Lisp_Object block_name) { - gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); - Lisp_Object key = make_string (block_name, strlen (block_name)); + char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); + gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - if (!NILP (Fgethash (key, comp.func_blocks, Qnil))) + if (!NILP (Fgethash (block_name, comp.func_blocks, Qnil))) error ("LIMPLE basic block inconsistency"); - Fputhash (key, value, comp.func_blocks); + Fputhash (block_name, value, comp.func_blocks); } static void @@ -2279,19 +2277,19 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, i)); comp.frame = frame; - comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal); + comp.func_blocks = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ - declare_block ("entry"); + declare_block (Qentry); Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); - Lisp_Object entry_block = Fgethash (intern ("entry"), blocks, Qnil); + Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); for (ptrdiff_t i = 0; i < ht->count; i++) { Lisp_Object block = HASH_VALUE (ht, i); if (!EQ (block, entry_block)) - declare_block ((char *) SDATA (SYMBOL_NAME (HASH_KEY (ht, i)))); + declare_block (HASH_KEY (ht, i)); } for (ptrdiff_t i = 0; i < ht->count; i++) @@ -2436,6 +2434,7 @@ syms_of_comp (void) DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); From e65d2f364cf40891d15009e9764143a45c2d164c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 09:18:45 +0200 Subject: [PATCH 0244/1452] some renaming --- src/comp.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 08fa384654c..347a3b351e1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -145,7 +145,7 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ Lisp_Object funcs; /* List of functions defined. */ - Lisp_Object routine_dispatcher; + Lisp_Object emitter_dispatcher; } comp_t; static comp_t comp; @@ -249,7 +249,7 @@ static void register_dispatch (Lisp_Object key, void *func) { Lisp_Object value = make_mint_ptr (func); - Fputhash (key, value, comp.routine_dispatcher); + Fputhash (key, value, comp.emitter_dispatcher); } @@ -1109,7 +1109,7 @@ emit_limple_call (Lisp_Object args) Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); Lisp_Object emitter = - Fgethash (calle_sym, comp.routine_dispatcher, Qnil); + Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { @@ -2056,10 +2056,10 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qnil; } - if (NILP (comp.routine_dispatcher)) + if (NILP (comp.emitter_dispatcher)) { /* Move this into syms_of_comp the day will be dumpable. */ - comp.routine_dispatcher = CALLN (Fmake_hash_table); + comp.emitter_dispatcher = CALLN (Fmake_hash_table); register_dispatch (Qset_internal, emit_set_internal); register_dispatch (Qhelper_unbind_n, helper_unbind_n); } @@ -2172,7 +2172,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, sizeof (void *), false); - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); + if (NILP (comp.func_hash)) + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); /* Define data structures. */ @@ -2442,13 +2443,12 @@ syms_of_comp (void) defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); defsubr (&Scomp_compile_and_load_ctxt); - staticpro (&comp.func_hash); - staticpro (&comp.func_blocks); - comp.func_hash = Qnil; - comp.routine_dispatcher = Qnil; - staticpro (&comp.routine_dispatcher); - comp.routine_dispatcher = Qnil; + staticpro (&comp.func_hash); + comp.func_hash = Qnil; + staticpro (&comp.func_blocks); + staticpro (&comp.emitter_dispatcher); + comp.emitter_dispatcher = Qnil; DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); From 9901f47ef77e777ebe0183624024527ce691256d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 09:34:30 +0200 Subject: [PATCH 0245/1452] some fixes to unbind_n --- lisp/emacs-lisp/comp.el | 5 ++--- src/comp.c | 13 ++++++------- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7fa723fc88b..04668b3ed50 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -500,9 +500,8 @@ the annotation emission." (comp-stack-adjust (- arg)) (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) (byte-unbind - (comp-emit `(call unbind_to - ,(make-comp-mvar :constant arg) - ,(make-comp-mvar :constant nil)))) + (comp-emit `(call helper_unbind_n + ,(make-comp-mvar :constant arg)))) (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase diff --git a/src/comp.c b/src/comp.c index 347a3b351e1..e101666cb6b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -160,7 +160,7 @@ void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); -Lisp_Object helper_unbind_n (int val); +Lisp_Object helper_unbind_n (Lisp_Object n); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); @@ -1101,15 +1101,14 @@ emit_simple_limple_call (Lisp_Object args) return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); } -/* Entry point to dispatch emission of (call fun ...). */ +/* Entry point to dispatch emitting (call fun ...). */ static gcc_jit_rvalue * emit_limple_call (Lisp_Object args) { Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); - Lisp_Object emitter = - Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); + Lisp_Object emitter = Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { @@ -2061,7 +2060,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, /* Move this into syms_of_comp the day will be dumpable. */ comp.emitter_dispatcher = CALLN (Fmake_hash_table); register_dispatch (Qset_internal, emit_set_internal); - register_dispatch (Qhelper_unbind_n, helper_unbind_n); + register_dispatch (Qhelper_unbind_n, emit_simple_limple_call); } comp.ctxt = gcc_jit_context_acquire(); @@ -2402,9 +2401,9 @@ helper_temp_output_buffer_setup (Lisp_Object x) } Lisp_Object -helper_unbind_n (int val) +helper_unbind_n (Lisp_Object n) { - return unbind_to (SPECPDL_INDEX () - val, Qnil); + return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil); } bool From 5dda07d22c8d974b31e196a802414c267fac5cc9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 10:14:57 +0200 Subject: [PATCH 0246/1452] dipatcher support for helper_unwind_protect record_unwind_current_buffer --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 48 ++++++++++++++++++++++++++--------------- 2 files changed, 32 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 04668b3ed50..79f987bd4c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -613,7 +613,7 @@ the annotation emission." (byte-save-restriction) (byte-catch) (byte-unwind-protect - (comp-emit '(call helper_unwind_protect))) + (comp-emit `(call helper_unwind_protect ,(comp-slot-next)))) (byte-condition-case) (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) diff --git a/src/comp.c b/src/comp.c index e101666cb6b..42186e7ea5d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -246,7 +246,7 @@ declare_block (Lisp_Object block_name) } static void -register_dispatch (Lisp_Object key, void *func) +register_emitter (Lisp_Object key, void *func) { Lisp_Object value = make_mint_ptr (func); Fputhash (key, value, comp.emitter_dispatcher); @@ -1082,14 +1082,8 @@ emit_limple_ncall_prolog (EMACS_UINT n) /* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * -emit_simple_limple_call (Lisp_Object args) +emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { - /* - Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil)) - */ int i = 0; char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); args = XCDR (args); @@ -1098,7 +1092,25 @@ emit_simple_limple_call (Lisp_Object args) FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + return emit_call (calle, ret_type, nargs, gcc_args); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_lisp_ret (Lisp_Object args) +{ + /* + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) + + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) + */ + return emit_simple_limple_call (args, comp.lisp_obj_type); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_void_ret (Lisp_Object args) +{ + return emit_simple_limple_call (args, comp.void_type); } /* Entry point to dispatch emitting (call fun ...). */ @@ -1117,13 +1129,9 @@ emit_limple_call (Lisp_Object args) } else if (calle[0] == 'F') { - return emit_simple_limple_call (args); - } - else if (!strcmp (calle, "record_unwind_current_buffer") || - !strcmp (calle, "helper_unwind_protect")) - { - return emit_call (calle, comp.void_type, 0, NULL); + return emit_simple_limple_call_lisp_ret (args); } + error ("LIMPLE call is inconsistent"); } @@ -2059,8 +2067,12 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, { /* Move this into syms_of_comp the day will be dumpable. */ comp.emitter_dispatcher = CALLN (Fmake_hash_table); - register_dispatch (Qset_internal, emit_set_internal); - register_dispatch (Qhelper_unbind_n, emit_simple_limple_call); + register_emitter (Qset_internal, emit_set_internal); + register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret); + register_emitter (Qhelper_unwind_protect, + emit_simple_limple_call_void_ret); + register_emitter (Qrecord_unwind_current_buffer, + emit_simple_limple_call_lisp_ret); } comp.ctxt = gcc_jit_context_acquire(); @@ -2436,7 +2448,9 @@ syms_of_comp (void) DEFSYM (Qcatcher, "catcher"); DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); + DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); + DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From f63e1740edac418c2ab88d72e1ee56cecfec038a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 10:15:46 +0200 Subject: [PATCH 0247/1452] fix bug for not blanking func_hash after context release --- src/comp.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 42186e7ea5d..7f1219780cc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2183,8 +2183,11 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, sizeof (void *), false); - if (NILP (comp.func_hash)) - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); + /* + Always reinitialize this cause old function definitions are garbage collected + by libgccjit when the ctxt is released. + */ + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); /* Define data structures. */ From 5992502ca42263855e327239eeb7f51b59a2703d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 10:19:51 +0200 Subject: [PATCH 0248/1452] add a test about buffer manipulation --- test/src/comp-tests.el | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e959e265228..1f15a0bd8bd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -453,6 +453,14 @@ (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) +(ert-deftest comp-tests-buffer () + (defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) + + (should (string= (comp-test-apply #'comp-tests-buff0-f) "foo"))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 3e18100038a0514b1ea6bee01a141f1477fdfbf6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 11:59:31 +0200 Subject: [PATCH 0249/1452] implement log-buffer --- lisp/emacs-lisp/comp.el | 50 +++++++++++++++++++++++++++++++---------- 1 file changed, 38 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 79f987bd4c8..29d1625009f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -35,7 +35,13 @@ "Emacs Lisp native compiler." :group 'lisp) -(defconst comp-debug t) +(defcustom comp-debug t + "Log compilation process." + :type 'boolean + :group 'comp) + +(defconst native-compile-log-buffer "*Native-compile-Log*" + "Name of the native-compiler's log buffer.") ;; FIXME these has to be removed (defvar comp-speed 2) @@ -137,14 +143,35 @@ LIMPLE basic block.") (block-name nil :type 'symbol :documentation "Current basic block name.")) -(defun comp-pretty-print-func (func) - "Pretty print function FUNC in the current buffer." - (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (progn - (insert (concat "\n<" (symbol-name block-name) ">")) - (cl-prettyprint (comp-block-insns bb))))) +(defmacro comp-within-log-buff (&rest body) + "Execute BODY while at the end the log-buffer. +BODY is evaluate only if `comp-debug' is non nil." + (declare (debug (form body)) + (indent defun)) + `(when comp-debug + (with-current-buffer (get-buffer-create native-compile-log-buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + ,@body)))) + +(defun comp-log (string) + "Log a STRING into the log-buffer." + (comp-within-log-buff + (cond (noninteractive + (message " %s" string)) + (t + (insert (format "%s\n" string)))))) + +(defun comp-log-func (func) + "Pretty print function FUNC in the log-buffer." + (comp-within-log-buff + (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (progn + (insert (concat "\n<" (symbol-name block-name) ">")) + (cl-prettyprint (comp-block-insns bb)))))) ;;; spill-lap pass specific code. @@ -184,7 +211,7 @@ LIMPLE basic block.") (let (byte-compile-lap-output) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (when comp-debug + (comp-within-log-buff (cl-prettyprint byte-compile-lap-output)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (if (fixnump lambda-list) @@ -689,8 +716,7 @@ the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (reverse (comp-block-insns bb)))) - (when comp-debug - (comp-pretty-print-func func)) + (comp-log-func func) func)) From 128cc4a2f401e96936e9e5791e65fbdc35ace6b2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 12:24:15 +0200 Subject: [PATCH 0250/1452] add record_unwind_protect_excursion support --- lisp/emacs-lisp/comp.el | 3 ++- src/comp.c | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 29d1625009f..6fa098e0eb4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -635,7 +635,8 @@ the annotation emission." (byte-discard 'pass) (byte-dup (comp-copy-slot (1- (comp-sp)))) - (byte-save-excursion) + (byte-save-excursion + (comp-emit '(call record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction) (byte-catch) diff --git a/src/comp.c b/src/comp.c index 7f1219780cc..90fa5ccdfa3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2073,6 +2073,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (Qrecord_unwind_current_buffer, emit_simple_limple_call_lisp_ret); + register_emitter (Qrecord_unwind_protect_excursion, + emit_simple_limple_call_void_ret); } comp.ctxt = gcc_jit_context_acquire(); @@ -2452,6 +2454,7 @@ syms_of_comp (void) DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); + DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); From bdadeff503d1796758a498dee218751520bb0cf8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 12:37:21 +0200 Subject: [PATCH 0251/1452] add narrow-to-region + widen support --- lisp/emacs-lisp/comp.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6fa098e0eb4..357085ee479 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -611,8 +611,12 @@ the annotation emission." (byte-char-syntax auto) (byte-buffer-substring auto) (byte-delete-region auto) - (byte-narrow-to-region) - (byte-widen) + (byte-narrow-to-region + (comp-emit-set-call `(call Fnarrow_to_region + ,(comp-slot) + ,(comp-slot-next)))) + (byte-widen + (comp-emit-set-call '(call Fwiden))) (byte-end-of-line auto) (byte-constant2) (byte-goto From 7dc99d5d51fcadafcd7e38f169ef8b353db61e81 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 14:10:57 +0200 Subject: [PATCH 0252/1452] add save-restriction support --- lisp/emacs-lisp/comp.el | 9 +++++---- src/comp.c | 18 +++++++++++++++++- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 357085ee479..3789a517740 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -642,14 +642,15 @@ the annotation emission." (byte-save-excursion (comp-emit '(call record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) - (byte-save-restriction) - (byte-catch) + (byte-save-restriction + '(call helper-save-restriction)) + (byte-catch) ;; Obsolete (byte-unwind-protect (comp-emit `(call helper_unwind_protect ,(comp-slot-next)))) - (byte-condition-case) + (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) - (byte-unbind-all) + (byte-unbind-all) ;; Obsolete (byte-set-marker auto) (byte-match-beginning auto) (byte-match-end auto) diff --git a/src/comp.c b/src/comp.c index 90fa5ccdfa3..a4793a36ada 100644 --- a/src/comp.c +++ b/src/comp.c @@ -165,6 +165,8 @@ Lisp_Object helper_unbind_n (Lisp_Object n); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); +void helper_emit_save_restriction (void); + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) @@ -2075,6 +2077,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_lisp_ret); register_emitter (Qrecord_unwind_protect_excursion, emit_simple_limple_call_void_ret); + register_emitter (Qhelper_save_restriction, + emit_simple_limple_call_void_ret); } comp.ctxt = gcc_jit_context_acquire(); @@ -2389,6 +2393,8 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, /******************************************************************************/ /* Helper functions called from the runtime. */ /* These can't be statics till shared mechanism is used to solve relocations. */ +/* Note: this are all potentially definable directly to gcc and are here just */ +/* for lazyness. Change this if a performance impact is measured. */ /******************************************************************************/ Lisp_Object @@ -2402,7 +2408,8 @@ helper_save_window_excursion (Lisp_Object v1) return v1; } -void helper_unwind_protect (Lisp_Object handler) +void +helper_unwind_protect (Lisp_Object handler) { /* Support for a function here is new in 24.4. */ record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, @@ -2432,6 +2439,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, code); } +void +helper_emit_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + + void syms_of_comp (void) { @@ -2457,6 +2472,7 @@ syms_of_comp (void) DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); + DEFSYM (Qhelper_save_restriction, "helper_save_restriction") defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From bb8f8f5cfa0f66729c6c6a333bee5bd4ba16c24c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 14:41:35 +0200 Subject: [PATCH 0253/1452] mark todos --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3789a517740..9bf60d1f3cb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -519,7 +519,7 @@ the annotation emission." (comp-emit `(call set_internal ,(make-comp-mvar :constant arg) ,(comp-slot)))) - (byte-varbind + (byte-varbind ;; Verify (comp-emit `(call specbind ,(make-comp-mvar :constant arg) ,(comp-slot-next)))) @@ -618,7 +618,7 @@ the annotation emission." (byte-widen (comp-emit-set-call '(call Fwiden))) (byte-end-of-line auto) - (byte-constant2) + (byte-constant2) ;; TODO (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil @@ -685,7 +685,7 @@ the annotation emission." (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) - (byte-stack-set2) + (byte-stack-set2) ;; TODO (byte-discardN (comp-stack-adjust (- arg))) (byte-switch From b6e7df0926b1a569a582b0d3ff0da0c27ad368bd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 14:54:13 +0200 Subject: [PATCH 0254/1452] rework args structures --- lisp/emacs-lisp/comp.el | 29 +++++++++++++++++------------ src/comp.c | 7 +++---- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9bf60d1f3cb..a35fbd0fec5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -76,15 +76,20 @@ finally return h) "Hash table lap-op -> stack adjustment.")) -(cl-defstruct comp-args +(cl-defstruct comp-args-gen (min nil :type number - :documentation "Minimum number of arguments allowed.") - (max nil + :documentation "Minimum number of arguments allowed.")) + +(cl-defstruct (comp-args (:include comp-args-gen)) + (max nil :type number :documentation "Maximum number of arguments allowed. -To be used when ncall-conv is nil.") - (ncall-conv nil :type boolean - :documentation "If t the signature is: -(ptrdiff_t nargs, Lisp_Object *args).")) +To be used when ncall-conv is nil.")) + +(cl-defstruct (comp-nargs (:include comp-args-gen)) + "Describe args when the functin signature is of kind: +(ptrdiff_t nargs, Lisp_Object *args)." + (nonrest nil :type number + :documentation "Number of non rest arguments.")) (cl-defstruct (comp-block (:copier nil)) "A basic block." @@ -109,7 +114,7 @@ into it.") :documentation "Byte compiled version.") (lap () :type list :documentation "Lap assembly representation.") - (args nil :type 'comp-args) + (args nil :type 'comp-args-gen) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -203,8 +208,8 @@ BODY is evaluate only if `comp-debug' is non nil." (< nonrest 9)) ;; SUBR_MAX_ARGS (make-comp-args :min mandatory :max nonrest) - (make-comp-args :min mandatory - :ncall-conv t)))) + (make-comp-nargs :min mandatory + :nonrest nonrest)))) (defun comp-spill-lap (func) "Byte compile and spill the LAP rapresentation for FUNC." @@ -703,13 +708,13 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) - (args-min (comp-args-min (comp-func-args func))) + (args-min (comp-args-gen-min (comp-func-args func))) (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (if (not (comp-args-ncall-conv (comp-func-args func))) + (if (comp-args-p (comp-func-args func)) (cl-loop for i below (comp-args-max (comp-func-args func)) do (cl-incf (comp-sp)) do (comp-emit `(setpar ,(comp-slot) ,i))) diff --git a/src/comp.c b/src/comp.c index a4793a36ada..881a78b3d75 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2247,8 +2247,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); - /* EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); */ - bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); + bool ncall = (FUNCALL1 (comp-nargs-p, args)); if (!ncall) { @@ -2373,8 +2372,8 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - if (NILP (FUNCALL1 (comp-args-ncall-conv, args))) + x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-gen-min, args)); + if (FUNCALL1 (comp-args-p, args)) x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); else x->s.max_args = MANY; From 0c33a8ff4bd20fcb5f2d4d2a27907c77804f4e42 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 15:04:38 +0200 Subject: [PATCH 0255/1452] fix &optional args --- lisp/emacs-lisp/comp.el | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a35fbd0fec5..3ce35983828 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -708,18 +708,20 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) - (args-min (comp-args-gen-min (comp-func-args func))) + (args (comp-func-args func)) + (args-min (comp-args-gen-min args)) (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (if (comp-args-p (comp-func-args func)) - (cl-loop for i below (comp-args-max (comp-func-args func)) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) do (comp-emit `(setpar ,(comp-slot) ,i))) - (comp-emit `(ncall-prolog ,args-min)) - (cl-incf (comp-sp) (1+ args-min))) + (let ((nonrest (comp-nargs-nonrest args))) + (comp-emit `(ncall-prolog ,nonrest)) + (cl-incf (comp-sp) (1+ nonrest)))) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) From 29e17e08b395db8e08e4c91a543750f8021376e8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 16:44:12 +0200 Subject: [PATCH 0256/1452] add comp-emit-narg-prologue --- lisp/emacs-lisp/comp.el | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ce35983828..0a8ab551ebf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -701,6 +701,29 @@ the annotation emission." (comp-stack-adjust (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) +(defun comp-emit-narg-prologue (args-min non-rest) + "Emit the prologue for a narg function." + (cl-loop for i below args-min + do (progn + (comp-emit `(set-args-to-local ,i)) + (comp-emit '(inc-args)))) + (cl-loop for i from args-min below non-rest + for bb = (intern (format "entry_%s" i)) + for fallback = (intern (format "entry_fallback_%s" i)) + do (progn + (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + (comp-mark-block-closed) + (comp-emit-block bb) + (comp-emit `(set-args-to-local ,i)) + (comp-emit '(inc-args))) + finally (comp-emit-jump 'entry_rest_args)) + (cl-loop for i from args-min below non-rest + do (comp-with-sp i + (comp-emit-block (intern (format "entry_fallback_%s" i))) + (comp-emit-set-const nil))) + (comp-emit-block 'entry_rest_args) + (comp-emit `(set-rest-args-to-local ,non-rest))) + (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) @@ -720,7 +743,7 @@ the annotation emission." do (cl-incf (comp-sp)) do (comp-emit `(setpar ,(comp-slot) ,i))) (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit `(ncall-prolog ,nonrest)) + (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body (comp-emit-block 'bb_1) From 74635dafacb9ebb640a4a69108dabdd897c2498f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 17:21:23 +0200 Subject: [PATCH 0257/1452] C support for new prologue mechanism --- src/comp.c | 171 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 97 insertions(+), 74 deletions(-) diff --git a/src/comp.c b/src/comp.c index 881a78b3d75..acc727c772f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1013,74 +1013,6 @@ emit_set_internal (Lisp_Object args) return emit_call ("set_internal", comp.void_type , 4, gcc_args); } -static void -emit_limple_ncall_prolog (EMACS_UINT n) -{ - /* - nargs will be known at runtime therfore we emit: - - prologue: - local[0] = *args; - ++args; - . - . - . - local[min_args - 1] = *args; - ++args; - local[min_args] = list (nargs - min_args, args); - bb_1: - . - . - . - */ - gcc_jit_lvalue *nargs = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_lvalue *args = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_rvalue *min_args = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - n); - - for (ptrdiff_t i = 0; i < n; ++i) - { - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[i], - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference ( - gcc_jit_lvalue_as_rvalue (args), - NULL))); - - gcc_jit_block_add_assignment (comp.block, - NULL, - args, - emit_ptr_arithmetic ( - gcc_jit_lvalue_as_rvalue (args), - comp.lisp_obj_ptr_type, - sizeof (Lisp_Object), - comp.one)); - } - - /* - rest arguments - */ - gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - min_args), - gcc_jit_lvalue_as_rvalue (args) }; - - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[n], - emit_call ("Flist", comp.lisp_obj_type, 2, - list_args)); -} - /* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * @@ -1250,6 +1182,28 @@ emit_limple_insn (Lisp_Object insn) emit_cond_jump (emit_EQ (a, b), target2, target1); } + else if (EQ (op, Qcond_jump_narg_leq)) + { + /* + Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2) + C: if (nargs < 2) goto entry2_fallback; else goto entry_2; + */ + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (arg0)); + gcc_jit_block *target1 = retrive_block (SECOND (args)); + gcc_jit_block *target2 = retrive_block (THIRD (args)); + gcc_jit_rvalue *test = gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_lvalue_as_rvalue (nargs), + n); + emit_cond_jump (test, target2, target1); + } else if (EQ (op, Qpush_handler)) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1272,8 +1226,10 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qpop_handler)) { - /* current_thread->m_handlerlist = - current_thread->m_handlerlist->next; */ + /* + C: current_thread->m_handlerlist = + current_thread->m_handlerlist->next; + */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field (comp.current_thread, NULL, @@ -1328,10 +1284,74 @@ emit_limple_insn (Lisp_Object insn) comp.frame[slot_n], param); } - else if (EQ (op, Qncall_prolog)) + else if (EQ (op, Qset_args_to_local)) { - /* Ex: (ncall-prolog 2). */ - emit_limple_ncall_prolog (XFIXNUM (arg0)); + /* + Limple: (set-args-to-local 1) + C: local[1] = *args; + */ + gcc_jit_rvalue *gcc_args = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1))); + + gcc_jit_rvalue *res = + gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); + + EMACS_UINT slot_n = XFIXNUM (arg0); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); + } + else if (EQ (op, Qset_rest_args_to_local)) + { + /* + Limple: (set-rest-args-to-local 3) + C: local[3] = list (nargs - 3, args); + */ + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (arg0)); + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + n), + gcc_jit_lvalue_as_rvalue (args) }; + + res = emit_call ("Flist", comp.lisp_obj_type, 2, + list_args); + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[XFIXNUM (arg0)], + res); + } + else if (EQ (op, Qinc_args)) + { + /* + Limple: (inc-args) + C: ++args; + */ + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_block_add_assignment (comp.block, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); } else if (EQ (op, Qsetimm)) { @@ -2456,11 +2476,14 @@ syms_of_comp (void) DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qsetpar, "setpar"); - DEFSYM (Qncall_prolog, "ncall-prolog"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qset_args_to_local, "set-args-to-local"); + DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); + DEFSYM (Qinc_args, "inc-args"); + DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq"); DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); From b6288d1322ec476c156c165496d08e8f782bcb03 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 18:49:26 +0200 Subject: [PATCH 0258/1452] improve comp-tests-ffuncall --- test/src/comp-tests.el | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1f15a0bd8bd..e7b370c9321 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -159,12 +159,21 @@ (ert-deftest comp-tests-ffuncall () "Test calling conventions." - (native-compile #'comp-tests-ffuncall-calle-f) + (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; After it gets compiled + (native-compile #'comp-tests-ffuncall-callee-f) + (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; Recompiling the caller once with callee already compiled + (defun comp-tests-ffuncall-caller-f () + (comp-tests-ffuncall-callee-f 1 2 3)) + (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) From ab69bb63641d12f8a53a262f37908d8234935e13 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 19:03:06 +0200 Subject: [PATCH 0259/1452] some minors --- lisp/emacs-lisp/comp.el | 12 ++++++------ src/comp.c | 17 +++++++++-------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a8ab551ebf..98c6e866ad4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -287,7 +287,7 @@ Restore the original value afterwards." (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. -If the calle function is known to have a return type propagate it." +If the callee function is known to have a return type propagate it." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) @@ -701,13 +701,13 @@ the annotation emission." (comp-stack-adjust (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) -(defun comp-emit-narg-prologue (args-min non-rest) +(defun comp-emit-narg-prologue (minarg nonrest) "Emit the prologue for a narg function." - (cl-loop for i below args-min + (cl-loop for i below minarg do (progn (comp-emit `(set-args-to-local ,i)) (comp-emit '(inc-args)))) - (cl-loop for i from args-min below non-rest + (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) do (progn @@ -717,12 +717,12 @@ the annotation emission." (comp-emit `(set-args-to-local ,i)) (comp-emit '(inc-args))) finally (comp-emit-jump 'entry_rest_args)) - (cl-loop for i from args-min below non-rest + (cl-loop for i from minarg below nonrest do (comp-with-sp i (comp-emit-block (intern (format "entry_fallback_%s" i))) (comp-emit-set-const nil))) (comp-emit-block 'entry_rest_args) - (comp-emit `(set-rest-args-to-local ,non-rest))) + (comp-emit `(set-rest-args-to-local ,nonrest))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." diff --git a/src/comp.c b/src/comp.c index acc727c772f..f77a1740fe3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1019,14 +1019,14 @@ static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { int i = 0; - char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); args = XCDR (args); ptrdiff_t nargs = list_length (args); gcc_jit_rvalue *gcc_args[nargs]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - return emit_call (calle, ret_type, nargs, gcc_args); + return emit_call (callee, ret_type, nargs, gcc_args); } static gcc_jit_rvalue * @@ -1052,16 +1052,16 @@ emit_simple_limple_call_void_ret (Lisp_Object args) static gcc_jit_rvalue * emit_limple_call (Lisp_Object args) { - Lisp_Object calle_sym = FIRST (args); - char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); - Lisp_Object emitter = Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); + Lisp_Object callee_sym = FIRST (args); + char *callee = (char *) SDATA (SYMBOL_NAME (callee_sym)); + Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); return emitter_ptr (args); } - else if (calle[0] == 'F') + else if (callee[0] == 'F') { return emit_simple_limple_call_lisp_ret (args); } @@ -1074,7 +1074,7 @@ emit_limple_call_ref (Lisp_Object args) { /* Ex: (callref Fplus 2 0). */ - char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); EMACS_UINT nargs = XFIXNUM (SECOND (args)); EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); gcc_jit_rvalue *gcc_args[2] = @@ -1083,7 +1083,7 @@ emit_limple_call_ref (Lisp_Object args) nargs), gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; - return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); + return emit_call (callee, comp.lisp_obj_type, 2, gcc_args); } /* Register an handler for a non local exit. */ @@ -2487,6 +2487,7 @@ syms_of_comp (void) DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); + /* call operands. */ DEFSYM (Qcatcher, "catcher"); DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); From 757a95906805b1d7fcbe4b536841a7b53ce0c047 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 11 Aug 2019 19:08:18 +0200 Subject: [PATCH 0260/1452] some renaming --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98c6e866ad4..38511b74bdf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -741,7 +741,7 @@ the annotation emission." (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) - do (comp-emit `(setpar ,(comp-slot) ,i))) + do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) (let ((nonrest (comp-nargs-nonrest args))) (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) diff --git a/src/comp.c b/src/comp.c index f77a1740fe3..8a9d98fde51 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1271,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn) comp.frame[slot_n], res); } - else if (EQ (op, Qsetpar)) + else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -2475,15 +2475,17 @@ syms_of_comp (void) DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); - DEFSYM (Qsetpar, "setpar"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + /* Used during prologue emission. */ + DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); DEFSYM (Qinc_args, "inc-args"); DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq"); + /* Others. */ DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); From af51e6556daaa4e847209f79ac9dbc1a3ecc8836 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 17:43:58 +0200 Subject: [PATCH 0261/1452] inline add1 --- src/comp.c | 267 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 179 insertions(+), 88 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8a9d98fde51..95390c52638 100644 --- a/src/comp.c +++ b/src/comp.c @@ -136,6 +136,8 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; + gcc_jit_function *add1; + gcc_jit_function *sub1; gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *setcar; @@ -615,67 +617,67 @@ emit_CONSP (gcc_jit_rvalue *obj) /* args); */ /* } */ -/* static gcc_jit_rvalue * */ -/* emit_FIXNUMP (gcc_jit_rvalue *obj) */ -/* { */ -/* /\* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) */ -/* - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) */ -/* & ((1 << INTTYPEBITS) - 1))) *\/ */ -/* emit_comment ("FIXNUMP"); */ +static gcc_jit_rvalue * +emit_FIXNUMP (gcc_jit_rvalue *obj) +{ + /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + & ((1 << INTTYPEBITS) - 1))) */ + emit_comment ("FIXNUMP"); -/* gcc_jit_rvalue *sh_res = */ -/* gcc_jit_context_new_binary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_RSHIFT, */ -/* comp.emacs_int_type, */ -/* emit_XLI (obj), */ -/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ -/* comp.emacs_int_type, */ -/* (USE_LSB_TAG ? 0 : FIXNUM_BITS))); */ + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + (USE_LSB_TAG ? 0 : FIXNUM_BITS))); -/* gcc_jit_rvalue *minus_res = */ -/* gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_MINUS, */ -/* comp.unsigned_type, */ -/* emit_cast (comp.unsigned_type, sh_res), */ -/* gcc_jit_context_new_rvalue_from_int ( */ -/* comp.ctxt, */ -/* comp.unsigned_type, */ -/* (Lisp_Int0 >> !USE_LSB_TAG))); */ + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + emit_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); -/* gcc_jit_rvalue *res = */ -/* gcc_jit_context_new_unary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_UNARY_OP_LOGICAL_NEGATE, */ -/* comp.int_type, */ -/* gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_BITWISE_AND, */ -/* comp.unsigned_type, */ -/* minus_res, */ -/* gcc_jit_context_new_rvalue_from_int ( */ -/* comp.ctxt, */ -/* comp.unsigned_type, */ -/* ((1 << INTTYPEBITS) - 1)))); */ + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); -/* return res; */ -/* } */ + return res; +} -/* static gcc_jit_rvalue * */ -/* emit_XFIXNUM (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("XFIXNUM"); */ +static gcc_jit_rvalue * +emit_XFIXNUM (gcc_jit_rvalue *obj) +{ + emit_comment ("XFIXNUM"); -/* return gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_RSHIFT, */ -/* comp.emacs_int_type, */ -/* emit_XLI (obj), */ -/* comp.inttypebits); */ -/* } */ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + comp.inttypebits); +} /* static gcc_jit_rvalue * */ /* emit_INTEGERP (gcc_jit_rvalue *obj) */ @@ -705,38 +707,38 @@ emit_CONSP (gcc_jit_rvalue *obj) /* emit_FLOATP (obj))); */ /* } */ -/* static gcc_jit_rvalue * */ -/* emit_make_fixnum (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("make_fixnum"); */ +static gcc_jit_rvalue * +emit_make_fixnum (gcc_jit_rvalue *obj) +{ + emit_comment ("make_fixnum"); -/* gcc_jit_rvalue *tmp = */ -/* gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_LSHIFT, */ -/* comp.emacs_int_type, */ -/* obj, */ -/* comp.inttypebits); */ + gcc_jit_rvalue *tmp = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + obj, + comp.inttypebits); -/* tmp = gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_PLUS, */ -/* comp.emacs_int_type, */ -/* tmp, */ -/* comp.lisp_int0); */ + tmp = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + tmp, + comp.lisp_int0); -/* gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, */ -/* NULL, */ -/* comp.lisp_obj_type, */ -/* "lisp_obj_fixnum"); */ + gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj_fixnum"); -/* gcc_jit_block_add_assignment (comp.block, */ -/* NULL, */ -/* emit_lval_XLI (res), */ -/* tmp); */ + gcc_jit_block_add_assignment (comp.block, + NULL, + emit_lval_XLI (res), + tmp); -/* return gcc_jit_lvalue_as_rvalue (res); */ -/* } */ + return gcc_jit_lvalue_as_rvalue (res); +} /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * @@ -1376,6 +1378,18 @@ emit_limple_insn (Lisp_Object insn) } } + +/*******************************/ +/* Code emitters for inlines. */ +/*******************************/ + +static gcc_jit_rvalue * +emit_add1 (Lisp_Object insn) +{ + gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.add1, 1, &n); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -1774,8 +1788,7 @@ define_CHECK_TYPE (void) gcc_jit_block_end_with_void_return (not_ok_block, NULL); } - -/* Declare a substitute for CAR as always inlined function. */ +/* Define a substitute for CAR as always inlined function. */ static void define_CAR_CDR (void) @@ -1926,7 +1939,82 @@ define_setcar_setcdr (void) } } -/* Declare a substitute for PSEUDOVECTORP as always inlined function. */ +/* + Define a substitute for Fadd1 Fsub1. + Currently expose just fixnum arithmetic. +*/ + +static void +define_add1_sub1 (void) +{ + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n") }; + + comp.func = comp.add1 = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "add1", + 1, + param, + 0); + + DECL_BLOCK (init_block, comp.add1); + DECL_BLOCK (add1_inline_block, comp.add1); + DECL_BLOCK (add1_fcall_block, comp.add1); + + comp.block = init_block; + + /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + ? (XFIXNUM (n) + 1) + : Fadd1 (n)) */ + + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (n)), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + comp.most_positive_fixnum)), + add1_inline_block, + add1_fcall_block); + + comp.block = add1_inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + n_fixnum, + comp.one); + + gcc_jit_block_end_with_return (add1_inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = add1_fcall_block; + gcc_jit_rvalue *call_res = emit_call ("Fadd1", comp.lisp_obj_type, 1, &n); + gcc_jit_block_end_with_return (add1_fcall_block, + NULL, + call_res); + comp.block = bb_orig; +} + +/* Define a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) @@ -2029,7 +2117,7 @@ define_CHECK_IMPURE (void) gcc_jit_block_end_with_void_return (err_block, NULL); } -/* Declare a function to convert boolean into t or nil */ +/* Define a function to convert boolean into t or nil */ static void define_bool_to_lisp_obj (void) @@ -2099,6 +2187,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + register_emitter (QFadd1, emit_add1); } comp.ctxt = gcc_jit_context_acquire(); @@ -2239,7 +2328,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); - define_setcar_setcdr(); + define_setcar_setcdr (); + define_add1_sub1 (); return Qt; } @@ -2497,7 +2587,8 @@ syms_of_comp (void) DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); - DEFSYM (Qhelper_save_restriction, "helper_save_restriction") + DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + DEFSYM (QFadd1, "Fadd1") defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 643771818e36a8448744f061184cb3411b13291e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 18:29:36 +0200 Subject: [PATCH 0262/1452] inline sub1 --- src/comp.c | 129 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 74 insertions(+), 55 deletions(-) diff --git a/src/comp.c b/src/comp.c index 95390c52638..fa242a85e3b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1390,6 +1390,13 @@ emit_add1 (Lisp_Object insn) return gcc_jit_context_new_call (comp.ctxt, NULL, comp.add1, 1, &n); } +static gcc_jit_rvalue * +emit_sub1 (Lisp_Object insn) +{ + gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -1949,69 +1956,79 @@ define_add1_sub1 (void) { gcc_jit_block *bb_orig = comp.block; - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "n") }; + gcc_jit_function *func[2]; + char const *f_name[] = {"add1", "sub1"}; + char const *fall_back_func[] = {"Fadd1", "Fsub1"}; + gcc_jit_rvalue *compare[] = + { comp.most_positive_fixnum, comp.most_negative_fixnum }; + enum gcc_jit_binary_op op[] = + { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; + for (int i = 0; i < 2; i++) + { + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"); + comp.func = func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + f_name[i], + 1, + ¶m, + 0); + DECL_BLOCK (init_block, func[i]); + DECL_BLOCK (inline_block, func[i]); + DECL_BLOCK (fcall_block, func[i]); - comp.func = comp.add1 = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "add1", - 1, - param, - 0); + comp.block = init_block; - DECL_BLOCK (init_block, comp.add1); - DECL_BLOCK (add1_inline_block, comp.add1); - DECL_BLOCK (add1_fcall_block, comp.add1); + /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + ? (XFIXNUM (n) + 1) + : Fadd1 (n)) */ - comp.block = init_block; + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); - /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM - ? (XFIXNUM (n) + 1) - : Fadd1 (n)) */ - - gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); - gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + emit_cast (comp.bool_type, emit_FIXNUMP (n)), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - n_fixnum, - comp.most_positive_fixnum)), - add1_inline_block, - add1_fcall_block); + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + compare[i])), + inline_block, + fcall_block); - comp.block = add1_inline_block; - gcc_jit_rvalue *inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - n_fixnum, - comp.one); + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + op[i], + comp.emacs_int_type, + n_fixnum, + comp.one); - gcc_jit_block_end_with_return (add1_inline_block, - NULL, - emit_make_fixnum (inline_res)); + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); - comp.block = add1_fcall_block; - gcc_jit_rvalue *call_res = emit_call ("Fadd1", comp.lisp_obj_type, 1, &n); - gcc_jit_block_end_with_return (add1_fcall_block, - NULL, - call_res); + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call (fall_back_func[i], + comp.lisp_obj_type, 1, &n); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + } comp.block = bb_orig; + comp.add1 = func[0]; + comp.sub1 = func[1]; } /* Define a substitute for PSEUDOVECTORP as always inlined function. */ @@ -2188,6 +2205,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); register_emitter (QFadd1, emit_add1); + register_emitter (QFsub1, emit_sub1); } comp.ctxt = gcc_jit_context_acquire(); @@ -2588,7 +2606,8 @@ syms_of_comp (void) DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); - DEFSYM (QFadd1, "Fadd1") + DEFSYM (QFadd1, "Fadd1"); + DEFSYM (QFsub1, "Fsub1"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From b30bbf030bacdb0b66c0296d1368db7b4c07558c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 18:40:42 +0200 Subject: [PATCH 0263/1452] inline consp --- src/comp.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/comp.c b/src/comp.c index fa242a85e3b..fed777e9e0b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1397,6 +1397,18 @@ emit_sub1 (Lisp_Object insn) return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); } +static gcc_jit_rvalue * +emit_consp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_cast (comp.bool_type, + emit_CONSP (x)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2206,6 +2218,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (QFadd1, emit_add1); register_emitter (QFsub1, emit_sub1); + register_emitter (QFconsp, emit_consp); } comp.ctxt = gcc_jit_context_acquire(); @@ -2608,6 +2621,7 @@ syms_of_comp (void) DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); DEFSYM (QFadd1, "Fadd1"); DEFSYM (QFsub1, "Fsub1"); + DEFSYM (QFconsp, "Fconsp"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 92fc5baf17ccd0999f631d469708523de50ac06e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 18:49:36 +0200 Subject: [PATCH 0264/1452] inline car cdr --- src/comp.c | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/comp.c b/src/comp.c index fed777e9e0b..dd43ed40344 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1409,6 +1409,26 @@ emit_consp (Lisp_Object insn) 1, &res); } +static gcc_jit_rvalue * +emit_car (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.car, + 1, &x); +} + +static gcc_jit_rvalue * +emit_cdr (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cdr, + 1, &x); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2219,6 +2239,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFadd1, emit_add1); register_emitter (QFsub1, emit_sub1); register_emitter (QFconsp, emit_consp); + register_emitter (QFcar, emit_car); + register_emitter (QFcdr, emit_cdr); } comp.ctxt = gcc_jit_context_acquire(); @@ -2622,6 +2644,8 @@ syms_of_comp (void) DEFSYM (QFadd1, "Fadd1"); DEFSYM (QFsub1, "Fsub1"); DEFSYM (QFconsp, "Fconsp"); + DEFSYM (QFcar, "Fcar"); + DEFSYM (QFcdr, "Fcdr"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 4ed657604d669b4ba05a9280734c5f006939cdab Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 21:06:07 +0200 Subject: [PATCH 0265/1452] inline negate --- lisp/emacs-lisp/comp.el | 3 +- src/comp.c | 125 +++++++++++++++++++++++++++++++++++----- 2 files changed, 111 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 38511b74bdf..d2ead1f1649 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -582,7 +582,8 @@ the annotation emission." (byte-leq <= Fleq) (byte-geq >= Fgeq) (byte-diff - Fminus) - (byte-negate - Fminus) + (byte-negate + (comp-emit-set-call `(call negate ,(comp-slot)))) (byte-plus + Fplus) (byte-max auto) (byte-min auto) diff --git a/src/comp.c b/src/comp.c index dd43ed40344..6aa86e37a1c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -138,6 +138,7 @@ typedef struct { gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *add1; gcc_jit_function *sub1; + gcc_jit_function *negate; gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *setcar; @@ -337,6 +338,18 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, args); } +static gcc_jit_rvalue * +emit_call_n_ref (const char *f_name, unsigned nargs, + gcc_jit_lvalue *base_arg) +{ + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (base_arg, NULL) }; + return emit_call (f_name, comp.lisp_obj_type, 2, args); +} + /* Close current basic block emitting a conditional. */ INLINE static void @@ -1397,6 +1410,13 @@ emit_sub1 (Lisp_Object insn) return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); } +static gcc_jit_rvalue * +emit_negate (Lisp_Object insn) +{ + gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.negate, 1, &n); +} + static gcc_jit_rvalue * emit_consp (Lisp_Object insn) { @@ -1804,11 +1824,11 @@ define_CHECK_TYPE (void) gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); - DECL_BLOCK (init_block, comp.check_type); + DECL_BLOCK (entry_block, comp.check_type); DECL_BLOCK (ok_block, comp.check_type); DECL_BLOCK (not_ok_block, comp.check_type); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.check_type; emit_cond_jump (ok, ok_block, not_ok_block); @@ -1865,11 +1885,11 @@ define_CAR_CDR (void) for (int i = 0; i < 2; i++) { gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - DECL_BLOCK (init_block, f); + DECL_BLOCK (entry_block, f); DECL_BLOCK (is_cons_b, f); DECL_BLOCK (not_a_cons_b, f); - comp.block = init_block; + comp.block = entry_block; comp.func = f; emit_cond_jump (emit_CONSP (c), is_cons_b, not_a_cons_b); @@ -1942,9 +1962,9 @@ define_setcar_setcdr (void) 2, param, 0); - DECL_BLOCK (init_block, *f_ref); + DECL_BLOCK (entry_block, *f_ref); comp.func = *f_ref; - comp.block = init_block; + comp.block = entry_block; /* CHECK_CONS (cell); */ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); @@ -1955,7 +1975,7 @@ define_setcar_setcdr (void) emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; gcc_jit_block_add_eval ( - init_block, + entry_block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -1972,7 +1992,7 @@ define_setcar_setcdr (void) gcc_jit_param_as_rvalue (new_el)); /* return newel; */ - gcc_jit_block_end_with_return (init_block, + gcc_jit_block_end_with_return (entry_block, NULL, gcc_jit_param_as_rvalue (new_el)); } @@ -2009,11 +2029,11 @@ define_add1_sub1 (void) 1, ¶m, 0); - DECL_BLOCK (init_block, func[i]); + DECL_BLOCK (entry_block, func[i]); DECL_BLOCK (inline_block, func[i]); DECL_BLOCK (fcall_block, func[i]); - comp.block = init_block; + comp.block = entry_block; /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM ? (XFIXNUM (n) + 1) @@ -2063,6 +2083,76 @@ define_add1_sub1 (void) comp.sub1 = func[1]; } +static void +define_negate (void) +{ + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n") }; + + comp.func = comp.negate = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "negate", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.negate); + DECL_BLOCK (inline_block, comp.negate); + DECL_BLOCK (fcall_block, comp.negate); + + comp.block = entry_block; + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) + : Fminus (1, &TOP)) */ + + gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); + gcc_jit_rvalue *n_fixnum = + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + comp.most_negative_fixnum)), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_MINUS, + comp.emacs_int_type, + n_fixnum); + + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call_n_ref ("Fminus", 1, n); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + comp.block = bb_orig; +} + /* Define a substitute for PSEUDOVECTORP as always inlined function. */ static void @@ -2087,11 +2177,11 @@ define_PSEUDOVECTORP (void) param, 0); - DECL_BLOCK (init_block, comp.pseudovectorp); + DECL_BLOCK (entry_block, comp.pseudovectorp); DECL_BLOCK (ret_false_b, comp.pseudovectorp); DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.pseudovectorp; emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])), @@ -2141,11 +2231,11 @@ define_CHECK_IMPURE (void) param, 0); - DECL_BLOCK (init_block, comp.check_impure); + DECL_BLOCK (entry_block, comp.check_impure); DECL_BLOCK (err_block, comp.check_impure); DECL_BLOCK (ok_block, comp.check_impure); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.check_impure; emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ @@ -2184,10 +2274,10 @@ define_bool_to_lisp_obj (void) 1, ¶m, 0); - DECL_BLOCK (init_block, comp.bool_to_lisp_obj); + DECL_BLOCK (entry_block, comp.bool_to_lisp_obj); DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj); DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.bool_to_lisp_obj; emit_cond_jump (gcc_jit_param_as_rvalue (param), @@ -2241,6 +2331,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFconsp, emit_consp); register_emitter (QFcar, emit_car); register_emitter (QFcdr, emit_cdr); + register_emitter (Qnegate, emit_negate); } comp.ctxt = gcc_jit_context_acquire(); @@ -2383,6 +2474,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, define_bool_to_lisp_obj (); define_setcar_setcdr (); define_add1_sub1 (); + define_negate (); return Qt; } @@ -2646,6 +2738,7 @@ syms_of_comp (void) DEFSYM (QFconsp, "Fconsp"); DEFSYM (QFcar, "Fcar"); DEFSYM (QFcdr, "Fcdr"); + DEFSYM (Qnegate, "negate"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From b72d1c5b157214bc8feb4e6364ba624f9feae271 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 21:19:24 +0200 Subject: [PATCH 0266/1452] remove duplicate code --- src/comp.c | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6aa86e37a1c..4838160d40f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -339,7 +339,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_rvalue * -emit_call_n_ref (const char *f_name, unsigned nargs, +emit_call_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { gcc_jit_rvalue *args[] = @@ -1092,13 +1092,7 @@ emit_limple_call_ref (Lisp_Object args) char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); EMACS_UINT nargs = XFIXNUM (SECOND (args)); EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); - gcc_jit_rvalue *gcc_args[2] = - { gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; - - return emit_call (callee, comp.lisp_obj_type, 2, gcc_args); + return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } /* Register an handler for a non local exit. */ @@ -2146,7 +2140,7 @@ define_negate (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call_n_ref ("Fminus", 1, n); + gcc_jit_rvalue *call_res = emit_call_ref ("Fminus", 1, n); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); From ac036532599bdd49ab3bdd36437a06a12224a620 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 21:32:02 +0200 Subject: [PATCH 0267/1452] fix preceding-char --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d2ead1f1649..d7b4123a21c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -595,7 +595,7 @@ the annotation emission." (byte-point-min auto) (byte-char-after auto) (byte-following-char auto) - (byte-preceding-char auto) + (byte-preceding-char preceding-char Fprevious_char) (byte-current-column auto) (byte-indent-to auto) (byte-scan-buffer-OBSOLETE) From d73dd4c12c92db4419df1b96b1562c5c821bf877 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 21:56:35 +0200 Subject: [PATCH 0268/1452] inline numberp --- src/comp.c | 104 +++++++++++++++++++++++++++++------------------------ 1 file changed, 58 insertions(+), 46 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4838160d40f..ff0f5699c28 100644 --- a/src/comp.c +++ b/src/comp.c @@ -603,32 +603,32 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } -/* static gcc_jit_rvalue * */ -/* emit_FLOATP (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("FLOATP"); */ +static gcc_jit_rvalue * +emit_FLOATP (gcc_jit_rvalue *obj) +{ + emit_comment ("FLOATP"); -/* return emit_TAGGEDP (obj, Lisp_Float); */ -/* } */ + return emit_TAGGEDP (obj, Lisp_Float); +} -/* static gcc_jit_rvalue * */ -/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ -/* { */ -/* /\* PSEUDOVECTORP (x, PVEC_BIGNUM); *\/ */ -/* emit_comment ("BIGNUMP"); */ +static gcc_jit_rvalue * +emit_BIGNUMP (gcc_jit_rvalue *obj) +{ + /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ + emit_comment ("BIGNUMP"); -/* gcc_jit_rvalue *args[2] = { */ -/* obj, */ -/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ -/* comp.int_type, */ -/* PVEC_BIGNUM) }; */ + gcc_jit_rvalue *args[2] = { + obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; -/* return gcc_jit_context_new_call (comp.ctxt, */ -/* NULL, */ -/* comp.pseudovectorp, */ -/* 2, */ -/* args); */ -/* } */ + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} static gcc_jit_rvalue * emit_FIXNUMP (gcc_jit_rvalue *obj) @@ -692,33 +692,33 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) comp.inttypebits); } -/* static gcc_jit_rvalue * */ -/* emit_INTEGERP (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("INTEGERP"); */ +static gcc_jit_rvalue * +emit_INTEGERP (gcc_jit_rvalue *obj) +{ + emit_comment ("INTEGERP"); -/* return gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ -/* comp.bool_type, */ -/* emit_cast (comp.bool_type, */ -/* emit_FIXNUMP (obj)), */ -/* emit_BIGNUMP (obj)); */ -/* } */ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (obj)), + emit_BIGNUMP (obj)); +} -/* static gcc_jit_rvalue * */ -/* emit_NUMBERP (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("NUMBERP"); */ +static gcc_jit_rvalue * +emit_NUMBERP (gcc_jit_rvalue *obj) +{ + emit_comment ("NUMBERP"); -/* return gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ -/* comp.bool_type, */ -/* emit_INTEGERP(obj), */ -/* emit_cast (comp.bool_type, */ -/* emit_FLOATP (obj))); */ -/* } */ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP(obj), + emit_cast (comp.bool_type, + emit_FLOATP (obj))); +} static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_rvalue *obj) @@ -1443,6 +1443,15 @@ emit_cdr (Lisp_Object insn) 1, &x); } +static gcc_jit_rvalue * +emit_numperp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_NUMBERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2326,6 +2335,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFcar, emit_car); register_emitter (QFcdr, emit_cdr); register_emitter (Qnegate, emit_negate); + register_emitter (QFnumberp, emit_numperp); } comp.ctxt = gcc_jit_context_acquire(); @@ -2727,12 +2737,14 @@ syms_of_comp (void) DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + /* Inliners. */ DEFSYM (QFadd1, "Fadd1"); DEFSYM (QFsub1, "Fsub1"); DEFSYM (QFconsp, "Fconsp"); DEFSYM (QFcar, "Fcar"); DEFSYM (QFcdr, "Fcdr"); DEFSYM (Qnegate, "negate"); + DEFSYM (QFnumberp, "Fnumberp"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 916a87f0a9748b4c31f20496fff3223553f5226e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 22:01:34 +0200 Subject: [PATCH 0269/1452] inline integerp --- src/comp.c | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index ff0f5699c28..71dda173995 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1386,9 +1386,9 @@ emit_limple_insn (Lisp_Object insn) } -/*******************************/ -/* Code emitters for inlines. */ -/*******************************/ +/**************/ +/* Inliners. */ +/**************/ static gcc_jit_rvalue * emit_add1 (Lisp_Object insn) @@ -1452,6 +1452,15 @@ emit_numperp (Lisp_Object insn) &res); } +static gcc_jit_rvalue * +emit_integerp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_INTEGERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2329,6 +2338,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + /* Inliners. */ register_emitter (QFadd1, emit_add1); register_emitter (QFsub1, emit_sub1); register_emitter (QFconsp, emit_consp); @@ -2336,6 +2346,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFcdr, emit_cdr); register_emitter (Qnegate, emit_negate); register_emitter (QFnumberp, emit_numperp); + register_emitter (QFintegerp, emit_integerp); } comp.ctxt = gcc_jit_context_acquire(); @@ -2745,6 +2756,7 @@ syms_of_comp (void) DEFSYM (QFcdr, "Fcdr"); DEFSYM (Qnegate, "negate"); DEFSYM (QFnumberp, "Fnumberp"); + DEFSYM (QFintegerp, "Fintegerp"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); From 15e31a4a1fa359cfabda074903fce79f4982245b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 22:23:32 +0200 Subject: [PATCH 0270/1452] fix indent_to --- lisp/emacs-lisp/comp.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7b4123a21c..a95cd56eae4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -597,7 +597,10 @@ the annotation emission." (byte-following-char auto) (byte-preceding-char preceding-char Fprevious_char) (byte-current-column auto) - (byte-indent-to auto) + (byte-indent-to + (comp-emit-set-call `(call Findent_to + ,(comp-slot) + ,(make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) From fd6c673cfa76b30d3910963982e2c28ca208e827 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 22:45:30 +0200 Subject: [PATCH 0271/1452] inline setcar setcdr --- src/comp.c | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/comp.c b/src/comp.c index 71dda173995..6a576cfe110 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1443,6 +1443,30 @@ emit_cdr (Lisp_Object insn) 1, &x); } +static gcc_jit_rvalue * +emit_setcar (Lisp_Object insn) +{ + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)) }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcar, + 2, args); +} + +static gcc_jit_rvalue * +emit_setcdr (Lisp_Object insn) +{ + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)) }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcdr, + 2, args); +} + static gcc_jit_rvalue * emit_numperp (Lisp_Object insn) { @@ -2344,6 +2368,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFconsp, emit_consp); register_emitter (QFcar, emit_car); register_emitter (QFcdr, emit_cdr); + register_emitter (QFsetcar, emit_setcar); + register_emitter (QFsetcdr, emit_setcdr); register_emitter (Qnegate, emit_negate); register_emitter (QFnumberp, emit_numperp); register_emitter (QFintegerp, emit_integerp); @@ -2754,6 +2780,8 @@ syms_of_comp (void) DEFSYM (QFconsp, "Fconsp"); DEFSYM (QFcar, "Fcar"); DEFSYM (QFcdr, "Fcdr"); + DEFSYM (QFsetcar, "Fsetcar"); + DEFSYM (QFsetcdr, "Fsetcdr"); DEFSYM (Qnegate, "negate"); DEFSYM (QFnumberp, "Fnumberp"); DEFSYM (QFintegerp, "Fintegerp"); From 291531a7e46edcf52f49e193114e818c111d7af6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Aug 2019 22:48:48 +0200 Subject: [PATCH 0272/1452] code clean-up --- src/comp.c | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6a576cfe110..e1ffcf94ec4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -378,23 +378,6 @@ emit_cond_jump (gcc_jit_rvalue *test, } -/* Close current basic block emitting a comparison between two rval. */ - -/* static gcc_jit_rvalue * */ -/* emit_comparison_jump (enum gcc_jit_comparison op, */ -/* gcc_jit_rvalue *a, gcc_jit_rvalue *b, */ -/* gcc_jit_block *then_target, gcc_jit_block *else_target) */ -/* { */ -/* gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, */ -/* NULL, */ -/* op, */ -/* a, b); */ - -/* emit_cond_jump (test, then_target, else_target); */ - -/* return test; */ -/* } */ - static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { @@ -2755,7 +2738,7 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); - /* Used during prologue emission. */ + /* In use for prologue emission. */ DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); From 281d3a7aadefb673917bc585224c9bf7dae449e6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 16 Aug 2019 08:51:02 +0200 Subject: [PATCH 0273/1452] some renaming --- src/comp.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index e1ffcf94ec4..95bfb5d561b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -340,7 +340,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, static gcc_jit_rvalue * emit_call_ref (const char *f_name, unsigned nargs, - gcc_jit_lvalue *base_arg) + gcc_jit_lvalue *base_arg) { gcc_jit_rvalue *args[] = { gcc_jit_context_new_rvalue_from_int(comp.ctxt, @@ -1048,33 +1048,33 @@ emit_simple_limple_call_void_ret (Lisp_Object args) /* Entry point to dispatch emitting (call fun ...). */ static gcc_jit_rvalue * -emit_limple_call (Lisp_Object args) +emit_limple_call (Lisp_Object insn) { - Lisp_Object callee_sym = FIRST (args); + Lisp_Object callee_sym = FIRST (insn); char *callee = (char *) SDATA (SYMBOL_NAME (callee_sym)); Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); - return emitter_ptr (args); + return emitter_ptr (insn); } else if (callee[0] == 'F') { - return emit_simple_limple_call_lisp_ret (args); + return emit_simple_limple_call_lisp_ret (insn); } error ("LIMPLE call is inconsistent"); } static gcc_jit_rvalue * -emit_limple_call_ref (Lisp_Object args) +emit_limple_call_ref (Lisp_Object insn) { /* Ex: (callref Fplus 2 0). */ - char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); - EMACS_UINT nargs = XFIXNUM (SECOND (args)); - EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); + char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (insn))); + EMACS_UINT nargs = XFIXNUM (SECOND (insn)); + EMACS_UINT base_ptr = XFIXNUM (THIRD (insn)); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } From 24fe275711aa0964051f3b95c9bc9b4a3e524826 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 16 Aug 2019 10:38:51 +0200 Subject: [PATCH 0274/1452] optimize self calls --- lisp/emacs-lisp/comp.el | 35 +++++++++++++++++++++++++++++++++-- test/src/comp-tests.el | 2 ++ 2 files changed, 35 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a95cd56eae4..1c2ac4c6e4a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -463,6 +463,38 @@ If NEGATED non nil negate the tested condition." for m-test = (make-comp-mvar :constant test) do (comp-emit-cond-jump var m-test 0 target-label nil))) +(defun comp-emit-funcall (narg) + "Avoid Ffuncall trampoline if possibile. +NARG is the number of Ffuncall arguments." + (comp-stack-adjust (- narg)) + (let* ((callee (comp-slot)) + (callee-sym-name (comp-mvar-constant callee)) + (optimize nil) + (callref nil)) + (and (comp-mvar-const-vld callee) + (or (and (>= comp-speed 2) + (eq callee-sym-name (comp-func-symbol-name comp-func)) + (setq optimize t) + (setq callref (comp-nargs-p (comp-func-args comp-func)))) + ;; (and (>= comp-speed 3) + ;; (symbol-function callee-sym-name) + ;; (subrp (symbol-function callee-sym-name)) + ;; (setq optimize t) + ;; (setq callref (eq 'many + ;; (cdr (subr-arity + ;; (symbol-function callee-sym-name))))) + ;; (setf callee-sym-name )) + )) + (if optimize + (if callref + (comp-emit-set-call `(callref ,callee-sym-name + ,narg ,(1+ (comp-sp)))) + (comp-emit-set-call `(call ,callee-sym-name + ,@(cl-loop for i from (1+ (comp-sp)) + repeat narg + collect (comp-slot-n i))))) + (comp-emit-set-call `(callref Ffuncall ,(1+ narg) ,(comp-sp)))))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -529,8 +561,7 @@ the annotation emission." ,(make-comp-mvar :constant arg) ,(comp-slot-next)))) (byte-call - (comp-stack-adjust (- arg)) - (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) + (comp-emit-funcall arg)) (byte-unbind (comp-emit `(call helper_unbind_n ,(make-comp-mvar :constant arg)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e7b370c9321..55797f1352e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,6 +29,8 @@ (require 'comp) ;; (require 'cl-lib) +(setq comp-speed 3) + (defun comp-test-apply (func &rest args) (unless (subrp (symbol-function func)) (native-compile func)) From bdcd8dd9fe4a9926a0dbc46ee1180ef53a91bf17 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 16 Aug 2019 15:48:38 +0200 Subject: [PATCH 0275/1452] some other renaming --- lisp/emacs-lisp/comp.el | 10 +++++----- src/comp.c | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1c2ac4c6e4a..80b71590ec4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -76,16 +76,16 @@ finally return h) "Hash table lap-op -> stack adjustment.")) -(cl-defstruct comp-args-gen +(cl-defstruct comp-args-base (min nil :type number :documentation "Minimum number of arguments allowed.")) -(cl-defstruct (comp-args (:include comp-args-gen)) +(cl-defstruct (comp-args (:include comp-args-base)) (max nil :type number :documentation "Maximum number of arguments allowed. To be used when ncall-conv is nil.")) -(cl-defstruct (comp-nargs (:include comp-args-gen)) +(cl-defstruct (comp-nargs (:include comp-args-base)) "Describe args when the functin signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." (nonrest nil :type number @@ -114,7 +114,7 @@ into it.") :documentation "Byte compiled version.") (lap () :type list :documentation "Lap assembly representation.") - (args nil :type 'comp-args-gen) + (args nil :type 'comp-args-base) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -767,7 +767,7 @@ the annotation emission." :sp -1 :frame (comp-new-frame frame-size))) (args (comp-func-args func)) - (args-min (comp-args-gen-min args)) + (args-min (comp-args-base-min args)) (comp-block ())) ;; Prologue (comp-emit-block 'entry) diff --git a/src/comp.c b/src/comp.c index 95bfb5d561b..1e1060fd878 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2651,7 +2651,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-gen-min, args)); + x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); if (FUNCALL1 (comp-args-p, args)) x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); else From c4d723e865e86a83cf87d4cc42e7dbca799dc4ff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 16 Aug 2019 17:15:35 +0200 Subject: [PATCH 0276/1452] add comp-compile-ctxt-to-file --- src/comp.c | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1e1060fd878..b150292041b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -224,7 +224,7 @@ type_to_cast_field (gcc_jit_type *type) else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else - error ("unsupported cast\n"); + error ("Unsupported cast"); return field; } @@ -2327,7 +2327,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, { if (comp.ctxt) { - error ("Compiler context already taken."); + error ("Compiler context already taken"); return Qnil; } @@ -2611,6 +2611,48 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, return Qt; } +DEFUN ("comp-compile-ctxt-to-file", Fcomp_compile_ctxt_to_file, + Scomp_compile_ctxt_to_file, + 1, 1, 0, + doc: /* Compile as native code the current context to file. */) + (Lisp_Object ctxtname) +{ + if (!STRINGP (ctxtname)) + error ("Argument ctxtname not a string"); + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + comp_speed); + /* Gcc doesn't like being interrupted at all. */ + sigset_t oldset; + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + + if (COMP_DEBUG) + { + AUTO_STRING (dot_c, ".c"); + const char *filename = + (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_c)); + gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); + } + + AUTO_STRING (dot_so, ".so"); + const char *filename = + (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); + + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, + filename); + + pthread_sigmask (SIG_SETMASK, &oldset, 0); + + return Qt; +} + DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, Scomp_compile_and_load_ctxt, 0, 1, 0, @@ -2772,6 +2814,7 @@ syms_of_comp (void) defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_ctxt_to_file); defsubr (&Scomp_compile_and_load_ctxt); staticpro (&comp.func_hash); From 311c278c5bb26291fbe6d2e28130c43a08dce096 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 16 Aug 2019 22:09:29 +0200 Subject: [PATCH 0277/1452] export native_compiled_emacs_lisp symbol and make it loadable. --- src/comp.c | 5 +++++ src/emacs-module.c | 5 +++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index b150292041b..e3343afc7ba 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2500,6 +2500,11 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, define_add1_sub1 (); define_negate (); + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.int_type, + "native_compiled_emacs_lisp"); return Qt; } diff --git a/src/emacs-module.c b/src/emacs-module.c index bbb0e3dadd9..1ebcf19c2da 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -954,7 +954,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, { dynlib_handle_ptr handle; emacs_init_function module_init; - void *gpl_sym; + void *gpl_sym, *native_comp; CHECK_STRING (file); handle = dynlib_open (SSDATA (file)); @@ -962,7 +962,8 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, xsignal2 (Qmodule_open_failed, file, build_string (dynlib_error ())); gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible"); - if (!gpl_sym) + native_comp = dynlib_sym (handle, "native_compiled_emacs_lisp"); + if (!gpl_sym && !native_comp) xsignal1 (Qmodule_not_gpl_compatible, file); module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); From f4603ab67438ec1a31b35918608dc4db410be9c5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 16 Aug 2019 21:49:56 +0200 Subject: [PATCH 0278/1452] render data_relocs vector --- lisp/emacs-lisp/comp.el | 6 +++++- src/comp.c | 25 +++++++++++++++++++++++-- 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 80b71590ec4..9c31206cc2e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -773,6 +773,9 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) + (comp-emit `(const-vector ,(concat (comp-func-c-func-name func) "_data_relocs") + ,(prin1-to-string (aref (comp-func-byte-func func) + 2)))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) @@ -809,7 +812,8 @@ the annotation emission." ;; Once we have the final LIMPLE we jump into C. (comp-init-ctxt) (comp-add-func-to-ctxt func) - (comp-compile-and-load-ctxt) + (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) + ;; (comp-compile-and-load-ctxt) (comp-release-ctxt))) (error "Trying to native compile something not a function"))) diff --git a/src/comp.c b/src/comp.c index e3343afc7ba..32ece133c5e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1360,12 +1360,33 @@ emit_limple_insn (Lisp_Object insn) /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } + else if (EQ (op, Qconst_vector)) + { + /* Ex: (const-vector "F666f6f_foo_reloc" + "[a b c 1 2]"). */ + Lisp_Object vec = SECOND (args); + EMACS_INT v_len = XFIXNUM (FUNCALL1 (length, vec)); + + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + v_len), + (char *) SDATA (arg0)); + } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, NULL, emit_mvar_val (arg0)); } + else + { + error ("LIMPLE op inconsistent"); + } } @@ -2622,8 +2643,7 @@ DEFUN ("comp-compile-ctxt-to-file", Fcomp_compile_ctxt_to_file, doc: /* Compile as native code the current context to file. */) (Lisp_Object ctxtname) { - if (!STRINGP (ctxtname)) - error ("Argument ctxtname not a string"); + CHECK_STRING (ctxtname); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -2777,6 +2797,7 @@ syms_of_comp (void) { /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); + DEFSYM (Qconst_vector, "const-vector"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); From 52089993aa3231ccdfd0469aeb7c3e7b6b89edad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 10:34:18 +0200 Subject: [PATCH 0279/1452] no need to quote types into structs --- lisp/emacs-lisp/comp.el | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9c31206cc2e..fdb1b386132 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -97,7 +97,7 @@ To be used when ncall-conv is nil.")) (sp nil :documentation "When non nil indicates the sp value while entering into it.") - (closed nil :type 'boolean + (closed nil :type boolean :documentation "If the block was already closed.") (insns () :type list :documentation "List of instructions.")) @@ -106,7 +106,7 @@ into it.") "LIMPLE representation of a function." (symbol-name nil :documentation "Function symbol's name.") - (c-func-name nil :type 'string + (c-func-name nil :type string :documentation "The function name in the native world.") (func nil :documentation "Original form.") @@ -114,15 +114,15 @@ into it.") :documentation "Byte compiled version.") (lap () :type list :documentation "Lap assembly representation.") - (args nil :type 'comp-args-base) - (frame-size nil :type 'number) - (blocks (make-hash-table) :type 'hash-table + (args nil :type comp-args-base) + (frame-size nil :type number) + (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block structure.") - (lap-block (make-hash-table :test #'equal) :type 'hash-table + (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block.") - (ssa-cnt -1 :type 'number + (ssa-cnt -1 :type number :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) @@ -141,11 +141,11 @@ LIMPLE basic block.") (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during limplification." - (sp 0 :type 'fixnum + (sp 0 :type fixnum :documentation "Current stack pointer while walking LAP.") - (frame nil :type 'vector + (frame nil :type vector :documentation "Meta-stack used to flat LAP.") - (block-name nil :type 'symbol + (block-name nil :type symbol :documentation "Current basic block name.")) (defmacro comp-within-log-buff (&rest body) From 941937d295dce322e00a1d77b61041e6bda5cfd8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 11:06:48 +0200 Subject: [PATCH 0280/1452] disable const vect per function --- lisp/emacs-lisp/comp.el | 3 --- src/comp.c | 17 ----------------- 2 files changed, 20 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fdb1b386132..a55d369570d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -773,9 +773,6 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (comp-emit `(const-vector ,(concat (comp-func-c-func-name func) "_data_relocs") - ,(prin1-to-string (aref (comp-func-byte-func func) - 2)))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) diff --git a/src/comp.c b/src/comp.c index 32ece133c5e..b1116aa961b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1360,23 +1360,6 @@ emit_limple_insn (Lisp_Object insn) /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } - else if (EQ (op, Qconst_vector)) - { - /* Ex: (const-vector "F666f6f_foo_reloc" - "[a b c 1 2]"). */ - Lisp_Object vec = SECOND (args); - EMACS_INT v_len = XFIXNUM (FUNCALL1 (length, vec)); - - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_INTERNAL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - v_len), - (char *) SDATA (arg0)); - } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, From 7cd401f63db705acb8ede6624c293843b41e7e20 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 11:07:09 +0200 Subject: [PATCH 0281/1452] declare comp-ctxt Vcomp_ctxt --- src/comp.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/comp.c b/src/comp.c index b1116aa961b..1d53038d477 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2834,6 +2834,11 @@ syms_of_comp (void) DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, + doc: /* + The compiler context. */); + Vcomp_ctxt = Qnil; + comp_speed = DEFAULT_SPEED; } From f5ab0db4b03c497112fdcde3b8b270c3fa14a3c3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 11:07:54 +0200 Subject: [PATCH 0282/1452] rename a bunch o f functions as private --- src/comp.c | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1d53038d477..41147e46e0d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2324,7 +2324,7 @@ define_bool_to_lisp_obj (void) /* Entry points exposed to lisp. */ /**********************************/ -DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, +DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) (void) @@ -2512,7 +2512,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qt; } -DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, +DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, 0, 0, 0, doc: /* Release the native compiler context. */) (void) @@ -2527,8 +2527,8 @@ DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, return Qt; } -DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, - 1, 1, 0, +DEFUN ("comp--add-func-to-ctxt", Fcomp__add_func_to_ctxt, + Scomp__add_func_to_ctxt, 1, 1, 0, doc: /* Add limple FUNC to the current compilation context. */) (Lisp_Object func) { @@ -2620,8 +2620,8 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, return Qt; } -DEFUN ("comp-compile-ctxt-to-file", Fcomp_compile_ctxt_to_file, - Scomp_compile_ctxt_to_file, +DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, + Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) (Lisp_Object ctxtname) @@ -2780,7 +2780,6 @@ syms_of_comp (void) { /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); - DEFSYM (Qconst_vector, "const-vector"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); @@ -2820,10 +2819,10 @@ syms_of_comp (void) DEFSYM (QFnumberp, "Fnumberp"); DEFSYM (QFintegerp, "Fintegerp"); - defsubr (&Scomp_init_ctxt); - defsubr (&Scomp_release_ctxt); - defsubr (&Scomp_add_func_to_ctxt); - defsubr (&Scomp_compile_ctxt_to_file); + defsubr (&Scomp__init_ctxt); + defsubr (&Scomp__release_ctxt); + defsubr (&Scomp__add_func_to_ctxt); + defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Scomp_compile_and_load_ctxt); staticpro (&comp.func_hash); From 765e57e2d25d34280b25b925dd8ede4cbfd39020 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 15:36:36 +0200 Subject: [PATCH 0283/1452] improve relocation collection --- lisp/emacs-lisp/comp.el | 41 +++++++++++++++++++++++++++++++++++++---- 1 file changed, 37 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a55d369570d..fe92252405e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -76,6 +76,18 @@ finally return h) "Hash table lap-op -> stack adjustment.")) +(cl-defstruct comp-ctxt + (data-relocs () :type string + :documentation "Final data relocations.") + (data-relocs-l () :type list + :documentation "Constant objects used by functions.") + (data-relocs-idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into data-relocs.") + (func-relocs () :type list + :documentation "Native functions imported.") + (func-relocs-idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into func-relocs.")) + (cl-defstruct comp-args-base (min nil :type number :documentation "Minimum number of arguments allowed.")) @@ -148,6 +160,25 @@ LIMPLE basic block.") (block-name nil :type symbol :documentation "Current basic block name.")) +(defvar comp-ctxt) ;; FIXME (to be removed) + + +(defun comp-add-const-to-relocs (obj) + "Keep track of OBJ into relocations. +The corresponding index into it is returned." + (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) + (unless (gethash obj data-relocs-idx) + (push obj (comp-ctxt-data-relocs-l comp-ctxt)) + (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + +(defun comp-compile-ctxt-to-file (name) + "Compile as native code the current context naming it NAME." + (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) + (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (setf (comp-ctxt-data-relocs comp-ctxt) + (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (comp--compile-ctxt-to-file name)) + (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -346,6 +377,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." + (comp-add-const-to-relocs val) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :constant val)) (comp-emit (list 'setimm (comp-slot) val))) @@ -802,16 +834,17 @@ the annotation emission." (let ((func (make-comp-func :symbol-name func-symbol-name :func f :c-func-name (comp-c-func-name - func-symbol-name)))) + func-symbol-name))) + (comp-ctxt (make-comp-ctxt))) (mapc (lambda (pass) (funcall pass func)) comp-passes) ;; Once we have the final LIMPLE we jump into C. - (comp-init-ctxt) - (comp-add-func-to-ctxt func) + (comp--init-ctxt) + (comp--add-func-to-ctxt func) (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) ;; (comp-compile-and-load-ctxt) - (comp-release-ctxt))) + (comp--release-ctxt))) (error "Trying to native compile something not a function"))) (provide 'comp) From b6540a8ef5b2725812760f5a9a5cdaef591cb5b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 15:37:10 +0200 Subject: [PATCH 0284/1452] emit relocs as text into c code --- src/comp.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 51 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 41147e46e0d..babedf258a4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -170,6 +170,8 @@ bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, void helper_emit_save_restriction (void); +void helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs); + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) @@ -1472,6 +1474,46 @@ emit_integerp (Lisp_Object insn) &res); } +/* +This emit the code needed by every compilation unit to be loaded. +*/ +static void +emit_ctxt_code (void) +{ + const char *d_reloc = SSDATA (FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt)); + EMACS_UINT d_reloc_len = + XFIXNUM (FUNCALL1 (hash-table-count, + FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + "data_relocs"); + /* + Is not possibile to initilize static data in libgccjit therfore will create + the following: + + char *text_data_relocs (void) + { + return "[a b c... etc]"; + } + */ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.char_ptr_type, + "text_data_relocs", + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, d_reloc); + gcc_jit_block_end_with_return (block, NULL, res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -1591,7 +1633,7 @@ define_lisp_cons (void) } -/* opaque jmp_buf definition. */ +/* Opaque jmp_buf definition. */ static void define_jmp_buf (void) @@ -2640,6 +2682,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigaddset (&blocked, SIGIO); pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + emit_ctxt_code (); + if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); @@ -2648,7 +2692,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); } - AUTO_STRING (dot_so, ".so"); + AUTO_STRING (dot_so, ".so"); /* FIXME use correct var */ const char *filename = (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); @@ -2774,6 +2818,11 @@ helper_emit_save_restriction (void) save_restriction_save ()); } +void +helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) +{ +} + void syms_of_comp (void) From 6a65498228c80a6cafc514dee7092b64e9bb84c4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 16:47:43 +0200 Subject: [PATCH 0285/1452] fixup data relocs at load time --- src/emacs-module.c | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/src/emacs-module.c b/src/emacs-module.c index 1ebcf19c2da..7b9a5d843d0 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -944,6 +944,24 @@ module_signal_or_throw (struct emacs_env_private *env) } } +typedef char *(*f_comp_data_relocs) (void); + +static int +comp_load_unit (dynlib_handle_ptr handle, struct emacs_runtime *rt) +{ + Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); + f_comp_data_relocs f = dynlib_sym (handle, "text_data_relocs"); + char *text_data_relocs = f(); + + Lisp_Object d_vec = Fread (build_string (text_data_relocs)); + EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); + + for (EMACS_UINT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (d_vec, i); + + return 0; +} + /* Live runtime and environment objects, for assertions. */ static Lisp_Object Vmodule_runtimes; static Lisp_Object Vmodule_environments; @@ -966,10 +984,13 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, if (!gpl_sym && !native_comp) xsignal1 (Qmodule_not_gpl_compatible, file); - module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); - if (!module_init) - xsignal1 (Qmissing_module_init_function, file); - + if (!native_comp) + { + module_init = + (emacs_init_function) dynlib_func (handle, "emacs_module_init"); + if (!module_init) + xsignal1 (Qmissing_module_init_function, file); + } struct emacs_runtime rt_pub; struct emacs_runtime_private rt_priv; emacs_env env_pub; @@ -990,7 +1011,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); - int r = module_init (rt); + int r = native_comp ? comp_load_unit (handle, rt) : module_init (rt); /* Process the quit flag first, so that quitting doesn't get overridden by other non-local exits. */ From eb6ac423aa21a50d86056fdda4b2bd58278dbef4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 17:10:46 +0200 Subject: [PATCH 0286/1452] remove function list form the C compiler ctxt --- src/comp.c | 102 +++++++++++++++++++++++++---------------------------- 1 file changed, 49 insertions(+), 53 deletions(-) diff --git a/src/comp.c b/src/comp.c index babedf258a4..65bca050b0e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -63,7 +63,7 @@ along with GNU Emacs. If not, see . */ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR(name)) -/* The compiler context */ +/* C side of the compiler context. */ typedef struct { gcc_jit_context *ctxt; @@ -147,7 +147,6 @@ typedef struct { gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ - Lisp_Object funcs; /* List of functions defined. */ Lisp_Object emitter_dispatcher; } comp_t; @@ -2405,7 +2404,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, } comp.ctxt = gcc_jit_context_acquire(); - comp.funcs = Qnil; if (COMP_DEBUG) { @@ -2657,8 +2655,6 @@ DEFUN ("comp--add-func-to-ctxt", Fcomp__add_func_to_ctxt, } } - comp.funcs = Fcons (func, comp.funcs); - return Qt; } @@ -2705,61 +2701,61 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return Qt; } -DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, - Scomp_compile_and_load_ctxt, - 0, 1, 0, - doc: /* Compile as native code the current context and load its - functions. */) - (Lisp_Object disassemble) -{ - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - comp_speed); - /* Gcc doesn't like being interrupted at all. */ - sigset_t oldset; - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - sigaddset (&blocked, SIGIO); - pthread_sigmask (SIG_BLOCK, &blocked, &oldset); +/* DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, */ +/* Scomp_compile_and_load_ctxt, */ +/* 0, 1, 0, */ +/* doc: /\* Compile as native code the current context and load its */ +/* functions. *\/) */ +/* (Lisp_Object disassemble) */ +/* { */ +/* gcc_jit_context_set_int_option (comp.ctxt, */ +/* GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, */ +/* comp_speed); */ +/* /\* Gcc doesn't like being interrupted at all. *\/ */ +/* sigset_t oldset; */ +/* sigset_t blocked; */ +/* sigemptyset (&blocked); */ +/* sigaddset (&blocked, SIGALRM); */ +/* sigaddset (&blocked, SIGINT); */ +/* sigaddset (&blocked, SIGIO); */ +/* pthread_sigmask (SIG_BLOCK, &blocked, &oldset); */ - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); - gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); +/* if (COMP_DEBUG) */ +/* gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); */ +/* gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); */ - if (!NILP (disassemble)) - gcc_jit_context_compile_to_file (comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - "gcc-ctxt-dump.s"); +/* if (!NILP (disassemble)) */ +/* gcc_jit_context_compile_to_file (comp.ctxt, */ +/* GCC_JIT_OUTPUT_KIND_ASSEMBLER, */ +/* "gcc-ctxt-dump.s"); */ - while (CONSP (comp.funcs)) - { - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - Lisp_Object func = XCAR (comp.funcs); - Lisp_Object args = FUNCALL1 (comp-func-args, func); - char *symbol_name = - (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); - char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); +/* while (CONSP (comp.funcs)) */ +/* { */ +/* union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); */ +/* Lisp_Object func = XCAR (comp.funcs); */ +/* Lisp_Object args = FUNCALL1 (comp-func-args, func); */ +/* char *symbol_name = */ +/* (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); */ +/* char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); */ - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); - eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); - if (FUNCALL1 (comp-args-p, args)) - x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - else - x->s.max_args = MANY; - x->s.symbol_name = symbol_name; - defsubr(x); +/* x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; */ +/* x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); */ +/* eassert (x->s.function.a0); */ +/* x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); */ +/* if (FUNCALL1 (comp-args-p, args)) */ +/* x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ +/* else */ +/* x->s.max_args = MANY; */ +/* x->s.symbol_name = symbol_name; */ +/* defsubr(x); */ - comp.funcs = XCDR (comp.funcs); - } +/* comp.funcs = XCDR (comp.funcs); */ +/* } */ - pthread_sigmask (SIG_SETMASK, &oldset, 0); +/* pthread_sigmask (SIG_SETMASK, &oldset, 0); */ - return Qt; -} +/* return Qt; */ +/* } */ /******************************************************************************/ From 6f6362207f7d39b5fb10b2968d238e37848a5a9d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 17:17:56 +0200 Subject: [PATCH 0287/1452] add funcs into comp-ctxt --- lisp/emacs-lisp/comp.el | 44 +++++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe92252405e..486a7068be5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,8 +77,17 @@ "Hash table lap-op -> stack adjustment.")) (cl-defstruct comp-ctxt + "This structure is to serve al relocation creation for the current compiler + context." + (funcs () :type list + :documentation "Alist lisp-func-name -> c-func-name. +This is build before entering into `comp--compile-ctxt-to-file name'.") + (funcs-h (make-hash-table) :type hash-table + :documentation "lisp-func-name -> c-func-name. +This is to build the prev field.") (data-relocs () :type string - :documentation "Final data relocations.") + :documentation "Final data relocations. +This is build before entering into `comp--compile-ctxt-to-file name'.") (data-relocs-l () :type list :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table @@ -171,14 +180,6 @@ The corresponding index into it is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) -(defun comp-compile-ctxt-to-file (name) - "Compile as native code the current context naming it NAME." - (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) - (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-data-relocs comp-ctxt) - (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) - (comp--compile-ctxt-to-file name)) - (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -822,6 +823,29 @@ the annotation emission." (comp-log-func func) func)) + +;;; C function wrappers + +(defun comp-compile-ctxt-to-file (name) + "Compile as native code the current context naming it NAME." + (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) + (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (setf (comp-ctxt-data-relocs comp-ctxt) + (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (setf (comp-ctxt-funcs comp-ctxt) + (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) + for f being each hash-keys of h + using (hash-value c-f) + collect (cons (symbol-name f) c-f))) + (comp--compile-ctxt-to-file name)) + +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (puthash (comp-func-symbol-name func) + (comp-func-c-func-name func) + (comp-ctxt-funcs-h comp-ctxt)) + (comp--add-func-to-ctxt func)) + ;;; Entry points. @@ -841,7 +865,7 @@ the annotation emission." comp-passes) ;; Once we have the final LIMPLE we jump into C. (comp--init-ctxt) - (comp--add-func-to-ctxt func) + (comp-add-func-to-ctxt func) (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) ;; (comp-compile-and-load-ctxt) (comp--release-ctxt))) From c8a0b81f8ffe093910dd3ad2852dd47a15587d9e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 18:43:33 +0200 Subject: [PATCH 0288/1452] basic reload almost working --- lisp/emacs-lisp/comp.el | 25 +++++++++++++------- src/comp.c | 46 ++++++++++++++++++++++-------------- src/emacs-module.c | 52 ++++++++++++++++++++++++++++++++++++----- 3 files changed, 90 insertions(+), 33 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 486a7068be5..a453acc329c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -253,7 +253,7 @@ BODY is evaluate only if `comp-debug' is non nil." (let ((lambda-list (aref (comp-func-byte-func func) 0))) (if (fixnump lambda-list) (setf (comp-func-args func) - (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (comp-decrypt-lambda-list lambda-list)) (error "Can't native compile a non lexical scoped function"))) (setf (comp-func-lap func) byte-compile-lap-output) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) @@ -831,19 +831,26 @@ the annotation emission." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-data-relocs comp-ctxt) - (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) (setf (comp-ctxt-funcs comp-ctxt) - (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) - for f being each hash-keys of h - using (hash-value c-f) - collect (cons (symbol-name f) c-f))) + (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) + for f being each hash-value of h + collect f))) (comp--compile-ctxt-to-file name)) (defun comp-add-func-to-ctxt (func) "Add FUNC to the current compiler contex." - (puthash (comp-func-symbol-name func) - (comp-func-c-func-name func) - (comp-ctxt-funcs-h comp-ctxt)) + (let ((args (comp-func-args func)) + (doc (aref (comp-func-byte-func func) 4))) + (puthash (comp-func-symbol-name func) + (vector (comp-func-symbol-name func) + (comp-func-c-func-name func) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many)) + doc) + (comp-ctxt-funcs-h comp-ctxt))) (comp--add-func-to-ctxt func)) diff --git a/src/comp.c b/src/comp.c index 65bca050b0e..953a1dd9d0f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1473,6 +1473,30 @@ emit_integerp (Lisp_Object insn) &res); } +/* + Is not possibile to initilize static data in libgccjit therfore will create + the following: + + char *str_name (void) + { + return "payload here"; + } +*/ + +static void +emit_litteral_string_func (const char *str_name, const char *str) +{ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.char_ptr_type, + str_name, + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); + gcc_jit_block_end_with_return (block, NULL, res); +} + /* This emit the code needed by every compilation unit to be loaded. */ @@ -1493,24 +1517,11 @@ emit_ctxt_code (void) comp.lisp_obj_type, d_reloc_len), "data_relocs"); - /* - Is not possibile to initilize static data in libgccjit therfore will create - the following: - char *text_data_relocs (void) - { - return "[a b c... etc]"; - } - */ - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.char_ptr_type, - "text_data_relocs", - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, d_reloc); - gcc_jit_block_end_with_return (block, NULL, res); + emit_litteral_string_func ("text_data_relocs", d_reloc); + + const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); + emit_litteral_string_func ("text_funcs", func_list); } @@ -2868,7 +2879,6 @@ syms_of_comp (void) defsubr (&Scomp__release_ctxt); defsubr (&Scomp__add_func_to_ctxt); defsubr (&Scomp__compile_ctxt_to_file); - defsubr (&Scomp_compile_and_load_ctxt); staticpro (&comp.func_hash); comp.func_hash = Qnil; diff --git a/src/emacs-module.c b/src/emacs-module.c index 7b9a5d843d0..e14ef89d8f9 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -944,21 +944,61 @@ module_signal_or_throw (struct emacs_env_private *env) } } -typedef char *(*f_comp_data_relocs) (void); + +/* + Native compiler load functions. + FIXME: Move away from here. +*/ + +typedef char *(*comp_litt_str_func) (void); + +static Lisp_Object +comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) +{ + comp_litt_str_func f = dynlib_sym (handle, str_name); + char *res = f(); + return Fread (build_string (res)); +} static int -comp_load_unit (dynlib_handle_ptr handle, struct emacs_runtime *rt) +comp_load_unit (dynlib_handle_ptr handle, emacs_env *env) { Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); - f_comp_data_relocs f = dynlib_sym (handle, "text_data_relocs"); - char *text_data_relocs = f(); - Lisp_Object d_vec = Fread (build_string (text_data_relocs)); + Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) data_relocs[i] = AREF (d_vec, i); + Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); + + while (func_list) + { + Lisp_Object el = XCAR (func_list); + Lisp_Object Qsym = AREF (el, 0); + char *c_func_name = SSDATA (AREF (el, 1)); + Lisp_Object args = AREF (el, 2); + ptrdiff_t minargs = XFIXNUM (XCAR (args)); + ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; + /* char *doc = SSDATA (AREF (el, 3)); */ + void *func = dynlib_sym (handle, c_func_name); + eassert (func); + /* Ffset (Qsym, */ + /* value_to_lisp (module_make_function (env, minargs, maxargs, func, */ + /* doc, NULL))); */ + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = minargs; + x->s.max_args = maxargs; + x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); + defsubr(x); + + func_list = XCDR (func_list); + } + return 0; } @@ -1011,7 +1051,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); - int r = native_comp ? comp_load_unit (handle, rt) : module_init (rt); + int r = native_comp ? comp_load_unit (handle, &env_pub) : module_init (rt); /* Process the quit flag first, so that quitting doesn't get overridden by other non-local exits. */ From 70a7c65742244403422d7c3e4b79a2046c1cefb7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 21:48:49 +0200 Subject: [PATCH 0289/1452] move away from modules --- src/comp.c | 87 ++++++++++++++++++++++++++++++++++++++++++---- src/emacs-module.c | 76 ++++------------------------------------ src/lread.c | 47 +++++++++++++++++-------- 3 files changed, 120 insertions(+), 90 deletions(-) diff --git a/src/comp.c b/src/comp.c index 953a1dd9d0f..5233a72aa5d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see . */ #include "bytecode.h" #include "atimer.h" #include "window.h" +#include "dynlib.h" #define DEFAULT_SPEED 2 /* See comp-speed var. */ @@ -2555,11 +2556,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_add1_sub1 (); define_negate (); - gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - comp.int_type, - "native_compiled_emacs_lisp"); return Qt; } @@ -2699,7 +2695,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); } - AUTO_STRING (dot_so, ".so"); /* FIXME use correct var */ + AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); const char *filename = (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); @@ -2830,6 +2826,81 @@ helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) { } + + +/************************************/ +/* Native compiler load functions. */ +/************************************/ + +typedef char *(*comp_litt_str_func) (void); + +static Lisp_Object +comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) +{ + comp_litt_str_func f = dynlib_sym (handle, str_name); + char *res = f(); + return Fread (build_string (res)); +} + +static int +load_comp_unit (dynlib_handle_ptr handle) +{ + Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); + + Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); + EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); + + for (EMACS_UINT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (d_vec, i); + + Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); + + while (func_list) + { + Lisp_Object el = XCAR (func_list); + Lisp_Object Qsym = AREF (el, 0); + char *c_func_name = SSDATA (AREF (el, 1)); + Lisp_Object args = AREF (el, 2); + ptrdiff_t minargs = XFIXNUM (XCAR (args)); + ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; + /* char *doc = SSDATA (AREF (el, 3)); */ + void *func = dynlib_sym (handle, c_func_name); + eassert (func); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = minargs; + x->s.max_args = maxargs; + x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); + defsubr(x); + + func_list = XCDR (func_list); + } + + return 0; +} + +/* Load related routines. */ +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, + doc: /* Load native elisp code FILE. */) + (Lisp_Object file) +{ + dynlib_handle_ptr handle; + + CHECK_STRING (file); + handle = dynlib_open (SSDATA (file)); + if (!handle) + xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); + + int r = load_comp_unit (handle); + + if (r != 0) + xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); + + return Qt; +} + void syms_of_comp (void) @@ -2874,11 +2945,15 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (QFnumberp, "Fnumberp"); DEFSYM (QFintegerp, "Fintegerp"); + /* Returned values. */ + DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); + DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__add_func_to_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Snative_elisp_load); staticpro (&comp.func_hash); comp.func_hash = Qnil; diff --git a/src/emacs-module.c b/src/emacs-module.c index e14ef89d8f9..bbb0e3dadd9 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -944,64 +944,6 @@ module_signal_or_throw (struct emacs_env_private *env) } } - -/* - Native compiler load functions. - FIXME: Move away from here. -*/ - -typedef char *(*comp_litt_str_func) (void); - -static Lisp_Object -comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) -{ - comp_litt_str_func f = dynlib_sym (handle, str_name); - char *res = f(); - return Fread (build_string (res)); -} - -static int -comp_load_unit (dynlib_handle_ptr handle, emacs_env *env) -{ - Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); - - Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); - EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); - - for (EMACS_UINT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (d_vec, i); - - Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); - - while (func_list) - { - Lisp_Object el = XCAR (func_list); - Lisp_Object Qsym = AREF (el, 0); - char *c_func_name = SSDATA (AREF (el, 1)); - Lisp_Object args = AREF (el, 2); - ptrdiff_t minargs = XFIXNUM (XCAR (args)); - ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; - /* char *doc = SSDATA (AREF (el, 3)); */ - void *func = dynlib_sym (handle, c_func_name); - eassert (func); - /* Ffset (Qsym, */ - /* value_to_lisp (module_make_function (env, minargs, maxargs, func, */ - /* doc, NULL))); */ - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = func; - x->s.min_args = minargs; - x->s.max_args = maxargs; - x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); - defsubr(x); - - func_list = XCDR (func_list); - } - - return 0; -} - /* Live runtime and environment objects, for assertions. */ static Lisp_Object Vmodule_runtimes; static Lisp_Object Vmodule_environments; @@ -1012,7 +954,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, { dynlib_handle_ptr handle; emacs_init_function module_init; - void *gpl_sym, *native_comp; + void *gpl_sym; CHECK_STRING (file); handle = dynlib_open (SSDATA (file)); @@ -1020,17 +962,13 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, xsignal2 (Qmodule_open_failed, file, build_string (dynlib_error ())); gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible"); - native_comp = dynlib_sym (handle, "native_compiled_emacs_lisp"); - if (!gpl_sym && !native_comp) + if (!gpl_sym) xsignal1 (Qmodule_not_gpl_compatible, file); - if (!native_comp) - { - module_init = - (emacs_init_function) dynlib_func (handle, "emacs_module_init"); - if (!module_init) - xsignal1 (Qmissing_module_init_function, file); - } + module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); + if (!module_init) + xsignal1 (Qmissing_module_init_function, file); + struct emacs_runtime rt_pub; struct emacs_runtime_private rt_priv; emacs_env env_pub; @@ -1051,7 +989,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); - int r = native_comp ? comp_load_unit (handle, &env_pub) : module_init (rt); + int r = module_init (rt); /* Process the quit flag first, so that quitting doesn't get overridden by other non-local exits. */ diff --git a/src/lread.c b/src/lread.c index ca7b29f690b..1a5074cb70b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,6 +1281,11 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif +#ifdef HAVE_LIBGCCJIT + bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); +#else + bool is_native_elisp = false; +#endif /* Check if we're stuck in a recursive load cycle. 2000-09-21: It's not possible to just check for the file loaded @@ -1379,7 +1384,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)) @@ -1406,7 +1411,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); @@ -1422,7 +1427,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. */ @@ -1452,6 +1457,8 @@ Return t if the file exists and loads successfully. */) file, 1); else 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) @@ -1475,6 +1482,18 @@ Return t if the file exists and loads successfully. */) #else /* This cannot happen. */ emacs_abort (); +#endif + } + else if (is_native_elisp) + { +#ifdef HAVE_LIBGCCJIT + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fnative_elisp_load (found); + build_load_history (found, true); +#else + /* This cannot happen. */ + emacs_abort (); #endif } else @@ -4866,21 +4885,19 @@ 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 +#ifdef HAVE_LIBGCCJIT + Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); +#endif + DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix, doc: /* Suffix of loadable module file, or nil if modules are not supported. */); #ifdef HAVE_MODULES From 4d7a51eba2c780d10a0b0dac33936c178c677f50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 21:13:19 +0200 Subject: [PATCH 0290/1452] prevent garbage collection --- src/comp.c | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5233a72aa5d..9ccf73ef4bf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2827,15 +2827,22 @@ helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) } +/*********************************/ +/* Native elisp load functions. */ +/*********************************/ -/************************************/ -/* Native compiler load functions. */ -/************************************/ +static Lisp_Object Vnative_elisp_refs_hash; typedef char *(*comp_litt_str_func) (void); +static void +prevent_gc (Lisp_Object obj) +{ + Fputhash (obj, Qt, Vnative_elisp_refs_hash); +} + static Lisp_Object -comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) +retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) { comp_litt_str_func f = dynlib_sym (handle, str_name); char *res = f(); @@ -2847,13 +2854,16 @@ load_comp_unit (dynlib_handle_ptr handle) { Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); - Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); + Lisp_Object d_vec = retrive_litteral_obj (handle, "text_data_relocs"); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (d_vec, i); + { + data_relocs[i] = AREF (d_vec, i); + prevent_gc (data_relocs[i]); + } - Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); + Lisp_Object func_list = retrive_litteral_obj (handle, "text_funcs"); while (func_list) { @@ -2905,6 +2915,12 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { + staticpro (&Vnative_elisp_refs_hash); + Vnative_elisp_refs_hash + = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, + DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, + Qnil, false); + /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); From 20d42249ce8d7fad1e377621e717b238df3a4b05 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 21:39:09 +0200 Subject: [PATCH 0291/1452] emit reloc index --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a453acc329c..11803a3ea5f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -378,10 +378,10 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." - (comp-add-const-to-relocs val) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :constant val)) - (comp-emit (list 'setimm (comp-slot) val))) + (let ((rel-idx (comp-add-const-to-relocs val))) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) + :constant val)) + (comp-emit `(setimm ,(comp-slot) ,rel-idx . ,val)))) (defun comp-mark-block-closed () "Mark current basic block as closed." From 79d4b6915c0dc3e27ca18353bf53ceb31a14ded2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 18 Aug 2019 23:09:20 +0200 Subject: [PATCH 0292/1452] make use of data relocations --- lisp/emacs-lisp/comp.el | 31 +++--- src/comp.c | 216 +++++++++++++++++++++------------------- 2 files changed, 131 insertions(+), 116 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 11803a3ea5f..9026bf7b532 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -83,7 +83,7 @@ :documentation "Alist lisp-func-name -> c-func-name. This is build before entering into `comp--compile-ctxt-to-file name'.") (funcs-h (make-hash-table) :type hash-table - :documentation "lisp-func-name -> c-func-name. + :documentation "lisp-func-name -> comp-func. This is to build the prev field.") (data-relocs () :type string :documentation "Final data relocations. @@ -381,7 +381,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (let ((rel-idx (comp-add-const-to-relocs val))) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :constant val)) - (comp-emit `(setimm ,(comp-slot) ,rel-idx . ,val)))) + (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) (defun comp-mark-block-closed () "Mark current basic block as closed." @@ -835,23 +835,24 @@ the annotation emission." (setf (comp-ctxt-funcs comp-ctxt) (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h - collect f))) + for args = (comp-func-args f) + for doc = (aref (comp-func-byte-func f) 4) + collect (vector (comp-func-symbol-name f) + (comp-func-c-func-name f) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many)) + doc)))) (comp--compile-ctxt-to-file name)) (defun comp-add-func-to-ctxt (func) "Add FUNC to the current compiler contex." - (let ((args (comp-func-args func)) - (doc (aref (comp-func-byte-func func) 4))) - (puthash (comp-func-symbol-name func) - (vector (comp-func-symbol-name func) - (comp-func-c-func-name func) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many)) - doc) - (comp-ctxt-funcs-h comp-ctxt))) - (comp--add-func-to-ctxt func)) + (puthash (comp-func-symbol-name func) + func + (comp-ctxt-funcs-h comp-ctxt)) + ;; (comp--add-func-to-ctxt func) + ) ;;; Entry points. diff --git a/src/comp.c b/src/comp.c index 9ccf73ef4bf..acf02e7c7cd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,6 +149,7 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ Lisp_Object emitter_dispatcher; + gcc_jit_rvalue *data_relocs; } comp_t; static comp_t comp; @@ -1349,13 +1350,22 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ - Lisp_Object arg1 = SECOND (args); + /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_rvalue *reloc_n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + XFIXNUM (SECOND (args))); + emit_comment (SSDATA (Fprin1_to_string (THIRD (args), Qnil))); gcc_jit_block_add_assignment (comp.block, NULL, comp.frame[slot_n], - emit_lisp_obj_from_ptr (arg1)); + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + comp.data_relocs, + reloc_n))); } else if (EQ (op, Qcomment)) { @@ -1509,15 +1519,17 @@ emit_ctxt_code (void) XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_context_new_array_type (comp.ctxt, + comp.data_relocs + = gcc_jit_lvalue_as_rvalue( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.lisp_obj_type, d_reloc_len), - "data_relocs"); + "data_relocs")); emit_litteral_string_func ("text_data_relocs", d_reloc); @@ -2372,6 +2384,93 @@ define_bool_to_lisp_obj (void) } +static void +compile_function (Lisp_Object func) +{ + char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); + Lisp_Object args = FUNCALL1 (comp-func-args, func); + EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + bool ncall = (FUNCALL1 (comp-nargs-p, args)); + + if (!ncall) + { + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + comp.func = + emit_func_declare (c_name, comp.lisp_obj_type, max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); + } + else + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + comp.func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, 2, param, 0); + } + + gcc_jit_lvalue *frame_array = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "local"); + + gcc_jit_lvalue *frame[frame_size]; + for (int i = 0; i < frame_size; ++i) + frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (frame_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + comp.frame = frame; + + comp.func_blocks = CALLN (Fmake_hash_table); + + /* Pre declare all basic blocks to gcc. + The "entry" block must be declared as first. */ + declare_block (Qentry); + Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); + Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block = HASH_VALUE (ht, i); + if (!EQ (block, entry_block)) + declare_block (HASH_KEY (ht, i)); + } + + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block_name = HASH_KEY (ht, i); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = FUNCALL1 (comp-block-insns, block); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } + } +} + /**********************************/ /* Entry points exposed to lisp. */ @@ -2574,97 +2673,6 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } -DEFUN ("comp--add-func-to-ctxt", Fcomp__add_func_to_ctxt, - Scomp__add_func_to_ctxt, 1, 1, 0, - doc: /* Add limple FUNC to the current compilation context. */) - (Lisp_Object func) -{ - char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); - Lisp_Object args = FUNCALL1 (comp-func-args, func); - EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); - bool ncall = (FUNCALL1 (comp-nargs-p, args)); - - if (!ncall) - { - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - comp.func = - emit_func_declare (c_name, comp.lisp_obj_type, max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); - } - else - { - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "args") }; - comp.func = - gcc_jit_context_new_function (comp.ctxt, - NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_name, 2, param, 0); - } - - gcc_jit_lvalue *frame_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - frame_size), - "local"); - - gcc_jit_lvalue *frame[frame_size]; - for (int i = 0; i < frame_size; ++i) - frame[i] = - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (frame_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); - comp.frame = frame; - - comp.func_blocks = CALLN (Fmake_hash_table); - - /* Pre declare all basic blocks to gcc. - The "entry" block must be declared as first. */ - declare_block (Qentry); - Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); - Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); - struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); - for (ptrdiff_t i = 0; i < ht->count; i++) - { - Lisp_Object block = HASH_VALUE (ht, i); - if (!EQ (block, entry_block)) - declare_block (HASH_KEY (ht, i)); - } - - for (ptrdiff_t i = 0; i < ht->count; i++) - { - Lisp_Object block_name = HASH_KEY (ht, i); - Lisp_Object block = HASH_VALUE (ht, i); - Lisp_Object insns = FUNCALL1 (comp-block-insns, block); - - comp.block = retrive_block (block_name); - while (CONSP (insns)) - { - Lisp_Object insn = XCAR (insns); - emit_limple_insn (insn); - insns = XCDR (insns); - } - } - - return Qt; -} - DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -2687,6 +2695,13 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); + /* Compile all functions. Can't be done before because the + relocation vectore has to be already compiled. */ + struct Lisp_Hash_Table *func_h + = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); + for (ptrdiff_t i = 0; i < func_h->count; i++) + compile_function (HASH_VALUE (func_h, i)); + if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); @@ -2967,7 +2982,6 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); - defsubr (&Scomp__add_func_to_ctxt); defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Snative_elisp_load); From 5ebc3fc47cfefb9f6726e9308f153c0df6941c12 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 19 Aug 2019 17:08:44 +0200 Subject: [PATCH 0293/1452] have subr name in limple --- lisp/emacs-lisp/comp.el | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9026bf7b532..32fc1866c0a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -328,10 +328,9 @@ If the callee function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) -(defmacro comp-emit-set-call-subr (subr-name sp-delta &optional c-fun-name) - "Emit a call for SUBR-NAME using C-FUN-NAME. -SP-DELTA is the stack adjustment. -If C-FUN-NAME is nil it will be guessed from SUBR-NAME." +(defmacro comp-emit-set-call-subr (subr-name sp-delta) + "Emit a call for SUBR-NAME. +SP-DELTA is the stack adjustment." (let ((subr (symbol-function subr-name)) (subr-str (symbol-name subr-name)) (nargs (1+ (- sp-delta)))) @@ -340,25 +339,19 @@ If C-FUN-NAME is nil it will be guessed from SUBR-NAME." (let* ((arity (subr-arity subr)) (minarg (car arity)) (maxarg (cdr arity))) - (unless c-fun-name - (setq c-fun-name - (intern (concat "F" - (replace-regexp-in-string - "-" "_" - subr-str))))) (cl-assert (not (eq maxarg 'unevalled)) nil "%s contains unevalled arg" subr-name) (if (eq maxarg 'many) ;; callref case. - `(comp-emit-set-call (list 'callref ',c-fun-name ,nargs (comp-sp))) + `(comp-emit-set-call (list 'callref ',subr-name ,nargs (comp-sp))) ;; Normal call. (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) (nargs maxarg minarg) "Incoherent stack adjustment %d, maxarg %d minarg %d") - `(let* ((c-fun-name ',c-fun-name) + `(let* ((subr-name ',subr-name) (slots (cl-loop for i from 0 below ,maxarg collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,c-fun-name ,@slots))))))) + (comp-emit-set-call `(call ,subr-name ,@slots))))))) (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. @@ -549,8 +542,7 @@ the annotation emission." ((pred symbolp) (list `(comp-emit-set-call-subr ,(car body) - ,sp-delta - ,(cadr body)))) + ,sp-delta))) (_ body)))) `(pcase op ,@(cl-loop for (op . body) in cases From 8bf2e4e282ff3c0661ebea70e574cce16bdcc356 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 19 Aug 2019 17:59:20 +0200 Subject: [PATCH 0294/1452] add and call comp-add-subr-to-relocs --- lisp/emacs-lisp/comp.el | 92 ++++++++++++++++++++++++----------------- 1 file changed, 55 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 32fc1866c0a..82e9e8a620c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -173,13 +173,21 @@ LIMPLE basic block.") (defun comp-add-const-to-relocs (obj) - "Keep track of OBJ into relocations. -The corresponding index into it is returned." + "Keep track of OBJ into the ctxt relocations. +The corresponding index is returned." (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) (unless (gethash obj data-relocs-idx) (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) +(defun comp-add-subr-to-relocs (subr-name) + "Keep track of SUBR-NAME into the ctxt relocations. +The corresponding index is returned." + (let ((funcs-relocs-idx (comp-ctxt-funcs-relocs-idx comp-ctxt))) + (unless (gethash subr-name funcs-relocs-idx) + (push subr-name (comp-ctxt-funcs-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count funcs-relocs-idx) funcs-relocs-idx)))) + (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -273,6 +281,16 @@ BODY is evaluate only if `comp-debug' is non nil." ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) +(defun comp-call (&rest args) + "Emit a call for ARGS." + (comp-add-subr-to-relocs (car args)) + `(call ,@args)) + +(defun comp-callref (&rest args) + "Emit a call usign narg abi for ARGS." + (comp-add-subr-to-relocs (car args)) + `(callref ,@args)) + (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." (let ((v (make-vector size nil))) @@ -351,7 +369,7 @@ SP-DELTA is the stack adjustment." `(let* ((subr-name ',subr-name) (slots (cl-loop for i from 0 below ,maxarg collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,subr-name ,@slots))))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. @@ -440,14 +458,14 @@ If NEGATED non nil negate the tested condition." (defun comp-limplify-listn (n) "Limplify list N." (comp-with-sp (+ (comp-sp) n -1) - (comp-emit-set-call `(call Fcons - ,(comp-slot) - ,(make-comp-mvar :constant nil)))) + (comp-emit-set-call (comp-call 'Fcons + (comp-slot) + (make-comp-mvar :constant nil)))) (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) do (comp-with-sp sp - (comp-emit-set-call `(call Fcons - ,(comp-slot) - ,(comp-slot-next)))))) + (comp-emit-set-call (comp-call 'Fcons + (comp-slot) + (comp-slot-next)))))) (defun comp-new-block-sym () "Return a symbol naming the next new basic block." @@ -575,21 +593,21 @@ the annotation emission." (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref - (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar - :constant arg)))) + (comp-emit-set-call (comp-call 'Fsymbol_value (make-comp-mvar + :constant arg)))) (byte-varset - (comp-emit `(call set_internal - ,(make-comp-mvar :constant arg) - ,(comp-slot)))) + (comp-emit (comp-call 'set_internal + (make-comp-mvar :constant arg) + (comp-slot)))) (byte-varbind ;; Verify - (comp-emit `(call specbind - ,(make-comp-mvar :constant arg) - ,(comp-slot-next)))) + (comp-emit (comp-call 'specbind + (make-comp-mvar :constant arg) + (comp-slot-next)))) (byte-call (comp-emit-funcall arg)) (byte-unbind - (comp-emit `(call helper_unbind_n - ,(make-comp-mvar :constant arg)))) + (comp-emit (comp-call 'helper_unbind_n + (make-comp-mvar :constant arg)))) (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase @@ -625,11 +643,11 @@ the annotation emission." (byte-get auto) (byte-substring auto) (byte-concat2 - (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat 2 (comp-sp)))) (byte-concat3 - (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat 3 (comp-sp)))) (byte-concat4 - (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat 4 (comp-sp)))) (byte-sub1 1- Fsub1) (byte-add1 1+ Fadd1) (byte-eqlsign = Feqlsign) @@ -639,7 +657,7 @@ the annotation emission." (byte-geq >= Fgeq) (byte-diff - Fminus) (byte-negate - (comp-emit-set-call `(call negate ,(comp-slot)))) + (comp-emit-set-call (comp-call 'negate (comp-slot)))) (byte-plus + Fplus) (byte-max auto) (byte-min auto) @@ -654,9 +672,9 @@ the annotation emission." (byte-preceding-char preceding-char Fprevious_char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call `(call Findent_to - ,(comp-slot) - ,(make-comp-mvar :constant nil)))) + (comp-emit-set-call (comp-call 'Findent_to + (comp-slot) + (make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) @@ -665,7 +683,7 @@ the annotation emission." (byte-current-buffer auto) (byte-set-buffer auto) (byte-save-current-buffer - (comp-emit '(call record_unwind_current_buffer))) + (comp-emit (comp-call 'record_unwind_current_buffer))) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) (byte-forward-char auto) @@ -677,11 +695,11 @@ the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call `(call Fnarrow_to_region - ,(comp-slot) - ,(comp-slot-next)))) + (comp-emit-set-call (comp-call 'Fnarrow_to_region + (comp-slot) + (comp-slot-next)))) (byte-widen - (comp-emit-set-call '(call Fwiden))) + (comp-emit-set-call (comp-call 'Fwiden))) (byte-end-of-line auto) (byte-constant2) ;; TODO (byte-goto @@ -705,13 +723,13 @@ the annotation emission." (byte-dup (comp-copy-slot (1- (comp-sp)))) (byte-save-excursion - (comp-emit '(call record_unwind_protect_excursion))) + (comp-emit (comp-call 'record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction - '(call helper-save-restriction)) + (comp-call 'helper-save-restriction)) (byte-catch) ;; Obsolete (byte-unwind-protect - (comp-emit `(call helper_unwind_protect ,(comp-slot-next)))) + (comp-emit (comp-call 'helper_unwind_protect (comp-slot-next)))) (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) @@ -740,13 +758,13 @@ the annotation emission." (byte-integerp auto) (byte-listN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call `(callref Flist ,arg ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Flist arg (comp-sp)))) (byte-concatN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat arg (comp-sp)))) (byte-insertN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call `(callref Finsert ,arg ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Finsert arg (comp-sp)))) (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) From 5e06f2fc31a12012d73ef741715a68e47f0c3a09 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 19 Aug 2019 18:22:26 +0200 Subject: [PATCH 0295/1452] some clean-up into comp.el --- lisp/emacs-lisp/comp.el | 70 ++++++++++++++++++++--------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 82e9e8a620c..3452fed9161 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,7 +54,7 @@ comp-limplify) "Passes to be executed in order.") -(defconst comp-known-ret-types '((Fcons . cons)) +(defconst comp-known-ret-types '((cons . cons)) "Alist used for type propagation.") (defconst comp-mostly-pure-funcs @@ -92,7 +92,7 @@ This is build before entering into `comp--compile-ctxt-to-file name'.") :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into data-relocs.") - (func-relocs () :type list + (func-relocs-l () :type list :documentation "Native functions imported.") (func-relocs-idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into func-relocs.")) @@ -183,10 +183,10 @@ The corresponding index is returned." (defun comp-add-subr-to-relocs (subr-name) "Keep track of SUBR-NAME into the ctxt relocations. The corresponding index is returned." - (let ((funcs-relocs-idx (comp-ctxt-funcs-relocs-idx comp-ctxt))) - (unless (gethash subr-name funcs-relocs-idx) - (push subr-name (comp-ctxt-funcs-relocs-l comp-ctxt)) - (puthash subr-name (hash-table-count funcs-relocs-idx) funcs-relocs-idx)))) + (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) + (unless (gethash subr-name func-relocs-idx) + (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -458,12 +458,12 @@ If NEGATED non nil negate the tested condition." (defun comp-limplify-listn (n) "Limplify list N." (comp-with-sp (+ (comp-sp) n -1) - (comp-emit-set-call (comp-call 'Fcons + (comp-emit-set-call (comp-call 'cons (comp-slot) (make-comp-mvar :constant nil)))) (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) do (comp-with-sp sp - (comp-emit-set-call (comp-call 'Fcons + (comp-emit-set-call (comp-call 'cons (comp-slot) (comp-slot-next)))))) @@ -593,8 +593,8 @@ the annotation emission." (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref - (comp-emit-set-call (comp-call 'Fsymbol_value (make-comp-mvar - :constant arg)))) + (comp-emit-set-call (comp-call 'symbol_value (make-comp-mvar + :constant arg)))) (byte-varset (comp-emit (comp-call 'set_internal (make-comp-mvar :constant arg) @@ -621,7 +621,7 @@ the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not null Fnull) + (byte-not null) (byte-car auto) (byte-cdr auto) (byte-cons auto) @@ -643,25 +643,25 @@ the annotation emission." (byte-get auto) (byte-substring auto) (byte-concat2 - (comp-emit-set-call (comp-callref 'Fconcat 2 (comp-sp)))) + (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) (byte-concat3 - (comp-emit-set-call (comp-callref 'Fconcat 3 (comp-sp)))) + (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) (byte-concat4 - (comp-emit-set-call (comp-callref 'Fconcat 4 (comp-sp)))) - (byte-sub1 1- Fsub1) - (byte-add1 1+ Fadd1) - (byte-eqlsign = Feqlsign) - (byte-gtr > Fgtr) - (byte-lss < Flss) - (byte-leq <= Fleq) - (byte-geq >= Fgeq) - (byte-diff - Fminus) + (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) + (byte-sub1 1-) + (byte-add1 1+) + (byte-eqlsign =) + (byte-gtr >) + (byte-lss <) + (byte-leq <=) + (byte-geq >=) + (byte-diff -) (byte-negate (comp-emit-set-call (comp-call 'negate (comp-slot)))) - (byte-plus + Fplus) + (byte-plus +) (byte-max auto) (byte-min auto) - (byte-mult * Ftimes) + (byte-mult *) (byte-point auto) (byte-goto-char auto) (byte-insert auto) @@ -669,10 +669,10 @@ the annotation emission." (byte-point-min auto) (byte-char-after auto) (byte-following-char auto) - (byte-preceding-char preceding-char Fprevious_char) + (byte-preceding-char preceding-char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call (comp-call 'Findent_to + (comp-emit-set-call (comp-call 'indent_to (comp-slot) (make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) @@ -695,11 +695,11 @@ the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call (comp-call 'Fnarrow_to_region + (comp-emit-set-call (comp-call 'narrow_to_region (comp-slot) (comp-slot-next)))) (byte-widen - (comp-emit-set-call (comp-call 'Fwiden))) + (comp-emit-set-call (comp-call 'widen))) (byte-end-of-line auto) (byte-constant2) ;; TODO (byte-goto @@ -739,8 +739,8 @@ the annotation emission." (byte-match-end auto) (byte-upcase auto) (byte-downcase auto) - (byte-string= string-equal Fstring_equal) - (byte-string< string-lessp Fstring_lessp) + (byte-string= string-equal) + (byte-string< string-lessp) (byte-equal auto) (byte-nthcdr auto) (byte-elt auto) @@ -752,19 +752,19 @@ the annotation emission." (byte-car-safe auto) (byte-cdr-safe auto) (byte-nconc auto) - (byte-quo / Fquo) - (byte-rem % Frem) + (byte-quo /) + (byte-rem %) (byte-numberp auto) (byte-integerp auto) (byte-listN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call (comp-callref 'Flist arg (comp-sp)))) + (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) (byte-concatN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call (comp-callref 'Fconcat arg (comp-sp)))) + (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) (byte-insertN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call (comp-callref 'Finsert arg (comp-sp)))) + (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) From 620794aa93107115b52f3622c7b6934ebc3fc8ac Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Aug 2019 12:17:56 +0200 Subject: [PATCH 0296/1452] emit function relocation name from comp.el --- lisp/emacs-lisp/comp.el | 32 ++++++++++++-------------------- 1 file changed, 12 insertions(+), 20 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3452fed9161..26a7373aa26 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -180,14 +180,6 @@ The corresponding index is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) -(defun comp-add-subr-to-relocs (subr-name) - "Keep track of SUBR-NAME into the ctxt relocations. -The corresponding index is returned." - (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) - (unless (gethash subr-name func-relocs-idx) - (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) - (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) - (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -221,8 +213,9 @@ BODY is evaluate only if `comp-debug' is non nil." ;;; spill-lap pass specific code. -(defun comp-c-func-name (symbol-function) - "Given SYMBOL-FUNCTION return a name suitable for the native code." +(defun comp-c-func-name (symbol-function prefix) + "Given SYMBOL-FUNCTION return a name suitable for the native code. +Put PREFIX in front of it." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: (let* ((orig-name (symbol-name symbol-function)) @@ -237,7 +230,7 @@ BODY is evaluate only if `comp-debug' is non nil." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - (concat "F" crypted "_" human-readable))) + (concat prefix crypted "_" human-readable))) (defun comp-decrypt-lambda-list (x) "Decript lambda list X." @@ -281,15 +274,13 @@ BODY is evaluate only if `comp-debug' is non nil." ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) -(defun comp-call (&rest args) - "Emit a call for ARGS." - (comp-add-subr-to-relocs (car args)) - `(call ,@args)) +(defun comp-call (func &rest args) + "Emit a call for function FUNC with ARGS." + `(call (,func . ,(comp-c-func-name func "R")) ,@args)) -(defun comp-callref (&rest args) - "Emit a call usign narg abi for ARGS." - (comp-add-subr-to-relocs (car args)) - `(callref ,@args)) +(defun comp-callref (func &rest args) + "Emit a call usign narg abi for FUNC with ARGS." + `(callref (,func . ,(comp-c-func-name func "R")) ,@args)) (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." @@ -876,7 +867,8 @@ the annotation emission." (let ((func (make-comp-func :symbol-name func-symbol-name :func f :c-func-name (comp-c-func-name - func-symbol-name))) + func-symbol-name + "F"))) (comp-ctxt (make-comp-ctxt))) (mapc (lambda (pass) (funcall pass func)) From d34eb7a39f15524dd13681864be14f85d15b4a0b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Aug 2019 21:20:27 +0200 Subject: [PATCH 0297/1452] reloc fist simple func --- lisp/emacs-lisp/comp.el | 10 +-- src/comp.c | 149 +++++++++++++++++++++++----------------- 2 files changed, 90 insertions(+), 69 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 26a7373aa26..972c1185871 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -213,12 +213,12 @@ BODY is evaluate only if `comp-debug' is non nil." ;;; spill-lap pass specific code. -(defun comp-c-func-name (symbol-function prefix) - "Given SYMBOL-FUNCTION return a name suitable for the native code. +(defun comp-c-func-name (symbol prefix) + "Given SYMBOL return a name suitable for the native code. Put PREFIX in front of it." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: - (let* ((orig-name (symbol-name symbol-function)) + (let* ((orig-name (symbol-name symbol)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 for i across orig-name @@ -276,11 +276,11 @@ Put PREFIX in front of it." (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." - `(call (,func . ,(comp-c-func-name func "R")) ,@args)) + `(call ,func ,@args)) (defun comp-callref (func &rest args) "Emit a call usign narg abi for FUNC with ARGS." - `(callref (,func . ,(comp-c-func-name func "R")) ,@args)) + `(callref ,func ,@args)) (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." diff --git a/src/comp.c b/src/comp.c index acf02e7c7cd..168db4636ba 100644 --- a/src/comp.c +++ b/src/comp.c @@ -58,7 +58,7 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (XCDR (XCDR (x)))) #define FUNCALL1(fun, arg) \ - CALLN (Ffuncall, intern (STR(fun)), arg) + CALLN (Ffuncall, intern_c_string (STR(fun)), arg) #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ @@ -270,15 +270,17 @@ emit_comment (const char *str) str); } -/* Declare a function with all args being Lisp_Object and returning a - Lisp_Object. */ +/* + Declare a function. If the function is imported then a function pointer is + stored into comp.func_hash for later reuse and NULL is returned. + If the function is exported the corresponding is returned. +*/ static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) + enum gcc_jit_function_kind kind) { - gcc_jit_param *param[nargs]; gcc_jit_type *type[nargs]; /* If args are passed types are extracted from that otherwise assume params */ @@ -290,59 +292,81 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, for (unsigned i = 0; i < nargs; i++) type[i] = comp.lisp_obj_type; - for (int i = nargs - 1; i >= 0; i--) - param[i] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[i], - format_string ("par_%d", i)); - - gcc_jit_function *func = - gcc_jit_context_new_function(comp.ctxt, NULL, - kind, - ret_type, - f_name, - nargs, - param, - 0); - - if (reusable) + switch (kind) { - Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = make_mint_ptr (func); - /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); + case GCC_JIT_FUNCTION_IMPORTED: + { + gcc_jit_type *f_ptr_type + = gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + type, + 0); + gcc_jit_lvalue *f_ptr + = gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + f_ptr_type, + f_name); + Lisp_Object key = make_string (f_name, strlen (f_name)); + Lisp_Object value = make_mint_ptr (f_ptr); + /* Don't want to declare the same function two times. */ + eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); + Fputhash (key, value, comp.func_hash); - Fputhash (key, value, comp.func_hash); + return NULL; + } + case GCC_JIT_FUNCTION_EXPORTED: + { + gcc_jit_param *param[nargs]; + for (int i = nargs - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + return gcc_jit_context_new_function(comp.ctxt, NULL, + kind, + ret_type, + f_name, + nargs, + param, + 0); + } + default: + eassert (false); + return NULL; } - - return func; } static gcc_jit_rvalue * -emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, +emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = Fgethash (key, comp.func_hash, Qnil); + /* String containing the function ptr. */ + Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); + Lisp_Object value = Fgethash (f_ptr_name, comp.func_hash, Qnil); if (NILP (value)) { - emit_func_declare (f_name, ret_type, nargs, args, - GCC_JIT_FUNCTION_IMPORTED, true); - value = Fgethash (key, comp.func_hash, Qnil); + emit_func_declare (SSDATA (f_ptr_name), ret_type, nargs, args, + GCC_JIT_FUNCTION_IMPORTED); + value = Fgethash (f_ptr_name, comp.func_hash, Qnil); eassert (!NILP (value)); } - gcc_jit_function *func = (gcc_jit_function *) xmint_pointer (value); - - return gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - nargs, - args); + gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (value); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr(comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); } static gcc_jit_rvalue * -emit_call_ref (const char *f_name, unsigned nargs, +emit_call_ref (Lisp_Object subr_sym, unsigned nargs, gcc_jit_lvalue *base_arg) { gcc_jit_rvalue *args[] = @@ -350,7 +374,7 @@ emit_call_ref (const char *f_name, unsigned nargs, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (f_name, comp.lisp_obj_type, 2, args); + return emit_call (subr_sym, comp.lisp_obj_type, 2, args); } /* Close current basic block emitting a conditional. */ @@ -1011,7 +1035,8 @@ emit_set_internal (Lisp_Object args) gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - return emit_call ("set_internal", comp.void_type , 4, gcc_args); + return emit_call (intern_c_string ("set_internal"), comp.void_type , 4, + gcc_args); } /* This is for a regular function with arguments as m-var. */ @@ -1020,7 +1045,7 @@ static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { int i = 0; - char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + Lisp_Object callee = FIRST (args); args = XCDR (args); ptrdiff_t nargs = list_length (args); gcc_jit_rvalue *gcc_args[nargs]; @@ -1054,7 +1079,6 @@ static gcc_jit_rvalue * emit_limple_call (Lisp_Object insn) { Lisp_Object callee_sym = FIRST (insn); - char *callee = (char *) SDATA (SYMBOL_NAME (callee_sym)); Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) @@ -1062,12 +1086,8 @@ emit_limple_call (Lisp_Object insn) gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); return emitter_ptr (insn); } - else if (callee[0] == 'F') - { - return emit_simple_limple_call_lisp_ret (insn); - } - error ("LIMPLE call is inconsistent"); + return emit_simple_limple_call_lisp_ret (insn); } static gcc_jit_rvalue * @@ -1075,7 +1095,7 @@ emit_limple_call_ref (Lisp_Object insn) { /* Ex: (callref Fplus 2 0). */ - char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (insn))); + Lisp_Object callee = FIRST (insn); EMACS_UINT nargs = XFIXNUM (SECOND (insn)); EMACS_UINT base_ptr = XFIXNUM (THIRD (insn)); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); @@ -1106,7 +1126,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, comp.block, NULL, c, - emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + emit_call (intern_c_string ("push_handler"), comp.handler_ptr_type, 2, args)); args[0] = gcc_jit_lvalue_get_address ( @@ -1118,9 +1138,9 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue *res; #ifdef HAVE__SETJMP - res = emit_call ("_setjmp", comp.int_type, 1, args); + res = emit_call (intern_c_string ("_setjmp"), comp.int_type, 1, args); #else - res = emit_call ("setjmp", comp.int_type, 1, args); + res = emit_call (intern_c_string ("setjmp"), comp.int_type, 1, args); #endif emit_cond_jump (res, handler_bb, guarded_bb); @@ -1322,7 +1342,7 @@ emit_limple_insn (Lisp_Object insn) n), gcc_jit_lvalue_as_rvalue (args) }; - res = emit_call ("Flist", comp.lisp_obj_type, 2, + res = emit_call (Qlist, comp.lisp_obj_type, 2, list_args); gcc_jit_block_add_assignment (comp.block, @@ -1929,7 +1949,7 @@ define_CHECK_TYPE (void) gcc_jit_block_add_eval (comp.block, NULL, - emit_call ("wrong_type_argument", + emit_call (intern_c_string ("wrong_type_argument"), comp.lisp_obj_type, 2, wrong_type_args)); gcc_jit_block_end_with_void_return (not_ok_block, NULL); @@ -2011,7 +2031,7 @@ define_CAR_CDR (void) gcc_jit_block_add_eval (comp.block, NULL, - emit_call ("wrong_type_argument", + emit_call (intern_c_string ("wrong_type_argument"), comp.lisp_obj_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block, NULL, @@ -2098,7 +2118,7 @@ define_add1_sub1 (void) gcc_jit_function *func[2]; char const *f_name[] = {"add1", "sub1"}; - char const *fall_back_func[] = {"Fadd1", "Fsub1"}; + char const *fall_back_func[] = {"1+", "1-"}; gcc_jit_rvalue *compare[] = { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = @@ -2160,7 +2180,7 @@ define_add1_sub1 (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call (fall_back_func[i], + gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]), comp.lisp_obj_type, 1, &n); gcc_jit_block_end_with_return (fcall_block, NULL, @@ -2234,7 +2254,7 @@ define_negate (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call_ref ("Fminus", 1, n); + gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); @@ -2292,7 +2312,7 @@ define_PSEUDOVECTORP (void) gcc_jit_block_end_with_return (call_pseudovector_typep_b , NULL, - emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", + emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), comp.bool_type, 2, args)); @@ -2337,7 +2357,7 @@ define_CHECK_IMPURE (void) comp.block = err_block; gcc_jit_block_add_eval (comp.block, NULL, - emit_call ("pure_write_error", + emit_call (intern_c_string ("pure_write_error"), comp.void_type, 1, &pure_write_error_arg)); @@ -2397,7 +2417,7 @@ compile_function (Lisp_Object func) EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); comp.func = emit_func_declare (c_name, comp.lisp_obj_type, max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); + NULL, GCC_JIT_FUNCTION_EXPORTED); } else { @@ -2702,6 +2722,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); + /* FIXME use format_String here */ if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); From ed2d884872ab18e38ac7d8ba17e1d3a3446029e8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Aug 2019 23:28:02 +0200 Subject: [PATCH 0298/1452] seems to emit all relocs --- src/comp.c | 150 ++++++++++++++++++++++++++++------------------------- 1 file changed, 78 insertions(+), 72 deletions(-) diff --git a/src/comp.c b/src/comp.c index 168db4636ba..3491d5127d6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -147,7 +147,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object func_hash; /* f_name -> gcc_func. */ + Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; } comp_t; @@ -270,19 +270,10 @@ emit_comment (const char *str) str); } -/* - Declare a function. If the function is imported then a function pointer is - stored into comp.func_hash for later reuse and NULL is returned. - If the function is exported the corresponding is returned. -*/ - -static gcc_jit_function * -emit_func_declare (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind) +static void +fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, + unsigned nargs) { - gcc_jit_type *type[nargs]; - /* If args are passed types are extracted from that otherwise assume params */ /* are all lisp objs. */ if (args) @@ -291,71 +282,76 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, else for (unsigned i = 0; i < nargs; i++) type[i] = comp.lisp_obj_type; +} - switch (kind) - { - case GCC_JIT_FUNCTION_IMPORTED: - { - gcc_jit_type *f_ptr_type - = gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - ret_type, - nargs, - type, - 0); - gcc_jit_lvalue *f_ptr - = gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - f_ptr_type, - f_name); - Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = make_mint_ptr (f_ptr); - /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); - Fputhash (key, value, comp.func_hash); +static void +declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args) +{ + /* Don't want to declare the same function two times. */ + eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); - return NULL; - } - case GCC_JIT_FUNCTION_EXPORTED: - { - gcc_jit_param *param[nargs]; - for (int i = nargs - 1; i >= 0; i--) - param[i] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[i], - format_string ("par_%d", i)); - return gcc_jit_context_new_function(comp.ctxt, NULL, - kind, - ret_type, - f_name, - nargs, - param, - 0); - } - default: - eassert (false); - return NULL; - } + gcc_jit_type *type[nargs]; + fill_declaration_types (type, args, nargs); + + /* String containing the function ptr. */ + Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); + + + gcc_jit_type *f_ptr_type + = gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + type, + 0); + gcc_jit_lvalue *f_ptr + = gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + f_ptr_type, + SSDATA (f_ptr_name)); + Lisp_Object value = Fcons (make_mint_ptr (f_ptr), subr_sym); + Fputhash (subr_sym, value, comp.func_hash); +} + +static gcc_jit_function * +declare_func_exported (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args) +{ + gcc_jit_type *type[nargs]; + + fill_declaration_types (type, args, nargs); + + gcc_jit_param *param[nargs]; + for (int i = nargs - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + return gcc_jit_context_new_function(comp.ctxt, NULL, + GCC_JIT_GLOBAL_EXPORTED, + ret_type, + f_name, + nargs, + param, + 0); } static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - /* String containing the function ptr. */ - Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); - Lisp_Object value = Fgethash (f_ptr_name, comp.func_hash, Qnil); + Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); if (NILP (value)) { - emit_func_declare (SSDATA (f_ptr_name), ret_type, nargs, args, - GCC_JIT_FUNCTION_IMPORTED); - value = Fgethash (f_ptr_name, comp.func_hash, Qnil); + declare_imported_func (subr_sym, ret_type, nargs, args); + value = Fgethash (subr_sym, comp.func_hash, Qnil); eassert (!NILP (value)); } - gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (value); + gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (XCAR (value)); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr(comp.ctxt, @@ -1554,7 +1550,7 @@ emit_ctxt_code (void) emit_litteral_string_func ("text_data_relocs", d_reloc); const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_litteral_string_func ("text_funcs", func_list); + emit_litteral_string_func ("text_exported_funcs", func_list); } @@ -2415,9 +2411,8 @@ compile_function (Lisp_Object func) if (!ncall) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - comp.func = - emit_func_declare (c_name, comp.lisp_obj_type, max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED); + comp.func + = declare_func_exported (c_name, comp.lisp_obj_type, max_args, NULL); } else { @@ -2645,7 +2640,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. */ - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); + comp.func_hash = CALLN (Fmake_hash_table); /* Define data structures. */ @@ -2722,7 +2717,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); - /* FIXME use format_String here */ + /* FIXME wrap me */ + struct Lisp_Hash_Table *fh = XHASH_TABLE (comp.func_hash); + Lisp_Object f_reloc = make_vector (fh->count, Qnil); + for (ptrdiff_t i = 0; i < fh->count; i++) + { + Lisp_Object subr_sym = (XCDR (HASH_VALUE (fh, i))); + ASET (f_reloc, i, subr_sym); + } + emit_litteral_string_func ("text_imported_funcs", + (SSDATA (Fprin1_to_string (f_reloc, Qnil)))); + + /* FIXME use format_string here */ if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); @@ -2899,7 +2905,7 @@ load_comp_unit (dynlib_handle_ptr handle) prevent_gc (data_relocs[i]); } - Lisp_Object func_list = retrive_litteral_obj (handle, "text_funcs"); + Lisp_Object func_list = retrive_litteral_obj (handle, "text_exported_funcs"); while (func_list) { From cf0053a66a8055e05e9842c41f60c2130f4dd642 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 22 Aug 2019 11:40:41 +0200 Subject: [PATCH 0299/1452] some renaming --- src/comp.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3491d5127d6..5c8106a78e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -156,7 +156,6 @@ static comp_t comp; FILE *logfile = NULL; - Lisp_Object helper_save_window_excursion (Lisp_Object v1); @@ -294,10 +293,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, gcc_jit_type *type[nargs]; fill_declaration_types (type, args, nargs); - /* String containing the function ptr. */ - Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); - + /* String containing the function ptr name. */ + Lisp_Object f_ptr_name + = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); gcc_jit_type *f_ptr_type = gcc_jit_context_new_function_ptr_type (comp.ctxt, @@ -317,7 +316,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, } static gcc_jit_function * -declare_func_exported (const char *f_name, gcc_jit_type *ret_type, +declare_exported_func (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { gcc_jit_type *type[nargs]; @@ -2412,7 +2411,7 @@ compile_function (Lisp_Object func) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); comp.func - = declare_func_exported (c_name, comp.lisp_obj_type, max_args, NULL); + = declare_exported_func (c_name, comp.lisp_obj_type, max_args, NULL); } else { From ad5488cad62b04ff1ae28cbbe2a0dcb2af817f27 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 22 Aug 2019 16:00:43 +0200 Subject: [PATCH 0300/1452] emit function relocation into structure --- lisp/emacs-lisp/comp.el | 13 ++++++- src/comp.c | 84 ++++++++++++++++++++++++++++------------- 2 files changed, 69 insertions(+), 28 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 972c1185871..a14438e250c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -80,8 +80,7 @@ "This structure is to serve al relocation creation for the current compiler context." (funcs () :type list - :documentation "Alist lisp-func-name -> c-func-name. -This is build before entering into `comp--compile-ctxt-to-file name'.") + :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") @@ -180,6 +179,14 @@ The corresponding index is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) +(defun comp-add-subr-to-relocs (subr-name) + "Keep track of SUBR-NAME into the ctxt relocations. +The corresponding index is returned." + (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) + (unless (gethash subr-name func-relocs-idx) + (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) + (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -276,10 +283,12 @@ Put PREFIX in front of it." (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." + (comp-add-subr-to-relocs func) `(call ,func ,@args)) (defun comp-callref (func &rest args) "Emit a call usign narg abi for FUNC with ARGS." + (comp-add-subr-to-relocs func) `(callref ,func ,@args)) (defun comp-new-frame (size) diff --git a/src/comp.c b/src/comp.c index 5c8106a78e4..1a2984bb72e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -150,6 +150,7 @@ typedef struct { Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; + gcc_jit_lvalue *func_relocs; } comp_t; static comp_t comp; @@ -283,7 +284,7 @@ fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, type[i] = comp.lisp_obj_type; } -static void +static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { @@ -305,14 +306,15 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, nargs, type, 0); - gcc_jit_lvalue *f_ptr - = gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - f_ptr_type, - SSDATA (f_ptr_name)); - Lisp_Object value = Fcons (make_mint_ptr (f_ptr), subr_sym); + gcc_jit_field *field + = gcc_jit_context_new_field (comp.ctxt, + NULL, + f_ptr_type, + SSDATA (f_ptr_name)); + + Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); Fputhash (subr_sym, value, comp.func_hash); + return field; } static gcc_jit_function * @@ -343,14 +345,12 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); + eassert (!NILP (value)); - if (NILP (value)) - { - declare_imported_func (subr_sym, ret_type, nargs, args); - value = Fgethash (subr_sym, comp.func_hash, Qnil); - eassert (!NILP (value)); - } - gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (XCAR (value)); + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (XCAR (value))); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr(comp.ctxt, @@ -1529,6 +1529,8 @@ This emit the code needed by every compilation unit to be loaded. static void emit_ctxt_code (void) { + /* Imported objects. */ + const char *d_reloc = SSDATA (FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt)); EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, @@ -1548,6 +1550,37 @@ emit_ctxt_code (void) emit_litteral_string_func ("text_data_relocs", d_reloc); + /* Imported functions. */ + Lisp_Object f_reloc = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); + EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_reloc)); + gcc_jit_field *fields[f_reloc_len]; + int i = 0; + FOR_EACH_TAIL (f_reloc) + { + Lisp_Object subr_sym = XCAR (f_reloc); + Lisp_Object subr = Fsymbol_function (subr_sym); + gcc_jit_field *field + = declare_imported_func (subr_sym, comp.lisp_obj_type, + XFIXNUM (XCDR (Fsubr_arity (subr))), NULL); + fields [i++] = field; + } + eassert (f_reloc_len == i); + + gcc_jit_struct *f_reloc_struct + = gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "function_reloc_struct", + f_reloc_len, + fields); + comp.func_relocs + = gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_struct_as_type (f_reloc_struct), + "f_reloc"); + + /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); emit_litteral_string_func ("text_exported_funcs", func_list); } @@ -2658,17 +2691,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.void_ptr_type, pure); - /* Define inline functions. */ - - define_CAR_CDR(); - define_PSEUDOVECTORP (); - define_CHECK_TYPE (); - define_CHECK_IMPURE (); - define_bool_to_lisp_obj (); - define_setcar_setcdr (); - define_add1_sub1 (); - define_negate (); - return Qt; } @@ -2709,6 +2731,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); + /* /\* Define inline functions. *\/ */ + /* define_CAR_CDR(); */ + /* define_PSEUDOVECTORP (); */ + /* define_CHECK_TYPE (); */ + /* define_CHECK_IMPURE (); */ + /* define_bool_to_lisp_obj (); */ + /* define_setcar_setcdr (); */ + /* define_add1_sub1 (); */ + /* define_negate (); */ + /* Compile all functions. Can't be done before because the relocation vectore has to be already compiled. */ struct Lisp_Hash_Table *func_h From 9413488ab4e8752a2fe88ce9f42ca83ffbe5f1a8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 31 Aug 2019 17:06:45 +0200 Subject: [PATCH 0301/1452] reloc emission mechanism seems ok --- src/comp.c | 236 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 151 insertions(+), 85 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1a2984bb72e..d7e82845454 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,8 +149,8 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ Lisp_Object emitter_dispatcher; - gcc_jit_rvalue *data_relocs; - gcc_jit_lvalue *func_relocs; + gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ + gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ } comp_t; static comp_t comp; @@ -270,6 +270,58 @@ emit_comment (const char *str) str); } +/* + Declare an imported function. + When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed. + When types is NULL types is assumed to be all Lisp_Objects. +*/ +static gcc_jit_field * +declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, + int nargs, gcc_jit_type **types) +{ + /* Don't want to declare the same function two times. */ + eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); + + if (nargs == MANY) + { + nargs = 2; + types = alloca (nargs * sizeof (* types)); + types[0] = comp.ptrdiff_type; + types[1] = comp.lisp_obj_type; + } + else if (!types) + { + types = alloca (nargs * sizeof (* types)); + for (unsigned i = 0; i < nargs; i++) + types[i] = comp.lisp_obj_type; + } + + eassert (types); + + /* String containing the function ptr name. */ + Lisp_Object f_ptr_name = + CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); + + gcc_jit_type *f_ptr_type = + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + types, + 0); + gcc_jit_field *field = + gcc_jit_context_new_field (comp.ctxt, + NULL, + f_ptr_type, + SSDATA (f_ptr_name)); + + + Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); + Fputhash (subr_sym, value, comp.func_hash); + return field; +} + static void fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, unsigned nargs) @@ -284,39 +336,6 @@ fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, type[i] = comp.lisp_obj_type; } -static gcc_jit_field * -declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args) -{ - /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); - - gcc_jit_type *type[nargs]; - fill_declaration_types (type, args, nargs); - - /* String containing the function ptr name. */ - Lisp_Object f_ptr_name - = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); - - gcc_jit_type *f_ptr_type - = gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - ret_type, - nargs, - type, - 0); - gcc_jit_field *field - = gcc_jit_context_new_field (comp.ctxt, - NULL, - f_ptr_type, - SSDATA (f_ptr_name)); - - Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); - Fputhash (subr_sym, value, comp.func_hash); - return field; -} - static gcc_jit_function * declare_exported_func (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) @@ -351,6 +370,9 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_lvalue_access_field (comp.func_relocs, NULL, (gcc_jit_field *) xmint_pointer (XCAR (value))); + if (!f_ptr) + error ("Undeclared function relocation."); + emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr(comp.ctxt, @@ -1523,6 +1545,38 @@ emit_litteral_string_func (const char *str_name, const char *str) gcc_jit_block_end_with_return (block, NULL, res); } +/* + Declare as imported all the functions that are requested from the runtime. + These are either subrs or not. +*/ +static Lisp_Object +declare_runtime_imported (void) +{ + /* For subr imported by the runtime we rely on the standard mechanism in place + for functions imported by lisp code. */ + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1+")); + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("+")); + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("-")); + + Lisp_Object field_list = Qnil; +#define ADD_IMPORTED(f_name, ret_type, nargs, args) \ + { \ + Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object field = \ + make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ + field_list = Fcons (field, field_list); \ + } while (0) + + ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); + gcc_jit_type *args[] = {comp.lisp_obj_type, comp.int_type}; + ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); +#undef ADD_IMPORTED + + return field_list; +} + /* This emit the code needed by every compilation unit to be loaded. */ @@ -1536,49 +1590,61 @@ emit_ctxt_code (void) XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - comp.data_relocs - = gcc_jit_lvalue_as_rvalue( - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - d_reloc_len), - "data_relocs")); + comp.data_relocs = + gcc_jit_lvalue_as_rvalue( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + "data_relocs")); emit_litteral_string_func ("text_data_relocs", d_reloc); - /* Imported functions. */ - Lisp_Object f_reloc = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); - EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_reloc)); + /* Imported functions from non Lisp code. */ + Lisp_Object f_runtime = declare_runtime_imported (); + EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_runtime)); + + /* Imported subrs. */ + Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); + f_reloc_len += XFIXNUM (Flength (f_subr)); + gcc_jit_field *fields[f_reloc_len]; int i = 0; - FOR_EACH_TAIL (f_reloc) + + FOR_EACH_TAIL (f_runtime) { - Lisp_Object subr_sym = XCAR (f_reloc); + fields[i++] = xmint_pointer( XCAR (f_runtime)); + } + + FOR_EACH_TAIL (f_subr) + { + Lisp_Object subr_sym = XCAR (f_subr); Lisp_Object subr = Fsymbol_function (subr_sym); - gcc_jit_field *field - = declare_imported_func (subr_sym, comp.lisp_obj_type, - XFIXNUM (XCDR (Fsubr_arity (subr))), NULL); + Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); + gcc_jit_field *field = + declare_imported_func (subr_sym, comp.lisp_obj_type, + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); fields [i++] = field; } eassert (f_reloc_len == i); - gcc_jit_struct *f_reloc_struct - = gcc_jit_context_new_struct_type (comp.ctxt, - NULL, - "function_reloc_struct", - f_reloc_len, - fields); - comp.func_relocs - = gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_struct_as_type (f_reloc_struct), - "f_reloc"); + gcc_jit_struct *f_reloc_struct = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "function_reloc_struct", + f_reloc_len, + fields); + comp.func_relocs = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_struct_as_type (f_reloc_struct), + "f_reloc"); /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); @@ -2332,18 +2398,18 @@ define_PSEUDOVECTORP (void) comp.bool_type, false)); - gcc_jit_rvalue *args[2] = + gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; comp.block = call_pseudovector_typep_b; /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b - , - NULL, - emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), - comp.bool_type, - 2, - args)); + gcc_jit_block_end_with_return ( + call_pseudovector_typep_b, + NULL, + emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), + comp.bool_type, + 2, + args)); } static void @@ -2731,18 +2797,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); - /* /\* Define inline functions. *\/ */ - /* define_CAR_CDR(); */ - /* define_PSEUDOVECTORP (); */ - /* define_CHECK_TYPE (); */ - /* define_CHECK_IMPURE (); */ - /* define_bool_to_lisp_obj (); */ - /* define_setcar_setcdr (); */ - /* define_add1_sub1 (); */ - /* define_negate (); */ + /* Define inline functions. */ + define_CAR_CDR(); + define_PSEUDOVECTORP (); + define_CHECK_TYPE (); + define_CHECK_IMPURE (); + define_bool_to_lisp_obj (); + define_setcar_setcdr (); + define_add1_sub1 (); + define_negate (); /* Compile all functions. Can't be done before because the - relocation vectore has to be already compiled. */ + relocation structs has to be already defined. */ struct Lisp_Hash_Table *func_h = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) From dc52036074c46d1772557436cda2866b346b4d16 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 10:35:10 +0200 Subject: [PATCH 0302/1452] improve reloc mechanism --- src/comp.c | 74 +++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 56 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index d7e82845454..0f8c9648cdf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -46,6 +46,13 @@ along with GNU Emacs. If not, see . */ #define CONST_PROP_MAX 0 +/* C symbols emited for the load relocation mechanism. */ +#define DATA_RELOC_SYM "d_reloc" +#define IMPORTED_FUNC_RELOC_SYM "f_reloc" +#define TEXT_DATA_RELOC_SYM "text_data_reloc" +#define TEXT_EXPORTED_FUNC_RELOC_SYM "text_exported_funcs" +#define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" + #define STR(s) #s #define FIRST(x) \ @@ -147,7 +154,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ + Lisp_Object func_hash; /* subr_name -> reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -287,7 +294,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, nargs = 2; types = alloca (nargs * sizeof (* types)); types[0] = comp.ptrdiff_type; - types[1] = comp.lisp_obj_type; + types[1] = comp.lisp_obj_ptr_type; } else if (!types) { @@ -316,9 +323,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, f_ptr_type, SSDATA (f_ptr_name)); - - Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); - Fputhash (subr_sym, value, comp.func_hash); + Fputhash (subr_sym, make_mint_ptr (field), comp.func_hash); return field; } @@ -369,7 +374,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_lvalue *f_ptr = gcc_jit_lvalue_access_field (comp.func_relocs, NULL, - (gcc_jit_field *) xmint_pointer (XCAR (value))); + (gcc_jit_field *) xmint_pointer (value)); if (!f_ptr) error ("Undeclared function relocation."); @@ -1556,8 +1561,8 @@ declare_runtime_imported (void) for functions imported by lisp code. */ FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1+")); FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("+")); - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("-")); + FUNCALL1 (comp-add-subr-to-relocs, Qplus); + FUNCALL1 (comp-add-subr-to-relocs, Qminus); Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ @@ -1600,9 +1605,9 @@ emit_ctxt_code (void) NULL, comp.lisp_obj_type, d_reloc_len), - "data_relocs")); + DATA_RELOC_SYM)); - emit_litteral_string_func ("text_data_relocs", d_reloc); + emit_litteral_string_func (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported (); @@ -1644,11 +1649,11 @@ emit_ctxt_code (void) NULL, GCC_JIT_GLOBAL_EXPORTED, gcc_jit_struct_as_type (f_reloc_struct), - "f_reloc"); + IMPORTED_FUNC_RELOC_SYM); /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_litteral_string_func ("text_exported_funcs", func_list); + emit_litteral_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); } @@ -2044,7 +2049,7 @@ define_CHECK_TYPE (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.lisp_obj_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args)); gcc_jit_block_end_with_void_return (not_ok_block, NULL); } @@ -2126,7 +2131,7 @@ define_CAR_CDR (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.lisp_obj_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block, NULL, emit_lisp_obj_from_ptr (Qnil)); @@ -2819,7 +2824,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Lisp_Object f_reloc = make_vector (fh->count, Qnil); for (ptrdiff_t i = 0; i < fh->count; i++) { - Lisp_Object subr_sym = (XCDR (HASH_VALUE (fh, i))); + Lisp_Object subr_sym = HASH_KEY (fh, i); ASET (f_reloc, i, subr_sym); } emit_litteral_string_func ("text_imported_funcs", @@ -2984,6 +2989,7 @@ static Lisp_Object retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) { comp_litt_str_func f = dynlib_sym (handle, str_name); + eassert (f); char *res = f(); return Fread (build_string (res)); } @@ -2991,9 +2997,10 @@ retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) static int load_comp_unit (dynlib_handle_ptr handle) { - Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); + /* Imported data. */ + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = retrive_litteral_obj (handle, "text_data_relocs"); + Lisp_Object d_vec = retrive_litteral_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3002,7 +3009,38 @@ load_comp_unit (dynlib_handle_ptr handle) prevent_gc (data_relocs[i]); } - Lisp_Object func_list = retrive_litteral_obj (handle, "text_exported_funcs"); + /* Imported functions. */ + Lisp_Object (**f_relocs)(void) = + dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + Lisp_Object f_vec = + retrive_litteral_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); + for (EMACS_UINT i = 0; i < f_vec_len; i++) + { + Lisp_Object f_sym = AREF (f_vec, i); + char *f_str = SSDATA (SYMBOL_NAME (f_sym)); + Lisp_Object subr = Fsymbol_function (f_sym); + if (!NILP (subr)) + { + eassert (SUBRP (subr)); + f_relocs[i] = XSUBR (subr)->function.a0; + } else if (!strcmp (f_str, "wrong_type_argument")) + { + f_relocs[i] = (void *) wrong_type_argument; + } else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) + { + f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; + } else if (!strcmp (f_str, "pure_write_error")) + { + f_relocs[i] = (void *) pure_write_error; + } else + { + error ("Unexpected function relocation %s", f_str); + } + } + + /* Exported functions. */ + Lisp_Object func_list = retrive_litteral_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); while (func_list) { From e3163f1d4cec335b5941c9bea267fe161c5ab83d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 11:06:12 +0200 Subject: [PATCH 0303/1452] Revert "Create bytecode.h" This reverts commit c91954e5bb6365b72ad5654e932bc374a66fb4af. --- src/bytecode.c | 207 +++++++++++++++++++++++++++++++++++++++++++- src/bytecode.h | 230 ------------------------------------------------- src/lisp.h | 2 - 3 files changed, 206 insertions(+), 233 deletions(-) delete mode 100644 src/bytecode.h diff --git a/src/bytecode.c b/src/bytecode.c index e11704fd8b0..9e75c9012e0 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -27,7 +27,6 @@ along with GNU Emacs. If not, see . */ #include "ptr-bounds.h" #include "syntax.h" #include "window.h" -#include "bytecode.h" /* Work around GCC bug 54561. */ #if GNUC_PREREQ (4, 3, 0) @@ -78,6 +77,212 @@ along with GNU Emacs. If not, see . */ #endif /* BYTE_CODE_METER */ +/* Byte codes: */ + +#define BYTE_CODES \ +DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ +DEFINE (Bstack_ref1, 1) \ +DEFINE (Bstack_ref2, 2) \ +DEFINE (Bstack_ref3, 3) \ +DEFINE (Bstack_ref4, 4) \ +DEFINE (Bstack_ref5, 5) \ +DEFINE (Bstack_ref6, 6) \ +DEFINE (Bstack_ref7, 7) \ +DEFINE (Bvarref, 010) \ +DEFINE (Bvarref1, 011) \ +DEFINE (Bvarref2, 012) \ +DEFINE (Bvarref3, 013) \ +DEFINE (Bvarref4, 014) \ +DEFINE (Bvarref5, 015) \ +DEFINE (Bvarref6, 016) \ +DEFINE (Bvarref7, 017) \ +DEFINE (Bvarset, 020) \ +DEFINE (Bvarset1, 021) \ +DEFINE (Bvarset2, 022) \ +DEFINE (Bvarset3, 023) \ +DEFINE (Bvarset4, 024) \ +DEFINE (Bvarset5, 025) \ +DEFINE (Bvarset6, 026) \ +DEFINE (Bvarset7, 027) \ +DEFINE (Bvarbind, 030) \ +DEFINE (Bvarbind1, 031) \ +DEFINE (Bvarbind2, 032) \ +DEFINE (Bvarbind3, 033) \ +DEFINE (Bvarbind4, 034) \ +DEFINE (Bvarbind5, 035) \ +DEFINE (Bvarbind6, 036) \ +DEFINE (Bvarbind7, 037) \ +DEFINE (Bcall, 040) \ +DEFINE (Bcall1, 041) \ +DEFINE (Bcall2, 042) \ +DEFINE (Bcall3, 043) \ +DEFINE (Bcall4, 044) \ +DEFINE (Bcall5, 045) \ +DEFINE (Bcall6, 046) \ +DEFINE (Bcall7, 047) \ +DEFINE (Bunbind, 050) \ +DEFINE (Bunbind1, 051) \ +DEFINE (Bunbind2, 052) \ +DEFINE (Bunbind3, 053) \ +DEFINE (Bunbind4, 054) \ +DEFINE (Bunbind5, 055) \ +DEFINE (Bunbind6, 056) \ +DEFINE (Bunbind7, 057) \ + \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ +DEFINE (Bnth, 070) \ +DEFINE (Bsymbolp, 071) \ +DEFINE (Bconsp, 072) \ +DEFINE (Bstringp, 073) \ +DEFINE (Blistp, 074) \ +DEFINE (Beq, 075) \ +DEFINE (Bmemq, 076) \ +DEFINE (Bnot, 077) \ +DEFINE (Bcar, 0100) \ +DEFINE (Bcdr, 0101) \ +DEFINE (Bcons, 0102) \ +DEFINE (Blist1, 0103) \ +DEFINE (Blist2, 0104) \ +DEFINE (Blist3, 0105) \ +DEFINE (Blist4, 0106) \ +DEFINE (Blength, 0107) \ +DEFINE (Baref, 0110) \ +DEFINE (Baset, 0111) \ +DEFINE (Bsymbol_value, 0112) \ +DEFINE (Bsymbol_function, 0113) \ +DEFINE (Bset, 0114) \ +DEFINE (Bfset, 0115) \ +DEFINE (Bget, 0116) \ +DEFINE (Bsubstring, 0117) \ +DEFINE (Bconcat2, 0120) \ +DEFINE (Bconcat3, 0121) \ +DEFINE (Bconcat4, 0122) \ +DEFINE (Bsub1, 0123) \ +DEFINE (Badd1, 0124) \ +DEFINE (Beqlsign, 0125) \ +DEFINE (Bgtr, 0126) \ +DEFINE (Blss, 0127) \ +DEFINE (Bleq, 0130) \ +DEFINE (Bgeq, 0131) \ +DEFINE (Bdiff, 0132) \ +DEFINE (Bnegate, 0133) \ +DEFINE (Bplus, 0134) \ +DEFINE (Bmax, 0135) \ +DEFINE (Bmin, 0136) \ +DEFINE (Bmult, 0137) \ + \ +DEFINE (Bpoint, 0140) \ +/* Was Bmark in v17. */ \ +DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ +DEFINE (Bgoto_char, 0142) \ +DEFINE (Binsert, 0143) \ +DEFINE (Bpoint_max, 0144) \ +DEFINE (Bpoint_min, 0145) \ +DEFINE (Bchar_after, 0146) \ +DEFINE (Bfollowing_char, 0147) \ +DEFINE (Bpreceding_char, 0150) \ +DEFINE (Bcurrent_column, 0151) \ +DEFINE (Bindent_to, 0152) \ +DEFINE (Beolp, 0154) \ +DEFINE (Beobp, 0155) \ +DEFINE (Bbolp, 0156) \ +DEFINE (Bbobp, 0157) \ +DEFINE (Bcurrent_buffer, 0160) \ +DEFINE (Bset_buffer, 0161) \ +DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ +DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bforward_char, 0165) \ +DEFINE (Bforward_word, 0166) \ +DEFINE (Bskip_chars_forward, 0167) \ +DEFINE (Bskip_chars_backward, 0170) \ +DEFINE (Bforward_line, 0171) \ +DEFINE (Bchar_syntax, 0172) \ +DEFINE (Bbuffer_substring, 0173) \ +DEFINE (Bdelete_region, 0174) \ +DEFINE (Bnarrow_to_region, 0175) \ +DEFINE (Bwiden, 0176) \ +DEFINE (Bend_of_line, 0177) \ + \ +DEFINE (Bconstant2, 0201) \ +DEFINE (Bgoto, 0202) \ +DEFINE (Bgotoifnil, 0203) \ +DEFINE (Bgotoifnonnil, 0204) \ +DEFINE (Bgotoifnilelsepop, 0205) \ +DEFINE (Bgotoifnonnilelsepop, 0206) \ +DEFINE (Breturn, 0207) \ +DEFINE (Bdiscard, 0210) \ +DEFINE (Bdup, 0211) \ + \ +DEFINE (Bsave_excursion, 0212) \ +DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Bsave_restriction, 0214) \ +DEFINE (Bcatch, 0215) \ + \ +DEFINE (Bunwind_protect, 0216) \ +DEFINE (Bcondition_case, 0217) \ +DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ + \ +DEFINE (Bset_marker, 0223) \ +DEFINE (Bmatch_beginning, 0224) \ +DEFINE (Bmatch_end, 0225) \ +DEFINE (Bupcase, 0226) \ +DEFINE (Bdowncase, 0227) \ + \ +DEFINE (Bstringeqlsign, 0230) \ +DEFINE (Bstringlss, 0231) \ +DEFINE (Bequal, 0232) \ +DEFINE (Bnthcdr, 0233) \ +DEFINE (Belt, 0234) \ +DEFINE (Bmember, 0235) \ +DEFINE (Bassq, 0236) \ +DEFINE (Bnreverse, 0237) \ +DEFINE (Bsetcar, 0240) \ +DEFINE (Bsetcdr, 0241) \ +DEFINE (Bcar_safe, 0242) \ +DEFINE (Bcdr_safe, 0243) \ +DEFINE (Bnconc, 0244) \ +DEFINE (Bquo, 0245) \ +DEFINE (Brem, 0246) \ +DEFINE (Bnumberp, 0247) \ +DEFINE (Bintegerp, 0250) \ + \ +DEFINE (BRgoto, 0252) \ +DEFINE (BRgotoifnil, 0253) \ +DEFINE (BRgotoifnonnil, 0254) \ +DEFINE (BRgotoifnilelsepop, 0255) \ +DEFINE (BRgotoifnonnilelsepop, 0256) \ + \ +DEFINE (BlistN, 0257) \ +DEFINE (BconcatN, 0260) \ +DEFINE (BinsertN, 0261) \ + \ +/* Bstack_ref is code 0. */ \ +DEFINE (Bstack_set, 0262) \ +DEFINE (Bstack_set2, 0263) \ +DEFINE (BdiscardN, 0266) \ + \ +DEFINE (Bswitch, 0267) \ + \ +DEFINE (Bconstant, 0300) + +enum byte_code_op +{ +#define DEFINE(name, value) name = value, + BYTE_CODES +#undef DEFINE + +#if BYTE_CODE_SAFE + Bscan_buffer = 0153, /* No longer generated as of v18. */ + Bset_mark = 0163, /* this loser is no longer generated as of v18 */ +#endif +}; /* Fetch the next byte from the bytecode stream. */ diff --git a/src/bytecode.h b/src/bytecode.h deleted file mode 100644 index 07452eb1851..00000000000 --- a/src/bytecode.h +++ /dev/null @@ -1,230 +0,0 @@ -/* Byte code definitions - Copyright (C) 1985-1988, 1993, 2000-2018 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 . */ - -#ifndef EMACS_BYTECODE_H -#define EMACS_BYTECODE_H - -/* Byte codes: */ - -#define BYTE_CODES \ -DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ -DEFINE (Bstack_ref1, 1) \ -DEFINE (Bstack_ref2, 2) \ -DEFINE (Bstack_ref3, 3) \ -DEFINE (Bstack_ref4, 4) \ -DEFINE (Bstack_ref5, 5) \ -DEFINE (Bstack_ref6, 6) \ -DEFINE (Bstack_ref7, 7) \ -DEFINE (Bvarref, 010) \ -DEFINE (Bvarref1, 011) \ -DEFINE (Bvarref2, 012) \ -DEFINE (Bvarref3, 013) \ -DEFINE (Bvarref4, 014) \ -DEFINE (Bvarref5, 015) \ -DEFINE (Bvarref6, 016) \ -DEFINE (Bvarref7, 017) \ -DEFINE (Bvarset, 020) \ -DEFINE (Bvarset1, 021) \ -DEFINE (Bvarset2, 022) \ -DEFINE (Bvarset3, 023) \ -DEFINE (Bvarset4, 024) \ -DEFINE (Bvarset5, 025) \ -DEFINE (Bvarset6, 026) \ -DEFINE (Bvarset7, 027) \ -DEFINE (Bvarbind, 030) \ -DEFINE (Bvarbind1, 031) \ -DEFINE (Bvarbind2, 032) \ -DEFINE (Bvarbind3, 033) \ -DEFINE (Bvarbind4, 034) \ -DEFINE (Bvarbind5, 035) \ -DEFINE (Bvarbind6, 036) \ -DEFINE (Bvarbind7, 037) \ -DEFINE (Bcall, 040) \ -DEFINE (Bcall1, 041) \ -DEFINE (Bcall2, 042) \ -DEFINE (Bcall3, 043) \ -DEFINE (Bcall4, 044) \ -DEFINE (Bcall5, 045) \ -DEFINE (Bcall6, 046) \ -DEFINE (Bcall7, 047) \ -DEFINE (Bunbind, 050) \ -DEFINE (Bunbind1, 051) \ -DEFINE (Bunbind2, 052) \ -DEFINE (Bunbind3, 053) \ -DEFINE (Bunbind4, 054) \ -DEFINE (Bunbind5, 055) \ -DEFINE (Bunbind6, 056) \ -DEFINE (Bunbind7, 057) \ - \ -DEFINE (Bpophandler, 060) \ -DEFINE (Bpushconditioncase, 061) \ -DEFINE (Bpushcatch, 062) \ - \ -DEFINE (Bnth, 070) \ -DEFINE (Bsymbolp, 071) \ -DEFINE (Bconsp, 072) \ -DEFINE (Bstringp, 073) \ -DEFINE (Blistp, 074) \ -DEFINE (Beq, 075) \ -DEFINE (Bmemq, 076) \ -DEFINE (Bnot, 077) \ -DEFINE (Bcar, 0100) \ -DEFINE (Bcdr, 0101) \ -DEFINE (Bcons, 0102) \ -DEFINE (Blist1, 0103) \ -DEFINE (Blist2, 0104) \ -DEFINE (Blist3, 0105) \ -DEFINE (Blist4, 0106) \ -DEFINE (Blength, 0107) \ -DEFINE (Baref, 0110) \ -DEFINE (Baset, 0111) \ -DEFINE (Bsymbol_value, 0112) \ -DEFINE (Bsymbol_function, 0113) \ -DEFINE (Bset, 0114) \ -DEFINE (Bfset, 0115) \ -DEFINE (Bget, 0116) \ -DEFINE (Bsubstring, 0117) \ -DEFINE (Bconcat2, 0120) \ -DEFINE (Bconcat3, 0121) \ -DEFINE (Bconcat4, 0122) \ -DEFINE (Bsub1, 0123) \ -DEFINE (Badd1, 0124) \ -DEFINE (Beqlsign, 0125) \ -DEFINE (Bgtr, 0126) \ -DEFINE (Blss, 0127) \ -DEFINE (Bleq, 0130) \ -DEFINE (Bgeq, 0131) \ -DEFINE (Bdiff, 0132) \ -DEFINE (Bnegate, 0133) \ -DEFINE (Bplus, 0134) \ -DEFINE (Bmax, 0135) \ -DEFINE (Bmin, 0136) \ -DEFINE (Bmult, 0137) \ - \ -DEFINE (Bpoint, 0140) \ -/* Was Bmark in v17. */ \ -DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ -DEFINE (Bgoto_char, 0142) \ -DEFINE (Binsert, 0143) \ -DEFINE (Bpoint_max, 0144) \ -DEFINE (Bpoint_min, 0145) \ -DEFINE (Bchar_after, 0146) \ -DEFINE (Bfollowing_char, 0147) \ -DEFINE (Bpreceding_char, 0150) \ -DEFINE (Bcurrent_column, 0151) \ -DEFINE (Bindent_to, 0152) \ -DEFINE (Beolp, 0154) \ -DEFINE (Beobp, 0155) \ -DEFINE (Bbolp, 0156) \ -DEFINE (Bbobp, 0157) \ -DEFINE (Bcurrent_buffer, 0160) \ -DEFINE (Bset_buffer, 0161) \ -DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ -DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bforward_char, 0165) \ -DEFINE (Bforward_word, 0166) \ -DEFINE (Bskip_chars_forward, 0167) \ -DEFINE (Bskip_chars_backward, 0170) \ -DEFINE (Bforward_line, 0171) \ -DEFINE (Bchar_syntax, 0172) \ -DEFINE (Bbuffer_substring, 0173) \ -DEFINE (Bdelete_region, 0174) \ -DEFINE (Bnarrow_to_region, 0175) \ -DEFINE (Bwiden, 0176) \ -DEFINE (Bend_of_line, 0177) \ - \ -DEFINE (Bconstant2, 0201) \ -DEFINE (Bgoto, 0202) \ -DEFINE (Bgotoifnil, 0203) \ -DEFINE (Bgotoifnonnil, 0204) \ -DEFINE (Bgotoifnilelsepop, 0205) \ -DEFINE (Bgotoifnonnilelsepop, 0206) \ -DEFINE (Breturn, 0207) \ -DEFINE (Bdiscard, 0210) \ -DEFINE (Bdup, 0211) \ - \ -DEFINE (Bsave_excursion, 0212) \ -DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ - \ -DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ -DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ - \ -DEFINE (Bset_marker, 0223) \ -DEFINE (Bmatch_beginning, 0224) \ -DEFINE (Bmatch_end, 0225) \ -DEFINE (Bupcase, 0226) \ -DEFINE (Bdowncase, 0227) \ - \ -DEFINE (Bstringeqlsign, 0230) \ -DEFINE (Bstringlss, 0231) \ -DEFINE (Bequal, 0232) \ -DEFINE (Bnthcdr, 0233) \ -DEFINE (Belt, 0234) \ -DEFINE (Bmember, 0235) \ -DEFINE (Bassq, 0236) \ -DEFINE (Bnreverse, 0237) \ -DEFINE (Bsetcar, 0240) \ -DEFINE (Bsetcdr, 0241) \ -DEFINE (Bcar_safe, 0242) \ -DEFINE (Bcdr_safe, 0243) \ -DEFINE (Bnconc, 0244) \ -DEFINE (Bquo, 0245) \ -DEFINE (Brem, 0246) \ -DEFINE (Bnumberp, 0247) \ -DEFINE (Bintegerp, 0250) \ - \ -DEFINE (BRgoto, 0252) \ -DEFINE (BRgotoifnil, 0253) \ -DEFINE (BRgotoifnonnil, 0254) \ -DEFINE (BRgotoifnilelsepop, 0255) \ -DEFINE (BRgotoifnonnilelsepop, 0256) \ - \ -DEFINE (BlistN, 0257) \ -DEFINE (BconcatN, 0260) \ -DEFINE (BinsertN, 0261) \ - \ -/* Bstack_ref is code 0. */ \ -DEFINE (Bstack_set, 0262) \ -DEFINE (Bstack_set2, 0263) \ -DEFINE (BdiscardN, 0266) \ - \ -DEFINE (Bswitch, 0267) \ - \ -DEFINE (Bconstant, 0300) - -enum byte_code_op -{ -#define DEFINE(name, value) name = value, - BYTE_CODES -#undef DEFINE - -#if BYTE_CODE_SAFE - Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163, /* this loser is no longer generated as of v18 */ -#endif -}; - -#endif /* EMACS_BYTECODE_H */ diff --git a/src/lisp.h b/src/lisp.h index 6f0177436d8..93a3ddea0cb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,8 +2096,6 @@ union Aligned_Lisp_Subr }; verify (GCALIGNED (union Aligned_Lisp_Subr)); -#define SUBR_MAX_ARGS 9 - INLINE bool SUBRP (Lisp_Object a) { From 4c03c46946d95a7e9079a087b5e0e835f5a5beac Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 11:06:27 +0200 Subject: [PATCH 0304/1452] Revert "Move native C code into shared library" This reverts commit 613f4156880bc6c3d56ebe0297e59f805d2a69ab. --- lib/Makefile.in | 4 +--- src/Makefile.in | 50 +++++++++++++++++++++---------------------------- src/emacs.c | 2 +- src/main.c | 26 ------------------------- 4 files changed, 23 insertions(+), 59 deletions(-) delete mode 100644 src/main.c diff --git a/lib/Makefile.in b/lib/Makefile.in index ed3123885d2..06d8e56421b 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -26,8 +26,6 @@ abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ -CFLAGS = -fPIC @CFLAGS@ - all: .PHONY: all @@ -52,7 +50,7 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = -ALL_CFLAGS= -fPIC \ +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 \ diff --git a/src/Makefile.in b/src/Makefile.in index 8e3712709e5..5e0e36d8b4d 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -33,7 +33,7 @@ top_srcdir = @top_srcdir@ abs_top_srcdir=@abs_top_srcdir@ VPATH = $(srcdir) CC = @CC@ -CFLAGS = @CFLAGS@ -fPIC +CFLAGS = @CFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ EXEEXT = @EXEEXT@ @@ -465,7 +465,7 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) # Must be first, before dep inclusion! -all: $(pdmp) $(OTHER_FILES) +all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) .PHONY: all dmpstruct_headers=$(srcdir)/lisp.h $(srcdir)/buffer.h \ @@ -644,33 +644,25 @@ else MAKE_PDUMPER_FINGERPRINT = endif -## FIXME: dumper support totally missing here -libemacs.so: $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ - $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) main.o - $(CC) --shared -o $@ $(ALLOBJS) -Wl,-Bstatic $(LIBEGNU_ARCHIVE) -Wl,-Bdynamic $(LIBES) - -temacs$(EXEEXT): libemacs.so main.o - $(CC) -L. main.o -o $@ $(TEMACS_LDFLAGS) $(LDFLAGS) \ - $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lemacs -Wl,-rpath -Wl,$(shell pwd) - -# ## We have to create $(etc) here because init_cmdargs tests its -# ## existence when setting Vinstallation_directory (FIXME?). -# ## This goes on to affect various things, and the emacs binary fails -# ## to start if Vinstallation_directory has the wrong value. -# temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ -# $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) -# $(AM_V_CCLD)$(CC) -o $@.tmp \ -# $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ -# $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -# ifeq ($(HAVE_PDUMPER),yes) -# $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp -# endif -# $(AM_V_at)mv $@.tmp $@ -# $(MKDIR_P) $(etc) -# ifeq ($(DUMPING),unexec) -# ifneq ($(PAXCTL_notdumped),) -# $(PAXCTL_notdumped) $@ -# endif +## We have to create $(etc) here because init_cmdargs tests its +## existence when setting Vinstallation_directory (FIXME?). +## This goes on to affect various things, and the emacs binary fails +## to start if Vinstallation_directory has the wrong value. +temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ + $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) + $(AM_V_CCLD)$(CC) -o $@.tmp \ + $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ + $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) +ifeq ($(HAVE_PDUMPER),yes) + $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp +endif + $(AM_V_at)mv $@.tmp $@ + $(MKDIR_P) $(etc) +ifeq ($(DUMPING),unexec) + ifneq ($(PAXCTL_notdumped),) + $(PAXCTL_notdumped) $@ + endif +endif ## The following oldxmenu-related rules are only (possibly) used if ## HAVE_X11 && !USE_GTK, but there is no harm in always defining them. diff --git a/src/emacs.c b/src/emacs.c index 1491ba5a479..c59a70988b7 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -924,7 +924,7 @@ load_pdump (int argc, char **argv) #endif /* HAVE_PDUMPER */ int -main1 (int argc, char **argv) +main (int argc, char **argv) { /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ diff --git a/src/main.c b/src/main.c deleted file mode 100644 index 41e35534280..00000000000 --- a/src/main.c +++ /dev/null @@ -1,26 +0,0 @@ -/* Trampoline for GNU Emacs. - Copyright (C) 2019 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 . */ - -extern int main1 (int argc, char **argv); - -int -main (int argc, char **argv) -{ - return main1(argc, argv); -} From 3b696d1cdcc79505313b2f087fbf742e503a1998 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 11:07:11 +0200 Subject: [PATCH 0305/1452] Revert "Make block_atimers unblock_atimers extern" This reverts commit 4266794ceb30ba8c3465fb8568695f53b676247d. --- src/atimer.c | 33 ++++++++++++++++----------------- src/atimer.h | 2 -- 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/src/atimer.c b/src/atimer.c index 4b0cab14530..a7daf9dcf5b 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -65,6 +65,22 @@ enum { timerfd = -1 }; # endif #endif +/* Block/unblock SIGALRM. */ + +static void +block_atimers (sigset_t *oldset) +{ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, oldset); +} +static void +unblock_atimers (sigset_t const *oldset) +{ + pthread_sigmask (SIG_SETMASK, oldset, 0); +} /* Function prototypes. */ @@ -149,23 +165,6 @@ start_atimer (enum atimer_type type, struct timespec timestamp, return t; } -/* Block/unblock SIGALRM. */ - -void -block_atimers (sigset_t *oldset) -{ - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - pthread_sigmask (SIG_BLOCK, &blocked, oldset); -} - -void -unblock_atimers (sigset_t const *oldset) -{ - pthread_sigmask (SIG_SETMASK, oldset, 0); -} /* Cancel and free atimer TIMER. */ diff --git a/src/atimer.h b/src/atimer.h index 58209168afb..660d77c9392 100644 --- a/src/atimer.h +++ b/src/atimer.h @@ -71,8 +71,6 @@ struct atimer struct atimer *start_atimer (enum atimer_type, struct timespec, atimer_callback, void *); -void block_atimers (sigset_t *); -void unblock_atimers (sigset_t const *); void cancel_atimer (struct atimer *); void do_pending_atimers (void); void init_atimer (void); From a2257a531d0cd4c1d2bbfe374f490fa956be0330 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 11:22:35 +0200 Subject: [PATCH 0306/1452] add NATIVE_ELISP_SUFFIX def into congure.ac --- configure.ac | 2 ++ 1 file changed, 2 insertions(+) diff --git a/configure.ac b/configure.ac index d059b7d6724..6213051a602 100644 --- a/configure.ac +++ b/configure.ac @@ -3678,6 +3678,8 @@ if test "${with_nativecomp}" != "no"; then if test "${HAVE_LIBGCCJIT}" = "yes"; then LIBGCCJIT_LIB=-lgccjit AC_DEFINE([HAVE_LIBGCCJIT], 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) fi fi AC_SUBST([LIBGCCJIT_LIB]) From a2b1795b96b5ac5981220b1056f6ea222bc193f5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 11:23:00 +0200 Subject: [PATCH 0307/1452] clean-up unnecessary includes --- src/comp.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0f8c9648cdf..b1083355607 100644 --- a/src/comp.c +++ b/src/comp.c @@ -27,9 +27,6 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "puresize.h" -#include "buffer.h" -#include "bytecode.h" -#include "atimer.h" #include "window.h" #include "dynlib.h" From c698ac791b3755c340ff945c137f6732cd4e20e4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 11:58:20 +0200 Subject: [PATCH 0308/1452] add authorship --- lisp/emacs-lisp/comp.el | 2 ++ src/comp.c | 2 ++ 2 files changed, 4 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a14438e250c..3bd4aa31312 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1,5 +1,7 @@ ;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- +;; Author: Andrea Corallo + ;; Copyright (C) 2019 Free Software Foundation, Inc. ;; Keywords: lisp diff --git a/src/comp.c b/src/comp.c index b1083355607..bf1ff3be5d5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,6 +1,8 @@ /* Compile byte code produced by bytecomp.el into native code. Copyright (C) 2019 Free Software Foundation, Inc. +Author: Andrea Corallo + This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify From a102f471b3973d46d6954bc31c6170ddffd508da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 12:29:13 +0200 Subject: [PATCH 0309/1452] emit relocs for callref too --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3bd4aa31312..631003da1dd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -363,7 +363,7 @@ SP-DELTA is the stack adjustment." "%s contains unevalled arg" subr-name) (if (eq maxarg 'many) ;; callref case. - `(comp-emit-set-call (list 'callref ',subr-name ,nargs (comp-sp))) + `(comp-emit-set-call (comp-callref ',subr-name ,nargs (comp-sp))) ;; Normal call. (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) (nargs maxarg minarg) @@ -533,13 +533,13 @@ NARG is the number of Ffuncall arguments." )) (if optimize (if callref - (comp-emit-set-call `(callref ,callee-sym-name - ,narg ,(1+ (comp-sp)))) + (comp-emit-set-call (comp-callref callee-sym-name + narg (1+ (comp-sp)))) (comp-emit-set-call `(call ,callee-sym-name ,@(cl-loop for i from (1+ (comp-sp)) repeat narg collect (comp-slot-n i))))) - (comp-emit-set-call `(callref Ffuncall ,(1+ narg) ,(comp-sp)))))) + (comp-emit-set-call (comp-callref 'funcall (1+ narg) (comp-sp)))))) (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. From 90425b6d4b314f8f4c26cbf61ec24fdffec4c0f7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 12:40:54 +0200 Subject: [PATCH 0310/1452] better messaging when load native elisp --- src/lread.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/lread.c b/src/lread.c index 1a5074cb70b..b10743f980c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1534,6 +1534,8 @@ Return t if the file exists and loads successfully. */) file, 1); else 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) From 76021e1e06c5c1af05b658310505da333bc0c214 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 12:52:05 +0200 Subject: [PATCH 0311/1452] always release contex even in case of failure --- lisp/emacs-lisp/comp.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 631003da1dd..e9f9cd2db45 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -886,10 +886,11 @@ the annotation emission." comp-passes) ;; Once we have the final LIMPLE we jump into C. (comp--init-ctxt) - (comp-add-func-to-ctxt func) - (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) - ;; (comp-compile-and-load-ctxt) - (comp--release-ctxt))) + (unwind-protect + (progn + (comp-add-func-to-ctxt func) + (comp-compile-ctxt-to-file (symbol-name func-symbol-name))) + (comp--release-ctxt)))) (error "Trying to native compile something not a function"))) (provide 'comp) From bfc298ca31d11c09d49d792a88a9f72415bb4513 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 14:27:11 +0200 Subject: [PATCH 0312/1452] style fix in emit_limple_push_handler --- src/comp.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index bf1ff3be5d5..77b160c096d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1132,7 +1132,6 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ - gcc_jit_rvalue *args[2]; /* struct handler *c = push_handler (POP, type); */ gcc_jit_lvalue *c = @@ -1141,8 +1140,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, comp.handler_ptr_type, format_string ("c_%u", pushhandler_n)); - args[0] = handler; - args[1] = handler_type; + + gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( comp.block, NULL, From 999e625bc94d08eadf92d42d5bb0fd6f6d35c268 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 14:46:29 +0200 Subject: [PATCH 0313/1452] adding runtime relocs --- src/comp.c | 50 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 36 insertions(+), 14 deletions(-) diff --git a/src/comp.c b/src/comp.c index 77b160c096d..ae53fce380e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -52,7 +52,8 @@ along with GNU Emacs. If not, see . */ #define TEXT_EXPORTED_FUNC_RELOC_SYM "text_exported_funcs" #define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" -#define STR(s) #s +#define STR_VALUE(s) #s +#define STR(s) STR_VALUE (s) #define FIRST(x) \ XCAR(x) @@ -70,6 +71,13 @@ along with GNU Emacs. If not, see . */ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR(name)) +#ifdef HAVE__SETJMP +#define SETJMP _setjmp +#else +#define SETJMP setjmp +#endif +#define SETJMP_NAME STR (SETJMP) + /* C side of the compiler context. */ typedef struct { @@ -1157,11 +1165,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, NULL); gcc_jit_rvalue *res; -#ifdef HAVE__SETJMP - res = emit_call (intern_c_string ("_setjmp"), comp.int_type, 1, args); -#else - res = emit_call (intern_c_string ("setjmp"), comp.int_type, 1, args); -#endif + res = emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args); emit_cond_jump (res, handler_bb, guarded_bb); /* This emit the handler part. */ @@ -1561,20 +1565,32 @@ declare_runtime_imported (void) FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); FUNCALL1 (comp-add-subr-to-relocs, Qplus); FUNCALL1 (comp-add-subr-to-relocs, Qminus); + FUNCALL1 (comp-add-subr-to-relocs, Qlist); Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ - { \ - Lisp_Object name = intern_c_string (f_name); \ - Lisp_Object field = \ - make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ - field_list = Fcons (field, field_list); \ - } while (0) - + { \ + Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object field = \ + make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ + field_list = Fcons (field, field_list); \ + } while (0) + gcc_jit_type *args[2]; ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); - gcc_jit_type *args[] = {comp.lisp_obj_type, comp.int_type}; + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; + ADD_IMPORTED ("push_handler", comp.handler_ptr_type, 2, args); + + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); + #undef ADD_IMPORTED return field_list; @@ -3031,6 +3047,12 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "pure_write_error")) { f_relocs[i] = (void *) pure_write_error; + } else if (!strcmp (f_str, "push_handler")) + { + f_relocs[i] = (void *) push_handler; + } else if (!strcmp (f_str, SETJMP_NAME)) + { + f_relocs[i] = (void *) SETJMP; } else { error ("Unexpected function relocation %s", f_str); From b9b5cf4196e7a5368c5e36c0c5e0364b5d3e15b3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 15:35:31 +0200 Subject: [PATCH 0314/1452] ignore inliners while relocating --- src/comp.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index ae53fce380e..9dac0f9c8e8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1642,21 +1642,23 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_subr) { Lisp_Object subr_sym = XCAR (f_subr); - Lisp_Object subr = Fsymbol_function (subr_sym); - Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); - gcc_jit_field *field = - declare_imported_func (subr_sym, comp.lisp_obj_type, - FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); - fields [i++] = field; + /* Ignore inliners. This are not real functions to be imported. */ + if (NILP (Fgethash (subr_sym, comp.emitter_dispatcher, Qnil))) + { + Lisp_Object subr = Fsymbol_function (subr_sym); + Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); + gcc_jit_field *field = + declare_imported_func (subr_sym, comp.lisp_obj_type, + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); + fields [i++] = field; + } } - eassert (f_reloc_len == i); gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "function_reloc_struct", - f_reloc_len, - fields); + i, fields); comp.func_relocs = gcc_jit_context_new_global ( comp.ctxt, @@ -3139,7 +3141,7 @@ syms_of_comp (void) DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); /* call operands. */ - DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */ DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); From 895bb4c9112c715a1bfa66d9af0d945f4719db55 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 16:16:25 +0200 Subject: [PATCH 0315/1452] fix func reloc order emission --- src/comp.c | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9dac0f9c8e8..6837100651c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -274,7 +274,6 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } - INLINE static void emit_comment (const char *str) { @@ -1573,7 +1572,8 @@ declare_runtime_imported (void) Lisp_Object name = intern_c_string (f_name); \ Lisp_Object field = \ make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ - field_list = Fcons (field, field_list); \ + Lisp_Object el = Fcons (name, field); \ + field_list = Fcons (el, field_list); \ } while (0) gcc_jit_type *args[2]; ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); @@ -1632,11 +1632,14 @@ emit_ctxt_code (void) f_reloc_len += XFIXNUM (Flength (f_subr)); gcc_jit_field *fields[f_reloc_len]; - int i = 0; + Lisp_Object f_reloc_list = Qnil; + int n_frelocs = 0; FOR_EACH_TAIL (f_runtime) { - fields[i++] = xmint_pointer( XCAR (f_runtime)); + Lisp_Object el = XCAR (f_runtime); + fields[n_frelocs++] = xmint_pointer( XCDR (el)); + f_reloc_list = Fcons (XCAR (el), f_reloc_list); } FOR_EACH_TAIL (f_subr) @@ -1650,15 +1653,26 @@ emit_ctxt_code (void) gcc_jit_field *field = declare_imported_func (subr_sym, comp.lisp_obj_type, FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); - fields [i++] = field; + fields [n_frelocs++] = field; + f_reloc_list = Fcons (subr_sym, f_reloc_list); } } + Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); + f_reloc_list = Freverse (f_reloc_list); + ptrdiff_t i = 0; + FOR_EACH_TAIL (f_reloc_list) + { + ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); + } + emit_litteral_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, + (SSDATA (Fprin1_to_string (f_reloc_vec, Qnil)))); + gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "function_reloc_struct", - i, fields); + n_frelocs, fields); comp.func_relocs = gcc_jit_context_new_global ( comp.ctxt, @@ -2835,17 +2849,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); - /* FIXME wrap me */ - struct Lisp_Hash_Table *fh = XHASH_TABLE (comp.func_hash); - Lisp_Object f_reloc = make_vector (fh->count, Qnil); - for (ptrdiff_t i = 0; i < fh->count; i++) - { - Lisp_Object subr_sym = HASH_KEY (fh, i); - ASET (f_reloc, i, subr_sym); - } - emit_litteral_string_func ("text_imported_funcs", - (SSDATA (Fprin1_to_string (f_reloc, Qnil)))); - /* FIXME use format_string here */ if (COMP_DEBUG) { From 94c542da1ac13fc6052d02fc7b960176c09bbaa8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 16:49:42 +0200 Subject: [PATCH 0316/1452] add more runtime helpers --- src/comp.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/comp.c b/src/comp.c index 6837100651c..f428a440b05 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1591,6 +1591,11 @@ declare_runtime_imported (void) args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); + ADD_IMPORTED ("record_unwind_protect_excursion", comp.void_type, 0, NULL); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + #undef ADD_IMPORTED return field_list; @@ -3058,6 +3063,12 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, SETJMP_NAME)) { f_relocs[i] = (void *) SETJMP; + } else if (!strcmp (f_str, "record_unwind_protect_excursion")) + { + f_relocs[i] = (void *) record_unwind_protect_excursion; + } else if (!strcmp (f_str, "helper_unbind_n")) + { + f_relocs[i] = (void *) helper_unbind_n; } else { error ("Unexpected function relocation %s", f_str); From 6df64d170a93970fd57932980fceed6bf1853ccb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 17:02:35 +0200 Subject: [PATCH 0317/1452] fix relocation emission into comp.el --- lisp/emacs-lisp/comp.el | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e9f9cd2db45..65944e5dd86 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -177,7 +177,8 @@ LIMPLE basic block.") "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) - (unless (gethash obj data-relocs-idx) + (if-let ((idx (gethash obj data-relocs-idx))) + idx (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) @@ -185,7 +186,8 @@ The corresponding index is returned." "Keep track of SUBR-NAME into the ctxt relocations. The corresponding index is returned." (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) - (unless (gethash subr-name func-relocs-idx) + (if-let ((idx (gethash subr-name func-relocs-idx))) + idx (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) @@ -392,6 +394,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." (let ((rel-idx (comp-add-const-to-relocs val))) + (cl-assert (numberp rel-idx)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :constant val)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) @@ -848,7 +851,9 @@ the annotation emission." (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h for args = (comp-func-args f) - for doc = (aref (comp-func-byte-func f) 4) + for doc = (when (> (length (comp-func-byte-func f)) + 4) + (aref (comp-func-byte-func f) 4)) collect (vector (comp-func-symbol-name f) (comp-func-c-func-name f) (cons (comp-args-base-min args) From 211db146a2f475047b38b010ea55c27c08701114 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Sep 2019 17:16:13 +0200 Subject: [PATCH 0318/1452] add record_unwind_current_buffer as imported --- src/comp.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index f428a440b05..58f86322ac1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see . */ #include "puresize.h" #include "window.h" #include "dynlib.h" +#include "buffer.h" #define DEFAULT_SPEED 2 /* See comp-speed var. */ @@ -172,19 +173,16 @@ static comp_t comp; FILE *logfile = NULL; +/* + Helper functions called by the runtime. +*/ Lisp_Object helper_save_window_excursion (Lisp_Object v1); - void helper_unwind_protect (Lisp_Object handler); - Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); - Lisp_Object helper_unbind_n (Lisp_Object n); - bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); - void helper_emit_save_restriction (void); - void helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs); @@ -1596,6 +1594,8 @@ declare_runtime_imported (void) args[0] = comp.lisp_obj_type; ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + #undef ADD_IMPORTED return field_list; @@ -3069,6 +3069,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "helper_unbind_n")) { f_relocs[i] = (void *) helper_unbind_n; + } else if (!strcmp (f_str, "record_unwind_current_buffer")) + { + f_relocs[i] = (void *) record_unwind_current_buffer; } else { error ("Unexpected function relocation %s", f_str); From e672990d882ce53167b22969eec6b32e96503573 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 10:33:06 +0200 Subject: [PATCH 0319/1452] typo fixes --- src/comp.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 58f86322ac1..62b0dd0732e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1536,7 +1536,7 @@ emit_integerp (Lisp_Object insn) */ static void -emit_litteral_string_func (const char *str_name, const char *str) +emit_literal_string_func (const char *str_name, const char *str) { gcc_jit_function *f = gcc_jit_context_new_function (comp.ctxt, NULL, @@ -1626,7 +1626,7 @@ emit_ctxt_code (void) d_reloc_len), DATA_RELOC_SYM)); - emit_litteral_string_func (TEXT_DATA_RELOC_SYM, d_reloc); + emit_literal_string_func (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported (); @@ -1670,7 +1670,7 @@ emit_ctxt_code (void) { ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); } - emit_litteral_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, + emit_literal_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, (SSDATA (Fprin1_to_string (f_reloc_vec, Qnil)))); gcc_jit_struct *f_reloc_struct = @@ -1688,7 +1688,7 @@ emit_ctxt_code (void) /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_litteral_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); + emit_literal_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); } @@ -2729,10 +2729,10 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (EMACS_INT), true); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.emacs_int_type, - "num"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "num"); gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; @@ -3010,7 +3010,7 @@ prevent_gc (Lisp_Object obj) } static Lisp_Object -retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) +retrive_literal_obj (dynlib_handle_ptr handle, const char *str_name) { comp_litt_str_func f = dynlib_sym (handle, str_name); eassert (f); @@ -3024,7 +3024,7 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = retrive_litteral_obj (handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = retrive_literal_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3037,7 +3037,7 @@ load_comp_unit (dynlib_handle_ptr handle) Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - retrive_litteral_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + retrive_literal_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); for (EMACS_UINT i = 0; i < f_vec_len; i++) { @@ -3079,7 +3079,7 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Exported functions. */ - Lisp_Object func_list = retrive_litteral_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); + Lisp_Object func_list = retrive_literal_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); while (func_list) { From 3f841a942b22c4b6b140654d3d8de535b08b672a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 10:33:58 +0200 Subject: [PATCH 0320/1452] add set_internal as runtime imported --- src/comp.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 62b0dd0732e..77d8cad5514 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1573,7 +1573,9 @@ declare_runtime_imported (void) Lisp_Object el = Fcons (name, field); \ field_list = Fcons (el, field_list); \ } while (0) - gcc_jit_type *args[2]; + + gcc_jit_type *args[4]; + ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); args[0] = comp.lisp_obj_type; @@ -1596,6 +1598,10 @@ declare_runtime_imported (void) ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + args[0] = args[1] = args[2] = comp.lisp_obj_type; + args[3] = comp.int_type; + ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + #undef ADD_IMPORTED return field_list; @@ -3072,6 +3078,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "record_unwind_current_buffer")) { f_relocs[i] = (void *) record_unwind_current_buffer; + } else if (!strcmp (f_str, "set_internal")) + { + f_relocs[i] = (void *) set_internal; } else { error ("Unexpected function relocation %s", f_str); From 6ac6e5b4752a596436b35419e7ca111b04f35d95 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 11:30:51 +0200 Subject: [PATCH 0321/1452] long string literal workaround --- src/comp.c | 65 ++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 56 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index 77d8cad5514..453d6f6fe2c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1538,15 +1538,62 @@ emit_integerp (Lisp_Object insn) static void emit_literal_string_func (const char *str_name, const char *str) { - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.char_ptr_type, - str_name, - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); - gcc_jit_block_end_with_return (block, NULL, res); + if (0) /* FIXME: somehow check gcc version here. */ + { + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.char_ptr_type, + str_name, + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); + gcc_jit_block_end_with_return (block, NULL, res); + } else + { + /* Horrible workaround for a funny bug: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html + This will have to be used for all gccs pre gcc10 era. */ + size_t len = strlen (str); + gcc_jit_type *a_type = + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + len + 1); + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + gcc_jit_type_get_pointer (a_type), + str_name, + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_lvalue *arr = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + a_type, + format_string ("arr_%s", str_name)); + for (ptrdiff_t i = 0; i <= len; i++, str++) + { + char c = i != len ? *str : 0; + + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + i)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.char_type, + c)); + } + gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (arr, NULL); + gcc_jit_block_end_with_return (block, NULL, res); + } } /* From 17cf659fdfab02d7c5008d4a4b1df11f93b4764d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 11:51:32 +0200 Subject: [PATCH 0322/1452] add helper_unwind_protect as runtime imported --- src/comp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.c b/src/comp.c index 453d6f6fe2c..a08077ee41d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1649,6 +1649,9 @@ declare_runtime_imported (void) args[3] = comp.int_type; ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + args[0] = comp.lisp_obj_type; + ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + #undef ADD_IMPORTED return field_list; @@ -3128,6 +3131,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "set_internal")) { f_relocs[i] = (void *) set_internal; + } else if (!strcmp (f_str, "helper_unwind_protect")) + { + f_relocs[i] = (void *) helper_unwind_protect; } else { error ("Unexpected function relocation %s", f_str); From d88d35ffed6c1073a0695ba1e980cb8ea7f09c3a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 12:13:33 +0200 Subject: [PATCH 0323/1452] let emit_literal_string_func emit a dbg friendly friendly --- src/comp.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/comp.c b/src/comp.c index a08077ee41d..3b2f8e4e74d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1567,6 +1567,9 @@ emit_literal_string_func (const char *str_name, const char *str) str_name, 0, NULL, 0); DECL_BLOCK (block, f); + gcc_jit_block_add_comment (block, + NULL, + str); gcc_jit_lvalue *arr = gcc_jit_context_new_global (comp.ctxt, NULL, From 6cd45fbf37bd344c87b83424ecaccc8119c30dad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 17:05:15 +0200 Subject: [PATCH 0324/1452] rework stati object serialization --- lisp/emacs-lisp/comp.el | 28 +++--- src/comp.c | 185 ++++++++++++++++++++++------------------ 2 files changed, 115 insertions(+), 98 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 65944e5dd86..ade6461f138 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -846,21 +846,21 @@ the annotation emission." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-data-relocs comp-ctxt) - (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt)))) (setf (comp-ctxt-funcs comp-ctxt) - (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) - for f being each hash-value of h - for args = (comp-func-args f) - for doc = (when (> (length (comp-func-byte-func f)) - 4) - (aref (comp-func-byte-func f) 4)) - collect (vector (comp-func-symbol-name f) - (comp-func-c-func-name f) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many)) - doc)))) + (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) + for f being each hash-value of h + for args = (comp-func-args f) + for doc = (when (> (length (comp-func-byte-func f)) + 4) + (aref (comp-func-byte-func f) 4)) + collect (vector (comp-func-symbol-name f) + (comp-func-c-func-name f) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many)) + doc))) (comp--compile-ctxt-to-file name)) (defun comp-add-func-to-ctxt (func) diff --git a/src/comp.c b/src/comp.c index 3b2f8e4e74d..d36f239f510 100644 --- a/src/comp.c +++ b/src/comp.c @@ -172,6 +172,12 @@ static comp_t comp; FILE *logfile = NULL; +/* This is used for serialized objects by the reload mechanism. */ +typedef struct { + ptrdiff_t len; + const char data[]; +} static_obj_t; + /* Helper functions called by the runtime. @@ -1525,78 +1531,90 @@ emit_integerp (Lisp_Object insn) &res); } -/* - Is not possibile to initilize static data in libgccjit therfore will create - the following: - - char *str_name (void) - { - return "payload here"; - } -*/ - +/* This is in charge of serializing an object and export a function to + retrive it at load time. */ static void -emit_literal_string_func (const char *str_name, const char *str) +emit_static_object (const char *name, Lisp_Object obj) { - if (0) /* FIXME: somehow check gcc version here. */ - { - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.char_ptr_type, - str_name, - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); - gcc_jit_block_end_with_return (block, NULL, res); - } else - { - /* Horrible workaround for a funny bug: - https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html - This will have to be used for all gccs pre gcc10 era. */ - size_t len = strlen (str); - gcc_jit_type *a_type = - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - len + 1); - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - gcc_jit_type_get_pointer (a_type), - str_name, - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_block_add_comment (block, - NULL, - str); - gcc_jit_lvalue *arr = - gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_INTERNAL, - a_type, - format_string ("arr_%s", str_name)); - for (ptrdiff_t i = 0; i <= len; i++, str++) - { - char c = i != len ? *str : 0; + /* libgccjit has no support for initialized static data. + The mechanism below is certainly not aesthetic but I assume the bottle neck + in terms of performance at load time will still be the reader. + NOTE: we can not relay on it even for valid C strings cause of + this funny bug that will affect all pre gcc10 era gccs: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ - gcc_jit_block_add_assignment ( - block, - NULL, - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (arr), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - i)), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.char_type, - c)); - } - gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (arr, NULL); - gcc_jit_block_end_with_return (block, NULL, res); + Lisp_Object str = Fprin1_to_string (obj, Qnil); + ptrdiff_t len = SBYTES (str); + const char *p = SSDATA (str); + + gcc_jit_type *a_type = + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + len + 1); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "len"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + a_type, + "data") }; + + gcc_jit_type *data_struct_t = + gcc_jit_struct_as_type ( + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + format_string ("%s_struct", name), + 2, fields)); + + gcc_jit_lvalue *data_struct = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + data_struct_t, + format_string ("%s_s", name)); + + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + gcc_jit_type_get_pointer (data_struct_t), + name, + 0, NULL, 0); + DECL_BLOCK (block, f); + + /* NOTE this truncates if the data has some zero byte before termination. */ + gcc_jit_block_add_comment (block, NULL, p); + + gcc_jit_lvalue *arr = + gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); + + for (ptrdiff_t i = 0; i < len; i++, p++) + { + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + i)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.char_type, + *p)); } + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + len)); + gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL); + gcc_jit_block_end_with_return (block, NULL, res); } /* @@ -1667,8 +1685,7 @@ static void emit_ctxt_code (void) { /* Imported objects. */ - - const char *d_reloc = SSDATA (FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt)); + Lisp_Object d_reloc = FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt); EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); @@ -1685,7 +1702,7 @@ emit_ctxt_code (void) d_reloc_len), DATA_RELOC_SYM)); - emit_literal_string_func (TEXT_DATA_RELOC_SYM, d_reloc); + emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported (); @@ -1729,8 +1746,7 @@ emit_ctxt_code (void) { ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); } - emit_literal_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, - (SSDATA (Fprin1_to_string (f_reloc_vec, Qnil)))); + emit_static_object (TEXT_IMPORTED_FUNC_RELOC_SYM, f_reloc_vec); gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, @@ -1746,8 +1762,8 @@ emit_ctxt_code (void) IMPORTED_FUNC_RELOC_SYM); /* Exported functions info. */ - const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_literal_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); + Lisp_Object func_list = FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt); + emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); } @@ -3060,21 +3076,22 @@ helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) static Lisp_Object Vnative_elisp_refs_hash; -typedef char *(*comp_litt_str_func) (void); - static void prevent_gc (Lisp_Object obj) { Fputhash (obj, Qt, Vnative_elisp_refs_hash); } +typedef char *(*comp_lit_str_func) (void); + +/* Deserialize read and return static object. */ static Lisp_Object -retrive_literal_obj (dynlib_handle_ptr handle, const char *str_name) +load_static_obj (dynlib_handle_ptr handle, const char *name) { - comp_litt_str_func f = dynlib_sym (handle, str_name); + static_obj_t *(*f)(void) = dynlib_sym (handle, name); eassert (f); - char *res = f(); - return Fread (build_string (res)); + static_obj_t *res = f(); + return Fread (make_string (res->data, res->len)); } static int @@ -3083,7 +3100,7 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = retrive_literal_obj (handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3096,7 +3113,7 @@ load_comp_unit (dynlib_handle_ptr handle) Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - retrive_literal_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); for (EMACS_UINT i = 0; i < f_vec_len; i++) { @@ -3144,7 +3161,7 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Exported functions. */ - Lisp_Object func_list = retrive_literal_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); + Lisp_Object func_list = load_static_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); while (func_list) { From 41f1fd53c830666c1274a602ca48c433da2425d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 17:28:25 +0200 Subject: [PATCH 0325/1452] disable part of comp-tests-ffuncall --- test/src/comp-tests.el | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 55797f1352e..a719dfaa6ca 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -27,13 +27,15 @@ (require 'ert) (require 'comp) -;; (require 'cl-lib) +(require 'cl-lib) (setq comp-speed 3) (defun comp-test-apply (func &rest args) (unless (subrp (symbol-function func)) - (native-compile func)) + (native-compile func) + (cl-assert (symbol-name func)) + (load (concat (symbol-name func) ".eln"))) (apply func args)) (defun comp-mashup (&rest args) @@ -127,7 +129,7 @@ (ert-deftest comp-tests-length () "Testing length." (defun comp-tests-length-f () - (length '(1 2 3))) + (length '(1 2 3))) (should (= (comp-test-apply #'comp-tests-length-f) 3))) @@ -162,19 +164,19 @@ (ert-deftest comp-tests-ffuncall () "Test calling conventions." - (defun comp-tests-ffuncall-caller-f () - (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) - (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) - ;; After it gets compiled - (native-compile #'comp-tests-ffuncall-callee-f) - (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; ;; After it gets compiled + ;; (native-compile #'comp-tests-ffuncall-callee-f) + ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) - ;; Recompiling the caller once with callee already compiled - (defun comp-tests-ffuncall-caller-f () - (comp-tests-ffuncall-callee-f 1 2 3)) - (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; ;; Recompiling the caller once with callee already compiled + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) From f23894516ac731bc858158c3e7198db8aa54bfb6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 17:32:26 +0200 Subject: [PATCH 0326/1452] rename a function test to avoid name clashing --- test/src/comp-tests.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a719dfaa6ca..fa87b7f454c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -364,14 +364,14 @@ (defun comp-tests-consp-f (x) ;; Bconsp (consp x)) - (defun comp-tests-car-f (x) + (defun comp-tests-setcar2-f (x) ;; Bsetcar (setcar x 3)) (should (eq (comp-test-apply #'comp-tests-consp-f '(1)) t)) (should (eq (comp-test-apply #'comp-tests-consp-f 1) nil)) (let ((x (cons 1 2))) - (should (= (comp-test-apply #'comp-tests-car-f x) 3)) + (should (= (comp-test-apply #'comp-tests-setcar2-f x) 3)) (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () From 2f559c267806f8524d43bc46c5814c69074b0b0a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 17:37:47 +0200 Subject: [PATCH 0327/1452] need to temporary add a load path --- test/src/comp-tests.el | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fa87b7f454c..71a36ed5914 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -51,15 +51,7 @@ (defvar comp-tests-var1 3) -;; (defmacro comp-ert-deftest (name &rest body) -;; (declare (indent defun)) -;; `(progn -;; ,@(cl-loop for speed from 0 to 3 -;; for test-name = (comp-mashup name "-speed-" -;; (number-to-string speed)) -;; collect `(ert-deftest ,test-name () -;; (let ((comp-speed ,speed)) -;; ,body))))) +(add-to-list 'load-path "/home/andcor03/emacs/src") (ert-deftest comp-tests-varref () "Testing varref." From 6d4d9225afcca63f36b318b11be945146007b00e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 18:01:18 +0200 Subject: [PATCH 0328/1452] simplify condition in emit_ctxt_code --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index d36f239f510..eb6119b1118 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1726,10 +1726,10 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_subr) { Lisp_Object subr_sym = XCAR (f_subr); + Lisp_Object subr = Fsymbol_function (subr_sym); /* Ignore inliners. This are not real functions to be imported. */ - if (NILP (Fgethash (subr_sym, comp.emitter_dispatcher, Qnil))) + if (SUBRP (subr)) { - Lisp_Object subr = Fsymbol_function (subr_sym); Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); gcc_jit_field *field = declare_imported_func (subr_sym, comp.lisp_obj_type, From 7e92976bc7973a4b4be0719b06d3751e57ad80ea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 18:08:59 +0200 Subject: [PATCH 0329/1452] fix last test broken by reload --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ade6461f138..7e1c2d1e0bf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -598,7 +598,7 @@ the annotation emission." (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref - (comp-emit-set-call (comp-call 'symbol_value (make-comp-mvar + (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar :constant arg)))) (byte-varset (comp-emit (comp-call 'set_internal From 5d6e42e013caf236f5f1c7a8bca6d76916bb404a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 2 Sep 2019 19:06:06 +0200 Subject: [PATCH 0330/1452] update inline emitters --- src/comp.c | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index eb6119b1118..00ed4172783 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2730,16 +2730,16 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); /* Inliners. */ - register_emitter (QFadd1, emit_add1); - register_emitter (QFsub1, emit_sub1); - register_emitter (QFconsp, emit_consp); - register_emitter (QFcar, emit_car); - register_emitter (QFcdr, emit_cdr); - register_emitter (QFsetcar, emit_setcar); - register_emitter (QFsetcdr, emit_setcdr); + register_emitter (Qadd1, emit_add1); + register_emitter (Qsub1, emit_sub1); + register_emitter (Qconsp, emit_consp); + register_emitter (Qcar, emit_car); + register_emitter (Qcdr, emit_cdr); + register_emitter (Qsetcar, emit_setcar); + register_emitter (Qsetcdr, emit_setcdr); register_emitter (Qnegate, emit_negate); - register_emitter (QFnumberp, emit_numperp); - register_emitter (QFintegerp, emit_integerp); + register_emitter (Qnumberp, emit_numperp); + register_emitter (Qintegerp, emit_integerp); } comp.ctxt = gcc_jit_context_acquire(); @@ -3249,16 +3249,16 @@ syms_of_comp (void) DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); /* Inliners. */ - DEFSYM (QFadd1, "Fadd1"); - DEFSYM (QFsub1, "Fsub1"); - DEFSYM (QFconsp, "Fconsp"); - DEFSYM (QFcar, "Fcar"); - DEFSYM (QFcdr, "Fcdr"); - DEFSYM (QFsetcar, "Fsetcar"); - DEFSYM (QFsetcdr, "Fsetcdr"); + DEFSYM (Qadd1, "1+"); + DEFSYM (Qsub1, "1-"); + DEFSYM (Qconsp, "consp"); + DEFSYM (Qcar, "car"); + DEFSYM (Qcdr, "cdr"); + DEFSYM (Qsetcar, "setcar"); + DEFSYM (Qsetcdr, "setcdr"); DEFSYM (Qnegate, "negate"); - DEFSYM (QFnumberp, "Fnumberp"); - DEFSYM (QFintegerp, "Fintegerp"); + DEFSYM (Qnumberp, "numberp"); + DEFSYM (Qintegerp, "integerp"); /* Returned values. */ DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); From 43172dd01fc7344f71f6e1d92fe051942f360355 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 4 Sep 2019 23:12:34 +0200 Subject: [PATCH 0331/1452] fix relocs for all inliners --- lisp/emacs-lisp/comp.el | 7 +-- src/comp.c | 103 ++++++++++++++++++---------------------- 2 files changed, 48 insertions(+), 62 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7e1c2d1e0bf..23cf7317d2e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -86,9 +86,6 @@ (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") - (data-relocs () :type string - :documentation "Final data relocations. -This is build before entering into `comp--compile-ctxt-to-file name'.") (data-relocs-l () :type list :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table @@ -303,6 +300,8 @@ Put PREFIX in front of it." v)) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) + (when const-vld + (comp-add-const-to-relocs constant)) (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -845,8 +844,6 @@ the annotation emission." "Compile as native code the current context naming it NAME." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-data-relocs comp-ctxt) - (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt)))) (setf (comp-ctxt-funcs comp-ctxt) (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h diff --git a/src/comp.c b/src/comp.c index 00ed4172783..4f40d83f82b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,4 +1,4 @@ -/* Compile byte code produced by bytecomp.el into native code. +/* Compile elisp into native code. Copyright (C) 2019 Free Software Foundation, Inc. Author: Andrea Corallo @@ -795,42 +795,30 @@ emit_make_fixnum (gcc_jit_rvalue *obj) return gcc_jit_lvalue_as_rvalue (res); } -/* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * -emit_lisp_obj_from_ptr (void *p) +emit_const_lisp_obj (Lisp_Object obj) { - static unsigned i; - emit_comment ("lisp_obj_from_ptr"); + emit_comment ("const lisp obj"); - gcc_jit_lvalue *lisp_obj = - gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("lisp_obj_from_ptr_%u", i++)); - gcc_jit_rvalue *void_ptr = - gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - p); - - if (SYMBOLP (p)) - emit_comment ( - format_string ("Symbol %s", - (char *) SDATA (SYMBOL_NAME (p)))); - - gcc_jit_block_add_assignment (comp.block, - NULL, - emit_lval_XLP (lisp_obj), - void_ptr); - - return gcc_jit_lvalue_as_rvalue (lisp_obj); + Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); + ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); + gcc_jit_rvalue *reloc_n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + reloc_fixn); + return + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + comp.data_relocs, + reloc_n)); } static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - - return emit_EQ (x, emit_lisp_obj_from_ptr (Qnil)); + return emit_EQ (x, emit_const_lisp_obj (Qnil)); } static gcc_jit_rvalue * @@ -933,7 +921,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_lisp_obj_from_ptr (Qconsp), + emit_const_lisp_obj (Qconsp), x }; gcc_jit_block_add_eval ( @@ -1025,27 +1013,16 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { - if (CONST_PROP_MAX) + + if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) { - if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) - return - gcc_jit_lvalue_as_rvalue( - comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); - else - return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); - } - else - { - if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) - { - /* If the slot is not specified this must be a constant. */ - eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); - return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); - } - return - gcc_jit_lvalue_as_rvalue( - comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + /* If the slot is not specified this must be a constant. */ + eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); + return emit_const_lisp_obj (FUNCALL1 (comp-mvar-constant, mvar)); } + + return + gcc_jit_lvalue_as_rvalue(comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); } static gcc_jit_rvalue * @@ -1063,7 +1040,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); + gcc_args[2] = emit_const_lisp_obj (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1617,12 +1594,22 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_block_end_with_return (block, NULL, res); } +static void +declare_runtime_imported_data (void) +{ + /* Imported symbols by inliner functions. */ + FUNCALL1 (comp-add-const-to-relocs, Qnil); + FUNCALL1 (comp-add-const-to-relocs, Qt); + FUNCALL1 (comp-add-const-to-relocs, Qconsp); + FUNCALL1 (comp-add-const-to-relocs, Qlistp); +} + /* Declare as imported all the functions that are requested from the runtime. These are either subrs or not. */ static Lisp_Object -declare_runtime_imported (void) +declare_runtime_imported_funcs (void) { /* For subr imported by the runtime we rely on the standard mechanism in place for functions imported by lisp code. */ @@ -1684,11 +1671,13 @@ This emit the code needed by every compilation unit to be loaded. static void emit_ctxt_code (void) { + declare_runtime_imported_data (); /* Imported objects. */ - Lisp_Object d_reloc = FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt); EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + Lisp_Object d_reloc = Freverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = gcc_jit_lvalue_as_rvalue( @@ -1705,7 +1694,7 @@ emit_ctxt_code (void) emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ - Lisp_Object f_runtime = declare_runtime_imported (); + Lisp_Object f_runtime = declare_runtime_imported_funcs (); EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_runtime)); /* Imported subrs. */ @@ -2232,11 +2221,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_lisp_obj_from_ptr (Qnil)); + emit_const_lisp_obj (Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_lisp_obj_from_ptr (Qlistp), c }; + { emit_const_lisp_obj (Qlistp), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2244,7 +2233,7 @@ define_CAR_CDR (void) comp.void_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_lisp_obj_from_ptr (Qnil)); + emit_const_lisp_obj (Qnil)); f = comp.cdr; param = cdr_param; } @@ -2604,12 +2593,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_lisp_obj_from_ptr (Qt)); + emit_const_lisp_obj (Qt)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_lisp_obj_from_ptr (Qnil)); + emit_const_lisp_obj (Qnil)); } From c05d414844f6e1e0af05ef0cbcabe3313f5089d0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 5 Sep 2019 17:24:02 +0200 Subject: [PATCH 0332/1452] emit fixnum constants as immediates --- src/comp.c | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4f40d83f82b..ebc4e8fba0e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1013,12 +1013,24 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { + Lisp_Object const_vld = FUNCALL1 (comp-mvar-const-vld, mvar); + Lisp_Object constant = FUNCALL1 (comp-mvar-constant, mvar); - if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) + if (!NILP (const_vld)) { - /* If the slot is not specified this must be a constant. */ - eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); - return emit_const_lisp_obj (FUNCALL1 (comp-mvar-constant, mvar)); + if (FIXNUMP (constant)) + { + /* We can still emit directly objects that are selfcontained in a word + read (fixnums). */ + emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); + gcc_jit_rvalue *word = + gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + constant); + return emit_cast (comp.lisp_obj_type, word); + } + /* Other const objects are fetched from the reloc array. */ + return emit_const_lisp_obj (constant); } return From ff7093d74b51f094b65314e3567fc96a3a37ffdf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 5 Sep 2019 21:16:42 +0200 Subject: [PATCH 0333/1452] some order into special vars --- lisp/emacs-lisp/bytecomp.el | 5 ++++- lisp/emacs-lisp/comp.el | 1 - 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fa3f5a7f9b9..ca7c67e6907 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -560,10 +560,13 @@ outputting warnings about functions not being defined at runtime.") (defvar byte-compile-output nil "Alist describing contents to put in byte code string. Each element is (INDEX . VALUE)") -(defvar byte-compile-lap-output nil) (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") +;; These are use by comp.el to spill lap +(defvar byte-compile-spilling-lap nil) +(defvar byte-compile-lap-output nil) + ;;; The byte codes; this information is duplicated in bytecomp.c diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 23cf7317d2e..6d9ff8d5156 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -47,7 +47,6 @@ ;; FIXME these has to be removed (defvar comp-speed 2) -(defvar byte-compile-lap-output) (defvar comp-pass nil "Every pass has the right to bind what it likes here.") From 9913638cc596a018c7d687652a3abb61325dc4f1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 5 Sep 2019 21:47:35 +0200 Subject: [PATCH 0334/1452] use nrevese where necessary --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6d9ff8d5156..3a01bb12387 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -832,7 +832,7 @@ the annotation emission." ;; Reverse insns into all basic blocks. (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) - (reverse (comp-block-insns bb)))) + (nreverse (comp-block-insns bb)))) (comp-log-func func) func)) diff --git a/src/comp.c b/src/comp.c index ebc4e8fba0e..398e4419581 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1688,7 +1688,7 @@ emit_ctxt_code (void) EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - Lisp_Object d_reloc = Freverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + Lisp_Object d_reloc = Fnreverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = @@ -1741,7 +1741,7 @@ emit_ctxt_code (void) } Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); - f_reloc_list = Freverse (f_reloc_list); + f_reloc_list = Fnreverse (f_reloc_list); ptrdiff_t i = 0; FOR_EACH_TAIL (f_reloc_list) { From 82eb75bd542ddc97b94a21bab25387f34c86f54a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 6 Sep 2019 20:12:29 +0200 Subject: [PATCH 0335/1452] remove unused helper functions --- src/comp.c | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/src/comp.c b/src/comp.c index 398e4419581..905cc70b6b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -188,8 +188,6 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); -void helper_emit_save_restriction (void); -void helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs); static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) @@ -3058,18 +3056,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, code); } -void -helper_emit_save_restriction (void) -{ - record_unwind_protect (save_restriction_restore, - save_restriction_save ()); -} - -void -helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) -{ -} - /*********************************/ /* Native elisp load functions. */ From 2b51859d447cf2914cb64936f18231363d971b21 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 6 Sep 2019 19:33:16 +0200 Subject: [PATCH 0336/1452] prepare for file compilation --- lisp/emacs-lisp/bytecomp.el | 10 ++++++---- lisp/emacs-lisp/comp.el | 7 ++++--- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ca7c67e6907..04f19426f1b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -563,9 +563,10 @@ 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.") -;; These are use by comp.el to spill lap -(defvar byte-compile-spilling-lap nil) -(defvar byte-compile-lap-output nil) +;; These are use by comp.el to spill +(defvar byte-native-compiling nil) +(defvar byte-to-native-lap-output nil) +(defvar byte-to-native-bytecode-output nil) ;;; The byte codes; this information is duplicated in bytecomp.c @@ -3117,7 +3118,8 @@ for symbols generated by the byte compiler itself." (setq rest (cdr rest))) rest)) ;; Spill lap output here - (setq byte-compile-lap-output byte-compile-output) + (when byte-native-compiling + (push byte-compile-output byte-to-native-lap-output)) (let ((byte-compile-vector (byte-compile-constants-vector))) (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3a01bb12387..2e35cd31d66 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -253,17 +253,18 @@ Put PREFIX in front of it." (defun comp-spill-lap (func) "Byte compile and spill the LAP rapresentation for FUNC." - (let (byte-compile-lap-output) + (let ((byte-native-compiling t) + (byte-to-native-lap-output ())) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) (comp-within-log-buff - (cl-prettyprint byte-compile-lap-output)) + (cl-prettyprint byte-to-native-lap-output)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (if (fixnump lambda-list) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list)) (error "Can't native compile a non lexical scoped function"))) - (setf (comp-func-lap func) byte-compile-lap-output) + (setf (comp-func-lap func) (car byte-to-native-lap-output)) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func)) From 3d9d7b34511bc3601efa2ab4ad24d62c73b80cc0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Sep 2019 08:18:08 +0200 Subject: [PATCH 0337/1452] generalize code into comp.el for compile multiple funcitons --- lisp/emacs-lisp/bytecomp.el | 14 ++-- lisp/emacs-lisp/comp.el | 149 ++++++++++++++++++++---------------- 2 files changed, 90 insertions(+), 73 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 04f19426f1b..736f4f62235 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3117,12 +3117,14 @@ for symbols generated by the byte compiler itself." (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) - ;; Spill lap output here - (when byte-native-compiling - (push byte-compile-output byte-to-native-lap-output)) - (let ((byte-compile-vector (byte-compile-constants-vector))) - (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) + (let* ((byte-compile-vector (byte-compile-constants-vector)) + (out (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) + (when byte-native-compiling + ;; Spill output for the native compiler here + (push byte-compile-output byte-to-native-lap-output) + (push out byte-to-native-bytecode-output)) + out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) ((car body))))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2e35cd31d66..d7f6f606e88 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -251,22 +251,39 @@ Put PREFIX in front of it." (make-comp-nargs :min mandatory :nonrest nonrest)))) -(defun comp-spill-lap (func) - "Byte compile and spill the LAP rapresentation for FUNC." +(defun comp-spill-lap-function (function-name) + "Spill LAP for FUNCTION-NAME." + (let* ((f (symbol-function function-name)) + (func (make-comp-func :symbol-name function-name + :func f + :c-func-name (comp-c-func-name + function-name + "F")))) + (when (byte-code-function-p f) + (error "Can't native compile an already bytecompiled function")) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) + (comp-within-log-buff + (cl-prettyprint byte-to-native-lap-output)) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (if (fixnump lambda-list) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list)) + (error "Can't native compile a non lexical scoped function"))) + (setf (comp-func-lap func) (car byte-to-native-lap-output)) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + func)) + +(defun comp-spill-lap (input) + "Byte compile and spill the LAP rapresentation for INPUT. +If INPUT is a symbol this is the function-name to be compiled. +If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lap-output ())) - (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) - (comp-within-log-buff - (cl-prettyprint byte-to-native-lap-output)) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (if (fixnump lambda-list) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list)) - (error "Can't native compile a non lexical scoped function"))) - (setf (comp-func-lap func) (car byte-to-native-lap-output)) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) - func)) + (cl-typecase input + (symbol (list (comp-spill-lap-function input))) + (string (error "To be implemented")) + (otherwise (error "Trying to native compile something not a function or file"))))) ;;; Limplification pass specific code. @@ -806,36 +823,38 @@ the annotation emission." (comp-emit-block 'entry_rest_args) (comp-emit `(set-rest-args-to-local ,nonrest))) -(defun comp-limplify (func) - "Given FUNC compute its LIMPLE ir." - (let* ((frame-size (comp-func-frame-size func)) - (comp-func func) - (comp-pass (make-comp-limplify - :sp -1 - :frame (comp-new-frame frame-size))) - (args (comp-func-args func)) - (args-min (comp-args-base-min args)) - (comp-block ())) - ;; Prologue - (comp-emit-block 'entry) - (comp-emit-annotation (concat "Lisp function: " - (symbol-name (comp-func-symbol-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit-narg-prologue args-min nonrest) - (cl-incf (comp-sp) (1+ nonrest)))) - ;; Body - (comp-emit-block 'bb_1) - (mapc #'comp-limplify-lap-inst (comp-func-lap func)) - ;; Reverse insns into all basic blocks. - (cl-loop for bb being the hash-value in (comp-func-blocks func) - do (setf (comp-block-insns bb) - (nreverse (comp-block-insns bb)))) - (comp-log-func func) - func)) +(defun comp-limplify (funcs) + "Given FUNCS compute their LIMPLE ir." + (mapcar (lambda (func) + (let* ((frame-size (comp-func-frame-size func)) + (comp-func func) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame frame-size))) + (args (comp-func-args func)) + (args-min (comp-args-base-min args)) + (comp-block ())) + ;; Prologue + (comp-emit-block 'entry) + (comp-emit-annotation (concat "Lisp function: " + (symbol-name (comp-func-symbol-name func)))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (let ((nonrest (comp-nargs-nonrest args))) + (comp-emit-narg-prologue args-min nonrest) + (cl-incf (comp-sp) (1+ nonrest)))) + ;; Body + (comp-emit-block 'bb_1) + (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + ;; Reverse insns into all basic blocks. + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (nreverse (comp-block-insns bb)))) + (comp-log-func func) + func)) + funcs)) ;;; C function wrappers @@ -871,29 +890,25 @@ the annotation emission." ;;; Entry points. -(defun native-compile (func-symbol-name) - "FUNC-SYMBOL-NAME is the function name to be compiled into native code." - (if-let ((f (symbol-function func-symbol-name))) - (progn - (when (byte-code-function-p f) - (error "Can't native compile an already bytecompiled function")) - (let ((func (make-comp-func :symbol-name func-symbol-name - :func f - :c-func-name (comp-c-func-name - func-symbol-name - "F"))) - (comp-ctxt (make-comp-ctxt))) - (mapc (lambda (pass) - (funcall pass func)) - comp-passes) - ;; Once we have the final LIMPLE we jump into C. - (comp--init-ctxt) - (unwind-protect - (progn - (comp-add-func-to-ctxt func) - (comp-compile-ctxt-to-file (symbol-name func-symbol-name))) - (comp--release-ctxt)))) - (error "Trying to native compile something not a function"))) +(defun native-compile (input) + "Compile INPUT into native code. +This is the entrypoint for the Emacs Lisp native compiler. +If INPUT is a symbol this is the function-name to be compiled. +If INPUT is a string this is the file path to be compiled." + (let ((data input) + (comp-ctxt (make-comp-ctxt))) + (mapc (lambda (pass) + (setq data (funcall pass data))) + comp-passes) + ;; Once we have the final LIMPLE we jump into C. + (comp--init-ctxt) + (unwind-protect + (progn + (mapc #'comp-add-func-to-ctxt data) + (comp-compile-ctxt-to-file (if (symbolp input) + (symbol-name input) + (file-name-sans-extension input)))) + (comp--release-ctxt)))) (provide 'comp) From 37a794ce21aa52180c3b5037c3825efee91ee7a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Sep 2019 08:57:07 +0200 Subject: [PATCH 0338/1452] split final pass + some code rework --- lisp/emacs-lisp/comp.el | 50 ++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7f6f606e88..cfaf453932d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -52,7 +52,8 @@ "Every pass has the right to bind what it likes here.") (defconst comp-passes '(comp-spill-lap - comp-limplify) + comp-limplify + comp-final) "Passes to be executed in order.") (defconst comp-known-ret-types '((cons . cons)) @@ -78,8 +79,9 @@ "Hash table lap-op -> stack adjustment.")) (cl-defstruct comp-ctxt - "This structure is to serve al relocation creation for the current compiler - context." + "Lisp side of the compiler context." + (output nil :'string + :documentation "Target output filename for the compilation.") (funcs () :type list :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table @@ -282,8 +284,7 @@ If INPUT is a string this is the file path to be compiled." (byte-to-native-lap-output ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) - (string (error "To be implemented")) - (otherwise (error "Trying to native compile something not a function or file"))))) + (string (error "To be implemented"))))) ;;; Limplification pass specific code. @@ -857,10 +858,11 @@ the annotation emission." funcs)) -;;; C function wrappers +;;; Final pass specific code. (defun comp-compile-ctxt-to-file (name) - "Compile as native code the current context naming it NAME." + "Compile as native code the current context naming it NAME. +Prepare every functions for final compilation and drive the C side." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-funcs comp-ctxt) @@ -883,9 +885,19 @@ the annotation emission." "Add FUNC to the current compiler contex." (puthash (comp-func-symbol-name func) func - (comp-ctxt-funcs-h comp-ctxt)) - ;; (comp--add-func-to-ctxt func) - ) + (comp-ctxt-funcs-h comp-ctxt))) + +(defun comp-final (data) + "Final pass driving DATA into the C side for code emission." + (let (compile-result) + (comp--init-ctxt) + (unwind-protect + (progn + (mapc #'comp-add-func-to-ctxt data) + (setq compile-result + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))) + (and (comp--release-ctxt) + compile-result)))) ;;; Entry points. @@ -895,20 +907,16 @@ the annotation emission." This is the entrypoint for the Emacs Lisp native compiler. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." + (unless (or (symbolp input) + (stringp input)) + (error "Trying to native compile something not a function or file")) (let ((data input) - (comp-ctxt (make-comp-ctxt))) + (comp-ctxt (make-comp-ctxt :output (if (symbolp input) + (symbol-name input) + (file-name-sans-extension input))))) (mapc (lambda (pass) (setq data (funcall pass data))) - comp-passes) - ;; Once we have the final LIMPLE we jump into C. - (comp--init-ctxt) - (unwind-protect - (progn - (mapc #'comp-add-func-to-ctxt data) - (comp-compile-ctxt-to-file (if (symbolp input) - (symbol-name input) - (file-name-sans-extension input)))) - (comp--release-ctxt)))) + comp-passes))) (provide 'comp) From 29fcb6ca1280fc01c652dcecc331b20cd88a5729 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Sep 2019 11:17:02 +0200 Subject: [PATCH 0339/1452] basic file compilation working --- lisp/emacs-lisp/bytecomp.el | 12 ++++++---- lisp/emacs-lisp/comp.el | 44 ++++++++++++++++++++++++++++--------- src/comp.c | 6 ++--- 3 files changed, 45 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 736f4f62235..ec7b036a677 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -563,8 +563,9 @@ 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.") -;; These are use by comp.el to spill +;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) +(defvar byte-to-native-names nil) (defvar byte-to-native-lap-output nil) (defvar byte-to-native-bytecode-output nil) @@ -2271,6 +2272,10 @@ we output that argument and the following argument QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." + (when byte-native-compiling + ;; Spill output for the native compiler here + (push name byte-to-native-names) + (push (apply #'vector form) byte-to-native-bytecode-output)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -3121,9 +3126,8 @@ for symbols generated by the byte compiler itself." (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling - ;; Spill output for the native compiler here - (push byte-compile-output byte-to-native-lap-output) - (push out byte-to-native-bytecode-output)) + ;; Spill output for the native compiler here + (push byte-compile-output byte-to-native-lap-output)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cfaf453932d..1a426560ba5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -243,6 +243,8 @@ Put PREFIX in front of it." (defun comp-decrypt-lambda-list (x) "Decript lambda list X." + (unless (fixnump x) + (error "Can't native compile a non lexical scoped function")) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -254,7 +256,7 @@ Put PREFIX in front of it." :nonrest nonrest)))) (defun comp-spill-lap-function (function-name) - "Spill LAP for FUNCTION-NAME." + "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :symbol-name function-name :func f @@ -268,23 +270,45 @@ Put PREFIX in front of it." (comp-within-log-buff (cl-prettyprint byte-to-native-lap-output)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (if (fixnump lambda-list) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list)) - (error "Can't native compile a non lexical scoped function"))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list))) (setf (comp-func-lap func) (car byte-to-native-lap-output)) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func)) +(defun comp-spill-lap-functions-file (filename) + "Byte compile FILENAME spilling data from the byte compiler." + (byte-compile-file filename) + (cl-assert (= (length byte-to-native-names) + (length byte-to-native-lap-output) + (length byte-to-native-bytecode-output))) + (cl-loop for function-name in byte-to-native-names + for lap in byte-to-native-lap-output + for bytecode in byte-to-native-bytecode-output + for lambda-list = (aref bytecode 0) + for func = (make-comp-func :symbol-name function-name + :byte-func bytecode + :c-func-name (comp-c-func-name + function-name + "F") + :args (comp-decrypt-lambda-list lambda-list) + :lap lap + :frame-size (aref bytecode 3)) + do (comp-within-log-buff + (cl-prettyprint lap)) + collect func)) + (defun comp-spill-lap (input) "Byte compile and spill the LAP rapresentation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-lap-output ())) + (byte-to-native-names ()) + (byte-to-native-lap-output ()) + (byte-to-native-bytecode-output ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) - (string (error "To be implemented"))))) + (string (comp-spill-lap-functions-file input))))) ;;; Limplification pass specific code. @@ -905,11 +929,11 @@ Prepare every functions for final compilation and drive the C side." (defun native-compile (input) "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. -If INPUT is a symbol this is the function-name to be compiled. -If INPUT is a string this is the file path to be compiled." +If INPUT is a symbol, native-compile its function definition. +If INPUT is a string, use it as the file path to be native compiled." (unless (or (symbolp input) (stringp input)) - (error "Trying to native compile something not a function or file")) + (error "Trying to native compile something not a symbol function or file")) (let ((data input) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) (symbol-name input) diff --git a/src/comp.c b/src/comp.c index 905cc70b6b3..07c779369c8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3057,9 +3057,9 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, } -/*********************************/ -/* Native elisp load functions. */ -/*********************************/ +/**************************************/ +/* Functions used to load eln files. */ +/**************************************/ static Lisp_Object Vnative_elisp_refs_hash; From ac47ef773e0cf734a3e3e4237aca50704a0a68be Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Sep 2019 11:55:20 +0200 Subject: [PATCH 0340/1452] test separate compile unit --- test/src/comp-test-funcs.el | 330 ++++++++++++++++++ test/src/comp-tests.el | 669 ++++++++++-------------------------- 2 files changed, 506 insertions(+), 493 deletions(-) create mode 100644 test/src/comp-test-funcs.el diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el new file mode 100644 index 00000000000..6d7311088ad --- /dev/null +++ b/test/src/comp-test-funcs.el @@ -0,0 +1,330 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; 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 . + +;;; 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-varset-f () + (setq comp-tests-var1 55)) + +(defun comp-tests-length-f () + (length '(1 2 3))) + +(defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (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-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-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")) + +;;FIXME: horrible... +(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))) + +;;;;;;;;;;;;;;;;;;;; +;; 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))) + +;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 71a36ed5914..ea1aab6e4c9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -26,132 +26,69 @@ ;;; Code: (require 'ert) -(require 'comp) (require 'cl-lib) +(require 'comp) -(setq comp-speed 3) +(setq comp-speed 0) -(defun comp-test-apply (func &rest args) - (unless (subrp (symbol-function func)) - (native-compile func) - (cl-assert (symbol-name func)) - (load (concat (symbol-name func) ".eln"))) - (apply func args)) +(defconst comp-test-src + (concat (file-name-directory (or load-file-name buffer-file-name)) + "comp-test-funcs.el")) -(defun comp-mashup (&rest args) - "Mash-up ARGS and return a symbol." - (intern (apply #'concat - (mapcar (lambda (x) - (cl-etypecase x - (symbol (symbol-name x)) - (string x))) - args)))) - -;; (setq garbage-collection-messages t) - -(defvar comp-tests-var1 3) - -(add-to-list 'load-path "/home/andcor03/emacs/src") +(message "Compiling %s" comp-test-src) +(native-compile comp-test-src) +(load (concat comp-test-src "n")) (ert-deftest comp-tests-varref () "Testing varref." - (defun comp-tests-varref-f () - comp-tests-var1) - - (should (= (comp-test-apply #'comp-tests-varref-f) 3))) + (should (= (comp-tests-varref-f) 3))) (ert-deftest comp-tests-list () "Testing cons car cdr." - (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)) - - (should (equal (comp-test-apply #'comp-tests-list-f) '(1 2 3))) - (should (equal (comp-test-apply #'comp-tests-list2-f 1 2 3) '(1 2 3))) - (should (= (comp-test-apply #'comp-tests-car-f '(1 . 2)) 1)) - (should (null (comp-test-apply #'comp-tests-car-f nil))) + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) (should (= (condition-case err - (comp-test-apply #'comp-tests-car-f 3) + (comp-tests-car-f 3) (error 10)) 10)) - (should (= (comp-test-apply #'comp-tests-cdr-f '(1 . 2)) 2)) - (should (null (comp-test-apply #'comp-tests-cdr-f nil))) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) (should (= (condition-case err - (comp-test-apply #'comp-tests-cdr-f 3) + (comp-tests-cdr-f 3) (error 10)) 10)) - (should (= (comp-test-apply #'comp-tests-car-safe-f '(1 . 2)) 1)) - (should (null (comp-test-apply #'comp-tests-car-safe-f 'a))) - (should (= (comp-test-apply #'comp-tests-cdr-safe-f '(1 . 2)) 2)) - (should (null (comp-test-apply #'comp-tests-cdr-safe-f 'a)))) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) (ert-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." - (defun comp-tests-cons-car-f () - (car (cons 1 2))) - - (defun comp-tests-cons-cdr-f (x) - (cdr (cons 'foo x))) - - (should (= (comp-test-apply #'comp-tests-cons-car-f) 1)) - (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) (ert-deftest comp-tests-varset () "Testing varset." - (defun comp-tests-varset-f () - (setq comp-tests-var1 55)) - - (comp-test-apply #'comp-tests-varset-f) - + (comp-tests-varset-f) (should (= comp-tests-var1 55))) (ert-deftest comp-tests-length () "Testing length." - (defun comp-tests-length-f () - (length '(1 2 3))) - - (should (= (comp-test-apply #'comp-tests-length-f) 3))) + (should (= (comp-tests-length-f) 3))) (ert-deftest comp-tests-aref-aset () "Testing aref and aset." - (defun comp-tests-aref-aset-f () - (let ((vec [1 2 3])) - (aset vec 2 100) - (aref vec 2))) - - (should (= (comp-test-apply #'comp-tests-aref-aset-f) 100))) + (should (= (comp-tests-aref-aset-f) 100))) (ert-deftest comp-tests-symbol-value () "Testing aref and aset." - (defvar comp-tests-var2 3) - (defun comp-tests-symbol-value-f () - (symbol-value 'comp-tests-var2)) - - (should (= (comp-test-apply #'comp-tests-symbol-value-f) 3))) + (should (= (comp-tests-symbol-value-f) 3))) (ert-deftest comp-tests-concat () "Testing concatX opcodes." - (defun comp-tests-concat-f (x) - (concat "a" "b" "c" "d" - (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - - (should (string= (comp-test-apply #'comp-tests-concat-f "bar") "abcdabcabfoobar"))) - -(defun comp-tests-ffuncall-callee-f (x y z) - (list x y z)) + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) (ert-deftest comp-tests-ffuncall () "Test calling conventions." @@ -159,117 +96,71 @@ ;; (defun comp-tests-ffuncall-caller-f () ;; (comp-tests-ffuncall-callee-f 1 2 3)) - ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) ;; ;; After it gets compiled ;; (native-compile #'comp-tests-ffuncall-callee-f) - ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) ;; ;; Recompiling the caller once with callee already compiled ;; (defun comp-tests-ffuncall-caller-f () ;; (comp-tests-ffuncall-callee-f 1 2 3)) - ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) - (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) - (list a b c d)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3 4) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) - (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) - (list a b c)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3 4) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) - (defun comp-tests-ffuncall-native-f () - "Call a primitive with no dedicate op." - (make-vector 1 nil)) + (should (equal (comp-tests-ffuncall-native-f) [nil])) - (should (equal (comp-test-apply #'comp-tests-ffuncall-native-f) [nil])) + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) - (defun comp-tests-ffuncall-native-rest-f () - "Call a primitive with no dedicate op with &rest." - (vector 1 2 3)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-native-rest-f) [1 2 3])) - - (defun comp-tests-ffuncall-apply-many-f (x) - (apply #'list x)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-apply-many-f '(1 2 3)) + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) - (defun comp-tests-ffuncall-lambda-f (x) - (let ((fun (lambda (x) - (1+ x)))) - (funcall fun x))) - - (should (= (comp-test-apply #'comp-tests-ffuncall-lambda-f 1) 2))) + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) (ert-deftest comp-tests-jump-table () "Testing jump tables" - (defun comp-tests-jump-table-1-f (x) - (pcase x - ('x 'a) - ('y 'b) - (_ 'c))) - - (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'x) 'a)) - (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'xxx) 'c))) + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) (ert-deftest comp-tests-conditionals () "Testing conditionals." - (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)) - - (should (= (comp-test-apply #'comp-tests-conditionals-1-f t) 1)) - (should (= (comp-test-apply #'comp-tests-conditionals-1-f nil) 2)) - (should (= (comp-test-apply #'comp-tests-conditionals-2-f t) 1340)) - (should (eq (comp-test-apply #'comp-tests-conditionals-2-f nil) nil))) + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) (ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." - (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)) - - (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f 10) 9)) - (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f most-negative-fixnum) + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f 10) 11)) - (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f most-positive-fixnum) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-plus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-test-apply #'comp-tests-fixnum-minus-f 10) -10)) - (should (= (comp-test-apply #'comp-tests-fixnum-minus-f most-negative-fixnum) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) (- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-minus-f 'a) @@ -278,49 +169,26 @@ (ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." - (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)) - - (should (eq (comp-test-apply #'comp-tests-eqlsign-f 4 3) nil)) - (should (eq (comp-test-apply #'comp-tests-eqlsign-f 3 3) t)) - (should (eq (comp-test-apply #'comp-tests-eqlsign-f 2 3) nil)) - (should (eq (comp-test-apply #'comp-tests-gtr-f 4 3) t)) - (should (eq (comp-test-apply #'comp-tests-gtr-f 3 3) nil)) - (should (eq (comp-test-apply #'comp-tests-gtr-f 2 3) nil)) - (should (eq (comp-test-apply #'comp-tests-lss-f 4 3) nil)) - (should (eq (comp-test-apply #'comp-tests-lss-f 3 3) nil)) - (should (eq (comp-test-apply #'comp-tests-lss-f 2 3) t)) - (should (eq (comp-test-apply #'comp-tests-les-f 4 3) nil)) - (should (eq (comp-test-apply #'comp-tests-les-f 3 3) t)) - (should (eq (comp-test-apply #'comp-tests-les-f 2 3) t)) - (should (eq (comp-test-apply #'comp-tests-geq-f 4 3) t)) - (should (eq (comp-test-apply #'comp-tests-geq-f 3 3) t)) - (should (eq (comp-test-apply #'comp-tests-geq-f 2 3) nil))) + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) (ert-deftest comp-tests-setcarcdr () "Testing setcar setcdr." - (defun comp-tests-setcar-f (x y) - (setcar x y) - x) - (defun comp-tests-setcdr-f (x y) - (setcdr x y) - x) - - (should (equal (comp-test-apply #'comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-test-apply #'comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) (should (equal (condition-case err (comp-tests-setcar-f 3 10) @@ -328,24 +196,12 @@ '(wrong-type-argument consp 3))) (should (equal (condition-case err - (comp-test-apply #'comp-tests-setcdr-f 3 10) + (comp-tests-setcdr-f 3 10) (error err)) '(wrong-type-argument consp 3)))) (ert-deftest comp-tests-bubble-sort () "Run bubble sort." - (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)) - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) @@ -353,50 +209,26 @@ (ert-deftest comp-test-apply () "Test some inlined list functions." - (defun comp-tests-consp-f (x) - ;; Bconsp - (consp x)) - (defun comp-tests-setcar2-f (x) - ;; Bsetcar - (setcar x 3)) - - (should (eq (comp-test-apply #'comp-tests-consp-f '(1)) t)) - (should (eq (comp-test-apply #'comp-tests-consp-f 1) nil)) + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) (let ((x (cons 1 2))) - (should (= (comp-test-apply #'comp-tests-setcar2-f x) 3)) + (should (= (comp-tests-setcar2-f x) 3)) (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () "Test some inlined number functions." - (defun comp-tests-integerp-f (x) - ;; Bintegerp - (integerp x)) - (defun comp-tests-numberp-f (x) - ;; Bnumberp - (numberp x)) + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - (should (eq (comp-test-apply #'comp-tests-integerp-f 1) t)) - (should (eq (comp-test-apply #'comp-tests-integerp-f '(1)) nil)) - (should (eq (comp-test-apply #'comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-test-apply #'comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - - (should (eq (comp-test-apply #'comp-tests-numberp-f 1) t)) - (should (eq (comp-test-apply #'comp-tests-numberp-f 'a) nil)) - (should (eq (comp-test-apply #'comp-tests-numberp-f 3.5) t))) + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) (ert-deftest comp-tests-stack () "Test some stack operation." - (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)) - - (should (= (comp-test-apply #'comp-tests-discardn-f 10) 2)) + (should (= (comp-tests-discardn-f 10) 2)) (should (string= (with-temp-buffer (comp-tests-insertn-f "a" "b" "c" "d") (buffer-string)) @@ -405,47 +237,11 @@ (ert-deftest comp-tests-non-locals () "Test non locals." (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! - (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)) - - (should (string= (comp-test-apply #'comp-tests-condition-case-0-f) + (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) - (should (string= (comp-test-apply #'comp-tests-condition-case-1-f) + (should (string= (comp-tests-condition-case-1-f) "error foo catched")) - (should (= (comp-test-apply #'comp-tests-catch-f + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) (should (= (catch 'foo @@ -455,283 +251,170 @@ "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) (comp-tests-cons-cdr-f 3)) - - (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-cdr-f 3) 3))) (ert-deftest comp-tests-buffer () - (defun comp-tests-buff0-f () - (with-temp-buffer - (insert "foo") - (buffer-string))) - - (should (string= (comp-test-apply #'comp-tests-buff0-f) "foo"))) + (should (string= (comp-tests-buff0-f) "foo"))) ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; -;; Test Bconsp. -(defun comp-test-consp (x) (consp x)) - (ert-deftest comp-consp () - (should-not (comp-test-apply 'comp-test-consp 23)) - (should-not (comp-test-apply 'comp-test-consp nil)) - (should (comp-test-apply 'comp-test-consp '(1 . 2)))) - -;; Test Blistp. -(defun comp-test-listp (x) (listp x)) + (should-not (comp-test-consp 23)) + (should-not (comp-test-consp nil)) + (should (comp-test-consp '(1 . 2)))) (ert-deftest comp-listp () - (should-not (comp-test-apply 'comp-test-listp 23)) - (should (comp-test-apply 'comp-test-listp nil)) - (should (comp-test-apply 'comp-test-listp '(1 . 2)))) - -;; Test Bstringp. -(defun comp-test-stringp (x) (stringp x)) + (should-not (comp-test-listp 23)) + (should (comp-test-listp nil)) + (should (comp-test-listp '(1 . 2)))) (ert-deftest comp-stringp () - (should-not (comp-test-apply 'comp-test-stringp 23)) - (should-not (comp-test-apply 'comp-test-stringp nil)) - (should (comp-test-apply 'comp-test-stringp "hi"))) - -;; Test Bsymbolp. -(defun comp-test-symbolp (x) (symbolp x)) + (should-not (comp-test-stringp 23)) + (should-not (comp-test-stringp nil)) + (should (comp-test-stringp "hi"))) (ert-deftest comp-symbolp () - (should-not (comp-test-apply 'comp-test-symbolp 23)) - (should-not (comp-test-apply 'comp-test-symbolp "hi")) - (should (comp-test-apply 'comp-test-symbolp 'whatever))) - -;; Test Bintegerp. -(defun comp-test-integerp (x) (integerp x)) + (should-not (comp-test-symbolp 23)) + (should-not (comp-test-symbolp "hi")) + (should (comp-test-symbolp 'whatever))) (ert-deftest comp-integerp () - (should (comp-test-apply 'comp-test-integerp 23)) - (should-not (comp-test-apply 'comp-test-integerp 57.5)) - (should-not (comp-test-apply 'comp-test-integerp "hi")) - (should-not (comp-test-apply 'comp-test-integerp 'whatever))) - -;; Test Bnumberp. -(defun comp-test-numberp (x) (numberp x)) + (should (comp-test-integerp 23)) + (should-not (comp-test-integerp 57.5)) + (should-not (comp-test-integerp "hi")) + (should-not (comp-test-integerp 'whatever))) (ert-deftest comp-numberp () - (should (comp-test-apply 'comp-test-numberp 23)) - (should (comp-test-apply 'comp-test-numberp 57.5)) - (should-not (comp-test-apply 'comp-test-numberp "hi")) - (should-not (comp-test-apply 'comp-test-numberp 'whatever))) - -;; Test Badd1. -(defun comp-test-add1 (x) (1+ x)) + (should (comp-test-numberp 23)) + (should (comp-test-numberp 57.5)) + (should-not (comp-test-numberp "hi")) + (should-not (comp-test-numberp 'whatever))) (ert-deftest comp-add1 () - (should (eq (comp-test-apply 'comp-test-add1 23) 24)) - (should (eq (comp-test-apply 'comp-test-add1 -17) -16)) - (should (eql (comp-test-apply 'comp-test-add1 1.0) 2.0)) - (should-error (comp-test-apply 'comp-test-add1 nil) + (should (eq (comp-test-add1 23) 24)) + (should (eq (comp-test-add1 -17) -16)) + (should (eql (comp-test-add1 1.0) 2.0)) + (should-error (comp-test-add1 nil) :type 'wrong-type-argument)) -;; Test Bsub1. -(defun comp-test-sub1 (x) (1- x)) - (ert-deftest comp-sub1 () - (should (eq (comp-test-apply 'comp-test-sub1 23) 22)) - (should (eq (comp-test-apply 'comp-test-sub1 -17) -18)) - (should (eql (comp-test-apply 'comp-test-sub1 1.0) 0.0)) - (should-error (comp-test-apply 'comp-test-sub1 nil) + (should (eq (comp-test-sub1 23) 22)) + (should (eq (comp-test-sub1 -17) -18)) + (should (eql (comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-sub1 nil) :type 'wrong-type-argument)) -;; Test Bneg. -(defun comp-test-negate (x) (- x)) - (ert-deftest comp-negate () - (should (eq (comp-test-apply 'comp-test-negate 23) -23)) - (should (eq (comp-test-apply 'comp-test-negate -17) 17)) - (should (eql (comp-test-apply 'comp-test-negate 1.0) -1.0)) - (should-error (comp-test-apply 'comp-test-negate nil) + (should (eq (comp-test-negate 23) -23)) + (should (eq (comp-test-negate -17) 17)) + (should (eql (comp-test-negate 1.0) -1.0)) + (should-error (comp-test-negate nil) :type 'wrong-type-argument)) -;; Test Bnot. -(defun comp-test-not (x) (not x)) - (ert-deftest comp-not () - (should (eq (comp-test-apply 'comp-test-not 23) nil)) - (should (eq (comp-test-apply 'comp-test-not nil) t)) - (should (eq (comp-test-apply 'comp-test-not t) nil))) - -;; 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)) + (should (eq (comp-test-not 23) nil)) + (should (eq (comp-test-not nil) t)) + (should (eq (comp-test-not t) nil))) (ert-deftest comp-bobp-and-eobp () (with-temp-buffer - (should (comp-test-apply 'comp-test-bobp)) - (should (comp-test-apply 'comp-test-eobp)) + (should (comp-test-bobp)) + (should (comp-test-eobp)) (insert "hi") (goto-char (point-min)) - (should (eq (comp-test-apply 'comp-test-point-min) (point-min))) - (should (eq (comp-test-apply 'comp-test-point) (point-min))) - (should (comp-test-apply 'comp-test-bobp)) - (should-not (comp-test-apply 'comp-test-eobp)) + (should (eq (comp-test-point-min) (point-min))) + (should (eq (comp-test-point) (point-min))) + (should (comp-test-bobp)) + (should-not (comp-test-eobp)) (goto-char (point-max)) - (should (eq (comp-test-apply 'comp-test-point-max) (point-max))) - (should (eq (comp-test-apply 'comp-test-point) (point-max))) - (should-not (comp-test-apply 'comp-test-bobp)) - (should (comp-test-apply 'comp-test-eobp)))) - -;; Test Bcar and Bcdr. -(defun comp-test-car (x) (car x)) -(defun comp-test-cdr (x) (cdr x)) + (should (eq (comp-test-point-max) (point-max))) + (should (eq (comp-test-point) (point-max))) + (should-not (comp-test-bobp)) + (should (comp-test-eobp)))) (ert-deftest comp-car-cdr () (let ((pair '(1 . b))) - (should (eq (comp-test-apply 'comp-test-car pair) 1)) - (should (eq (comp-test-apply 'comp-test-car nil) nil)) - (should-error (comp-test-apply 'comp-test-car 23) + (should (eq (comp-test-car pair) 1)) + (should (eq (comp-test-car nil) nil)) + (should-error (comp-test-car 23) :type 'wrong-type-argument) - (should (eq (comp-test-apply 'comp-test-cdr pair) 'b)) - (should (eq (comp-test-apply 'comp-test-cdr nil) nil)) - (should-error (comp-test-apply 'comp-test-cdr 23) + (should (eq (comp-test-cdr pair) 'b)) + (should (eq (comp-test-cdr nil) nil)) + (should-error (comp-test-cdr 23) :type 'wrong-type-argument))) -;; Test Bcar_safe and Bcdr_safe. -(defun comp-test-car-safe (x) (car-safe x)) -(defun comp-test-cdr-safe (x) (cdr-safe x)) - (ert-deftest comp-car-cdr-safe () (let ((pair '(1 . b))) - (should (eq (comp-test-apply 'comp-test-car-safe pair) 1)) - (should (eq (comp-test-apply 'comp-test-car-safe nil) nil)) - (should (eq (comp-test-apply 'comp-test-car-safe 23) nil)) - (should (eq (comp-test-apply 'comp-test-cdr-safe pair) 'b)) - (should (eq (comp-test-apply 'comp-test-cdr-safe nil) nil)) - (should (eq (comp-test-apply 'comp-test-cdr-safe 23) nil)))) - -;; Test Beq. -(defun comp-test-eq (x y) (eq x y)) + (should (eq (comp-test-car-safe pair) 1)) + (should (eq (comp-test-car-safe nil) nil)) + (should (eq (comp-test-car-safe 23) nil)) + (should (eq (comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-cdr-safe 23) nil)))) (ert-deftest comp-eq () - (should (comp-test-apply 'comp-test-eq 'a 'a)) - (should (comp-test-apply 'comp-test-eq 5 5)) - (should-not (comp-test-apply 'comp-test-eq 'a 'b)) - (should-not (comp-test-apply 'comp-test-eq "x" "x"))) - -;; Test Bgotoifnil. -(defun comp-test-if (x y) (if x x y)) + (should (comp-test-eq 'a 'a)) + (should (comp-test-eq 5 5)) + (should-not (comp-test-eq 'a 'b)) + (should-not (comp-test-eq "x" "x"))) (ert-deftest comp-if () - (should (eq (comp-test-apply 'comp-test-if 'a 'b) 'a)) - (should (eq (comp-test-apply 'comp-test-if 0 23) 0)) - (should (eq (comp-test-apply 'comp-test-if nil 'b) 'b))) - -;; Test Bgotoifnilelsepop. -(defun comp-test-and (x y) (and x y)) + (should (eq (comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-if 0 23) 0)) + (should (eq (comp-test-if nil 'b) 'b))) (ert-deftest comp-and () - (should (eq (comp-test-apply 'comp-test-and 'a 'b) 'b)) - (should (eq (comp-test-apply 'comp-test-and 0 23) 23)) - (should (eq (comp-test-apply 'comp-test-and nil 'b) nil))) - -;; Test Bgotoifnonnilelsepop. -(defun comp-test-or (x y) (or x y)) + (should (eq (comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-and 0 23) 23)) + (should (eq (comp-test-and nil 'b) nil))) (ert-deftest comp-or () - (should (eq (comp-test-apply 'comp-test-or 'a 'b) 'a)) - (should (eq (comp-test-apply 'comp-test-or 0 23) 0)) - (should (eq (comp-test-apply 'comp-test-or nil 'b) 'b))) - -;; Test Bsave_excursion. -(defun comp-test-save-excursion () - (save-excursion - (insert "XYZ"))) - -;; Test Bcurrent_buffer. -(defun comp-test-current-buffer () (current-buffer)) + (should (eq (comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-or 0 23) 0)) + (should (eq (comp-test-or nil 'b) 'b))) (ert-deftest comp-save-excursion () (with-temp-buffer - (comp-test-apply 'comp-test-save-excursion) + (comp-test-save-excursion) (should (eq (point) (point-min))) - (should (eq (comp-test-apply 'comp-test-current-buffer) (current-buffer))))) - -;; Test Bgtr. -(defun comp-test-> (a b) - (> a b)) + (should (eq (comp-test-current-buffer) (current-buffer))))) (ert-deftest comp-> () - (should (eq (comp-test-apply 'comp-test-> 0 23) nil)) - (should (eq (comp-test-apply 'comp-test-> 23 0) t))) - -;; Test Bpushcatch. -(defun comp-test-catch (&rest l) - (catch 'done - (dolist (v l) - (when (> v 23) - (throw 'done v))))) + (should (eq (comp-test-> 0 23) nil)) + (should (eq (comp-test-> 23 0) t))) (ert-deftest comp-catch () - (should (eq (comp-test-apply 'comp-test-catch 0 1 2 3 4) nil)) - (should (eq (comp-test-apply 'comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) - -;; Test Bmemq. -(defun comp-test-memq (val list) - (memq val list)) + (should (eq (comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) (ert-deftest comp-memq () - (should (equal (comp-test-apply 'comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) - (should (eq (comp-test-apply 'comp-test-memq 72 '(5 4 3 2 1 0)) nil))) - -;; Test BlistN. -(defun comp-test-listN (x) - (list x x x x x x x x x x x x x x x x)) + (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) (ert-deftest comp-listN () - (should (equal (comp-test-apply 'comp-test-listN 57) + (should (equal (comp-test-listN 57) '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) -;; Test BconcatN. -(defun comp-test-concatN (x) - (concat x x x x x x)) - (ert-deftest comp-concatN () - (should (equal (comp-test-apply 'comp-test-concatN "x") "xxxxxx"))) - -;; Test optional and rest arguments. -(defun comp-test-opt-rest (a &optional b &rest c) - (list a b c)) + (should (equal (comp-test-concatN "x") "xxxxxx"))) (ert-deftest comp-opt-rest () - (should (equal (comp-test-apply 'comp-test-opt-rest 1) '(1 nil nil))) - (should (equal (comp-test-apply 'comp-test-opt-rest 1 2) '(1 2 nil))) - (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 3) '(1 2 (3)))) - (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 56 57 58) + (should (equal (comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-opt-rest 1 2 56 57 58) '(1 2 (56 57 58))))) -;; Test for too many arguments. -(defun comp-test-opt (a &optional b) - (cons a b)) - (ert-deftest comp-opt () - (should (equal (comp-test-apply 'comp-test-opt 23) '(23))) - (should (equal (comp-test-apply 'comp-test-opt 23 24) '(23 . 24))) - (should-error (comp-test-apply 'comp-test-opt) + (should (equal (comp-test-opt 23) '(23))) + (should (equal (comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-opt) :type 'wrong-number-of-arguments) - (should-error (comp-test-apply 'comp-test-opt nil 24 97) + (should-error (comp-test-opt nil 24 97) :type 'wrong-number-of-arguments)) -;; 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))) - (ert-deftest comp-unwind-protect () (comp-test-unwind-protect 'ignore) (should (eq comp-test-up-val 999)) From 4814c6b1184a2b3fe673c5389ce0a8d2c67aec09 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Sep 2019 16:35:07 +0200 Subject: [PATCH 0341/1452] initial top level support (defvar working) --- lisp/emacs-lisp/bytecomp.el | 4 ++ lisp/emacs-lisp/comp.el | 103 ++++++++++++++++++++++++------------ src/comp.c | 18 +++++-- 3 files changed, 88 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ec7b036a677..3d4b76b988b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -568,6 +568,7 @@ Each element is (INDEX . VALUE)") (defvar byte-to-native-names nil) (defvar byte-to-native-lap-output nil) (defvar byte-to-native-bytecode-output nil) +(defvar byte-to-native-top-level-forms nil) ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2491,6 +2492,9 @@ list that represents a doc string reference. (setq form (copy-sequence form)) (setcar (cdr (cdr form)) (byte-compile-top-level (nth 2 form) nil 'file)))) + (when byte-native-compiling + ;; Spill output for the native compiler here + (push form byte-to-native-top-level-forms)) form)) (put 'define-abbrev-table 'byte-hunk-handler diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1a426560ba5..3ea500416de 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -80,8 +80,10 @@ (cl-defstruct comp-ctxt "Lisp side of the compiler context." - (output nil :'string + (output nil :type 'string :documentation "Target output filename for the compilation.") + (top-level-defvars nil :type list + :documentation "List of top level form to be compiled.") (funcs () :type list :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table @@ -160,7 +162,7 @@ LIMPLE basic block.") :documentation "When non nil is used for type propagation.")) (cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during limplification." + "Support structure used during function limplification." (sp 0 :type fixnum :documentation "Current stack pointer while walking LAP.") (frame nil :type vector @@ -282,6 +284,12 @@ Put PREFIX in front of it." (cl-assert (= (length byte-to-native-names) (length byte-to-native-lap-output) (length byte-to-native-bytecode-output))) + (setf (comp-ctxt-top-level-defvars comp-ctxt) + (mapcar (lambda (x) + (if (eq (car x) 'defvar) + (cdr x) + (cl-assert nil))) + byte-to-native-top-level-forms)) (cl-loop for function-name in byte-to-native-names for lap in byte-to-native-lap-output for bytecode in byte-to-native-bytecode-output @@ -305,7 +313,8 @@ If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-names ()) (byte-to-native-lap-output ()) - (byte-to-native-bytecode-output ())) + (byte-to-native-bytecode-output ()) + (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) (string (comp-spill-lap-functions-file input))))) @@ -848,38 +857,64 @@ the annotation emission." (comp-emit-block 'entry_rest_args) (comp-emit `(set-rest-args-to-local ,nonrest))) +(defun comp-limplify-finalize-function (func) + "Reverse insns into all basic blocks of FUNC." + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (nreverse (comp-block-insns bb)))) + (comp-log-func func) + func) + +(defun comp-limplify-top-level () + "Create a limple function doing the business for top level forms. +This will be called at runtime." + (let* ((func (make-comp-func :symbol-name 'top-level-run + :c-func-name "top_level_run" + :args (make-comp-args :min 0 :max 0) + :frame-size 0)) + (comp-func func) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame 0))) + (comp-block ())) + (comp-emit-block 'entry) + (comp-emit-annotation "Top level") + (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) + do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) + (comp-emit `(return ,(make-comp-mvar :constant nil))) + (comp-limplify-finalize-function func))) + +(defun comp-limplify-function (func) + "Limplify a single function FUNC." + (let* ((frame-size (comp-func-frame-size func)) + (comp-func func) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame frame-size))) + (args (comp-func-args func)) + (args-min (comp-args-base-min args)) + (comp-block ())) + ;; Prologue + (comp-emit-block 'entry) + (comp-emit-annotation (concat "Lisp function: " + (symbol-name (comp-func-symbol-name func)))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (let ((nonrest (comp-nargs-nonrest args))) + (comp-emit-narg-prologue args-min nonrest) + (cl-incf (comp-sp) (1+ nonrest)))) + ;; Body + (comp-emit-block 'bb_1) + (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + (comp-limplify-finalize-function func))) + (defun comp-limplify (funcs) - "Given FUNCS compute their LIMPLE ir." - (mapcar (lambda (func) - (let* ((frame-size (comp-func-frame-size func)) - (comp-func func) - (comp-pass (make-comp-limplify - :sp -1 - :frame (comp-new-frame frame-size))) - (args (comp-func-args func)) - (args-min (comp-args-base-min args)) - (comp-block ())) - ;; Prologue - (comp-emit-block 'entry) - (comp-emit-annotation (concat "Lisp function: " - (symbol-name (comp-func-symbol-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit-narg-prologue args-min nonrest) - (cl-incf (comp-sp) (1+ nonrest)))) - ;; Body - (comp-emit-block 'bb_1) - (mapc #'comp-limplify-lap-inst (comp-func-lap func)) - ;; Reverse insns into all basic blocks. - (cl-loop for bb being the hash-value in (comp-func-blocks func) - do (setf (comp-block-insns bb) - (nreverse (comp-block-insns bb)))) - (comp-log-func func) - func)) - funcs)) + "Compute the LIMPLE ir for FUNCS. +Top level forms for the current context are rendered too." + (cons (comp-limplify-top-level) + (mapcar #'comp-limplify-function funcs))) ;;; Final pass specific code. diff --git a/src/comp.c b/src/comp.c index 07c779369c8..00e15601998 100644 --- a/src/comp.c +++ b/src/comp.c @@ -304,6 +304,12 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[0] = comp.ptrdiff_type; types[1] = comp.lisp_obj_ptr_type; } + if (nargs == UNEVALLED) + { + nargs = 1; + types = alloca (nargs * sizeof (* types)); + types[0] = comp.lisp_obj_type; + } else if (!types) { types = alloca (nargs * sizeof (* types)); @@ -1718,7 +1724,7 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_runtime) { Lisp_Object el = XCAR (f_runtime); - fields[n_frelocs++] = xmint_pointer( XCDR (el)); + fields[n_frelocs++] = xmint_pointer (XCDR (el)); f_reloc_list = Fcons (XCAR (el), f_reloc_list); } @@ -1732,10 +1738,12 @@ emit_ctxt_code (void) Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); gcc_jit_field *field = declare_imported_func (subr_sym, comp.lisp_obj_type, - FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : + EQ (maxarg, Qmany) ? MANY : UNEVALLED, + NULL); fields [n_frelocs++] = field; f_reloc_list = Fcons (subr_sym, f_reloc_list); - } + } } Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); @@ -3173,6 +3181,10 @@ load_comp_unit (dynlib_handle_ptr handle) func_list = XCDR (func_list); } + /* Finally execute top level forms. */ + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + top_level_run (); + return 0; } From 17259826f263f87d45eb98c8effe0ba7ee774f5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 09:40:42 +0200 Subject: [PATCH 0342/1452] fix build system for native compiler option --- configure.ac | 10 +++++++--- src/Makefile.in | 4 +++- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/configure.ac b/configure.ac index 6213051a602..a36a2f32428 100644 --- a/configure.ac +++ b/configure.ac @@ -3671,18 +3671,22 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) +### Emacs Lisp native compiler support HAVE_LIBGCCJIT=no LIBGCCJIT_LIB= +COMP_OBJ= if test "${with_nativecomp}" != "no"; then AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_LIBGCCJIT=yes, , -lgccjit) if test "${HAVE_LIBGCCJIT}" = "yes"; then - LIBGCCJIT_LIB=-lgccjit - AC_DEFINE([HAVE_LIBGCCJIT], 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + LIBGCCJIT_LIB="-lgccjit -ldl" + COMP_OBJ="dynlib.o comp.o" + AC_DEFINE(HAVE_LIBGCCJIT, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) fi fi -AC_SUBST([LIBGCCJIT_LIB]) +AC_SUBST(LIBGCCJIT_LIB) +AC_SUBST(COMP_OBJ) ### Dynamic modules support LIBMODULES= diff --git a/src/Makefile.in b/src/Makefile.in index 5e0e36d8b4d..6c65275d6da 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -327,6 +327,8 @@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ LIBGCCJIT = @LIBGCCJIT_LIB@ +## dynlib.o comp.o if native compiler is enabled, else empty +COMP_OBJ = @COMP_OBJ@ RUN_TEMACS = ./temacs @@ -416,7 +418,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 comp.o \ + syntax.o $(UNEXEC_OBJ) bytecode.o $(COMP_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) \ From 06ad74581385cd1930a073b2fda314230b254608 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 10:11:36 +0200 Subject: [PATCH 0343/1452] rename HAVE_LIBGCCJIT -> HAVE_NATIVE_COMP --- configure.ac | 8 ++++---- src/comp.c | 4 ++-- src/emacs.c | 2 +- src/lread.c | 6 +++--- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/configure.ac b/configure.ac index a36a2f32428..0cfd80bb2e8 100644 --- a/configure.ac +++ b/configure.ac @@ -3672,15 +3672,15 @@ fi AC_SUBST(LIBZ) ### Emacs Lisp native compiler support -HAVE_LIBGCCJIT=no +HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_LIBGCCJIT=yes, , -lgccjit) - if test "${HAVE_LIBGCCJIT}" = "yes"; then + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) + if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ="dynlib.o comp.o" - AC_DEFINE(HAVE_LIBGCCJIT, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) fi diff --git a/src/comp.c b/src/comp.c index 00e15601998..2b6f8bf0536 100644 --- a/src/comp.c +++ b/src/comp.c @@ -20,7 +20,7 @@ along with GNU Emacs. If not, see . */ #include -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP #include #include @@ -3283,4 +3283,4 @@ syms_of_comp (void) comp_speed = DEFAULT_SPEED; } -#endif /* HAVE_LIBGCCJIT */ +#endif /* HAVE_NATIVE_COMP */ diff --git a/src/emacs.c b/src/emacs.c index c59a70988b7..90ab7ac1e8e 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1598,7 +1598,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP if (!initialized) syms_of_comp (); #endif diff --git a/src/lread.c b/src/lread.c index b10743f980c..f1b17edd011 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,7 +1281,7 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); #else bool is_native_elisp = false; @@ -1486,7 +1486,7 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP specbind (Qcurrent_load_list, Qnil); LOADHIST_ATTACH (found); Fnative_elisp_load (found); @@ -4896,7 +4896,7 @@ to the specified file name if a suffix is allowed or required. */); Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes); #endif #endif -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); #endif From 555450c7b1b1c02126bd9fc86486090fe2b829b5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 15:40:56 +0200 Subject: [PATCH 0344/1452] fix lambda handling and add a test for that --- lisp/emacs-lisp/bytecomp.el | 12 +++++------- lisp/emacs-lisp/comp.el | 16 +++++----------- test/src/comp-test-funcs.el | 3 +++ test/src/comp-tests.el | 3 +++ 4 files changed, 16 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3d4b76b988b..f82993956b7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,9 +565,8 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) -(defvar byte-to-native-names nil) -(defvar byte-to-native-lap-output nil) -(defvar byte-to-native-bytecode-output nil) +(defvar byte-last-lap nil) +(defvar byte-to-native-output nil) (defvar byte-to-native-top-level-forms nil) @@ -2274,9 +2273,8 @@ QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." (when byte-native-compiling - ;; Spill output for the native compiler here - (push name byte-to-native-names) - (push (apply #'vector form) byte-to-native-bytecode-output)) + ;; Spill output for the native compiler here + (push (list name byte-last-lap (apply #'vector form)) byte-to-native-output)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -3131,7 +3129,7 @@ for symbols generated by the byte compiler itself." byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling ;; Spill output for the native compiler here - (push byte-compile-output byte-to-native-lap-output)) + (setq byte-last-lap byte-compile-output)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ea500416de..39f00c57921 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -281,23 +281,18 @@ Put PREFIX in front of it." (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) - (cl-assert (= (length byte-to-native-names) - (length byte-to-native-lap-output) - (length byte-to-native-bytecode-output))) (setf (comp-ctxt-top-level-defvars comp-ctxt) (mapcar (lambda (x) (if (eq (car x) 'defvar) (cdr x) (cl-assert nil))) byte-to-native-top-level-forms)) - (cl-loop for function-name in byte-to-native-names - for lap in byte-to-native-lap-output - for bytecode in byte-to-native-bytecode-output + (cl-loop for (name lap bytecode) in byte-to-native-output for lambda-list = (aref bytecode 0) - for func = (make-comp-func :symbol-name function-name + for func = (make-comp-func :symbol-name name :byte-func bytecode :c-func-name (comp-c-func-name - function-name + name "F") :args (comp-decrypt-lambda-list lambda-list) :lap lap @@ -311,9 +306,8 @@ Put PREFIX in front of it." If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-names ()) - (byte-to-native-lap-output ()) - (byte-to-native-bytecode-output ()) + (byte-last-lap nil) + (byte-to-native-output ()) (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 6d7311088ad..609147e7e28 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -216,6 +216,9 @@ ;; (insert "foo") ;; (buffer-string))) +(defun comp-tests-lambda-return-f () + (lambda (x) (1+ x))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ea1aab6e4c9..47ae7899c69 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -256,6 +256,9 @@ (ert-deftest comp-tests-buffer () (should (string= (comp-tests-buff0-f) "foo"))) +(ert-deftest comp-tests-lambda-return () + (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 314f9fcf6cb8a6f513022a40ee384ff0e4ca513a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 15:42:52 +0200 Subject: [PATCH 0345/1452] uncomment back all tests --- test/src/comp-test-funcs.el | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 609147e7e28..b92716739b9 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -89,10 +89,10 @@ (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-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) (defun comp-tests-jump-table-1-f (x) (pcase x @@ -211,10 +211,10 @@ (defun comp-tests-throw-f (x) (throw 'foo x)) -;; (defun comp-tests-buff0-f () -;; (with-temp-buffer -;; (insert "foo") -;; (buffer-string))) +(defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) (defun comp-tests-lambda-return-f () (lambda (x) (1+ x))) @@ -319,15 +319,15 @@ (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))) +;; 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))) ;;; comp-test-funcs.el ends here From 59a428ed6ccd7ee41e847b1d63889845fae7ebd5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 15:55:23 +0200 Subject: [PATCH 0346/1452] fix single function compilation --- lisp/emacs-lisp/bytecomp.el | 6 +++--- lisp/emacs-lisp/comp.el | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f82993956b7..77cd408ce97 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,7 +565,7 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) -(defvar byte-last-lap nil) +(defvar byte-to-native-last-lap nil) (defvar byte-to-native-output nil) (defvar byte-to-native-top-level-forms nil) @@ -2274,7 +2274,7 @@ list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." (when byte-native-compiling ;; Spill output for the native compiler here - (push (list name byte-last-lap (apply #'vector form)) byte-to-native-output)) + (push (list name byte-to-native-last-lap (apply #'vector form)) byte-to-native-output)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -3129,7 +3129,7 @@ for symbols generated by the byte compiler itself." byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling ;; Spill output for the native compiler here - (setq byte-last-lap byte-compile-output)) + (setq byte-to-native-last-lap byte-compile-output)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 39f00c57921..2e98560e8f4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -270,11 +270,11 @@ Put PREFIX in front of it." (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) (comp-within-log-buff - (cl-prettyprint byte-to-native-lap-output)) + (cl-prettyprint byte-to-native-last-lap)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) - (setf (comp-func-lap func) (car byte-to-native-lap-output)) + (setf (comp-func-lap func) byte-to-native-last-lap) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func)) @@ -306,7 +306,7 @@ Put PREFIX in front of it." If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-last-lap nil) + (byte-to-native-last-lap nil) (byte-to-native-output ()) (byte-to-native-top-level-forms ())) (cl-typecase input From fca675dae325a974c625893fb0ad1aa88abeab8f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 16:31:53 +0200 Subject: [PATCH 0347/1452] fix varset and add a test --- lisp/emacs-lisp/comp.el | 2 +- test/src/comp-test-funcs.el | 5 ++++- test/src/comp-tests.el | 7 +++++-- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2e98560e8f4..48e22528072 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -647,7 +647,7 @@ the annotation emission." (byte-varset (comp-emit (comp-call 'set_internal (make-comp-mvar :constant arg) - (comp-slot)))) + (comp-slot-next)))) (byte-varbind ;; Verify (comp-emit (comp-call 'specbind (make-comp-mvar :constant arg) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index b92716739b9..4fc62482a0d 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -50,8 +50,11 @@ (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) -(defun comp-tests-varset-f () +(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))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 47ae7899c69..331e1cfed16 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -71,8 +71,11 @@ (ert-deftest comp-tests-varset () "Testing varset." - (comp-tests-varset-f) - (should (= comp-tests-var1 55))) + (comp-tests-varset0-f) + (should (= comp-tests-var1 55)) + + (should (= (comp-tests-varset1-f) 4)) + (should (= comp-tests-var1 66))) (ert-deftest comp-tests-length () "Testing length." From 038f46c2526fcc3643a74a6c3e9fda40691f4067 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 16:57:40 +0200 Subject: [PATCH 0348/1452] rename comp-slot-next -> comp-slot+1 --- lisp/emacs-lisp/comp.el | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 48e22528072..811e03a5edb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -375,7 +375,7 @@ Restore the original value afterwards." "Current slot into the meta-stack pointed by sp." '(comp-slot-n (comp-sp))) -(defmacro comp-slot-next () +(defmacro comp-slot+1 () "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) @@ -514,7 +514,7 @@ If NEGATED non nil negate the tested condition." do (comp-with-sp sp (comp-emit-set-call (comp-call 'cons (comp-slot) - (comp-slot-next)))))) + (comp-slot+1)))))) (defun comp-new-block-sym () "Return a symbol naming the next new basic block." @@ -538,7 +538,7 @@ If NEGATED non nil negate the tested condition." (make-comp-block :sp (comp-sp)) blocks) (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler (comp-slot-next) + (comp-emit (list 'push-handler (comp-slot+1) handler-type handler-bb guarded-bb)) @@ -647,11 +647,11 @@ the annotation emission." (byte-varset (comp-emit (comp-call 'set_internal (make-comp-mvar :constant arg) - (comp-slot-next)))) + (comp-slot+1)))) (byte-varbind ;; Verify (comp-emit (comp-call 'specbind (make-comp-mvar :constant arg) - (comp-slot-next)))) + (comp-slot+1)))) (byte-call (comp-emit-funcall arg)) (byte-unbind @@ -746,7 +746,7 @@ the annotation emission." (byte-narrow-to-region (comp-emit-set-call (comp-call 'narrow_to_region (comp-slot) - (comp-slot-next)))) + (comp-slot+1)))) (byte-widen (comp-emit-set-call (comp-call 'widen))) (byte-end-of-line auto) @@ -754,19 +754,19 @@ the annotation emission." (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (cl-third insn) t)) (byte-return - (comp-emit `(return ,(comp-slot-next))) + (comp-emit `(return ,(comp-slot+1))) (comp-mark-block-closed)) (byte-discard 'pass) (byte-dup @@ -778,7 +778,7 @@ the annotation emission." (comp-call 'helper-save-restriction)) (byte-catch) ;; Obsolete (byte-unwind-protect - (comp-emit (comp-call 'helper_unwind_protect (comp-slot-next)))) + (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) @@ -821,7 +821,7 @@ the annotation emission." (byte-discardN (comp-stack-adjust (- arg))) (byte-switch - (comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp))))) + (comp-emit-switch (comp-slot+1) (comp-slot-n (+ 2 (comp-sp))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos From f74ab3e9ef7a5a63efdb4a7e0bca0c9cc71bf575 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 17:04:06 +0200 Subject: [PATCH 0349/1452] get right dependency during top level form evaluantion --- lisp/emacs-lisp/comp.el | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 811e03a5edb..c5c36e9eda8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -282,11 +282,11 @@ Put PREFIX in front of it." "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (setf (comp-ctxt-top-level-defvars comp-ctxt) - (mapcar (lambda (x) - (if (eq (car x) 'defvar) - (cdr x) - (cl-assert nil))) - byte-to-native-top-level-forms)) + (reverse (mapcar (lambda (x) + (if (eq (car x) 'defvar) + (cdr x) + (cl-assert nil))) + byte-to-native-top-level-forms))) (cl-loop for (name lap bytecode) in byte-to-native-output for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name From 4c6272373d4e5a6fbb8668f4980bbafbdc28405e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 17:13:48 +0200 Subject: [PATCH 0350/1452] add defconst support --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c5c36e9eda8..12c8ca63699 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -283,9 +283,9 @@ Put PREFIX in front of it." (byte-compile-file filename) (setf (comp-ctxt-top-level-defvars comp-ctxt) (reverse (mapcar (lambda (x) - (if (eq (car x) 'defvar) - (cdr x) - (cl-assert nil))) + (ecase (car x) + ('defvar (cdr x)) + ('defconst (cdr x)))) byte-to-native-top-level-forms))) (cl-loop for (name lap bytecode) in byte-to-native-output for lambda-list = (aref bytecode 0) From 1b9b19ebf911a959948de513afe3f639e23f346a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 18:48:14 +0200 Subject: [PATCH 0351/1452] fix missing specbind import --- src/comp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.c b/src/comp.c index 2b6f8bf0536..b6733522a10 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1676,6 +1676,9 @@ declare_runtime_imported_funcs (void) args[0] = comp.lisp_obj_type; ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + args[0] = args[1] = comp.lisp_obj_type; + ADD_IMPORTED ("specbind", comp.void_type, 2, args); + #undef ADD_IMPORTED return field_list; @@ -3149,6 +3152,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "helper_unwind_protect")) { f_relocs[i] = (void *) helper_unwind_protect; + } else if (!strcmp (f_str, "specbind")) + { + f_relocs[i] = (void *) specbind; } else { error ("Unexpected function relocation %s", f_str); From ef6c633b9d5532d8888535a43ec8abc7de0a34f7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 18:48:29 +0200 Subject: [PATCH 0352/1452] add assertion for missing op support --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 12c8ca63699..702e10df8d9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -817,7 +817,7 @@ the annotation emission." (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) - (byte-stack-set2) ;; TODO + (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN (comp-stack-adjust (- arg))) (byte-switch From 5adfe6520b5a3ff2e3bacc603487c4f12e54dfc7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 19:56:37 +0200 Subject: [PATCH 0353/1452] fix pretty printing in native compilation buffer --- lisp/emacs-lisp/comp.el | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 702e10df8d9..4f407eabc05 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -203,6 +203,7 @@ BODY is evaluate only if `comp-debug' is non nil." (goto-char (point-max)) ,@body)))) + (defun comp-log (string) "Log a STRING into the log-buffer." (comp-within-log-buff @@ -211,6 +212,12 @@ BODY is evaluate only if `comp-debug' is non nil." (t (insert (format "%s\n" string)))))) +(defun comp-prettyprint (data) + "Nicely print DATA in the current buffer." + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data)) + (defun comp-log-func (func) "Pretty print function FUNC in the log-buffer." (comp-within-log-buff @@ -219,7 +226,7 @@ BODY is evaluate only if `comp-debug' is non nil." using (hash-value bb) do (progn (insert (concat "\n<" (symbol-name block-name) ">")) - (cl-prettyprint (comp-block-insns bb)))))) + (comp-prettyprint (comp-block-insns bb)))))) ;;; spill-lap pass specific code. @@ -270,7 +277,7 @@ Put PREFIX in front of it." (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) (comp-within-log-buff - (cl-prettyprint byte-to-native-last-lap)) + (comp-prettyprint byte-to-native-last-lap)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) @@ -298,7 +305,7 @@ Put PREFIX in front of it." :lap lap :frame-size (aref bytecode 3)) do (comp-within-log-buff - (cl-prettyprint lap)) + (comp-prettyprint lap)) collect func)) (defun comp-spill-lap (input) From a2b9d58b2e2f56679b33995e2d86b0624c0b1905 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 20:08:58 +0200 Subject: [PATCH 0354/1452] nit into comp-log --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4f407eabc05..644bd2b8d1b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -210,7 +210,7 @@ BODY is evaluate only if `comp-debug' is non nil." (cond (noninteractive (message " %s" string)) (t - (insert (format "%s\n" string)))))) + (insert string "\n"))))) (defun comp-prettyprint (data) "Nicely print DATA in the current buffer." From a70e54f6f7a6e711bcc49fce4e117d9c3e9d71a1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 20:16:09 +0200 Subject: [PATCH 0355/1452] some error handling in compile_function --- src/comp.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index b6733522a10..c2bd135495e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2626,7 +2626,7 @@ define_bool_to_lisp_obj (void) static void compile_function (Lisp_Object func) { - char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); + char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); bool ncall = (FUNCALL1 (comp-nargs-p, args)); @@ -2707,6 +2707,11 @@ compile_function (Lisp_Object func) insns = XCDR (insns); } } + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + error ("Failing to compile function %s with error:%s", + SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), + err); } From a8517ba3ceb21f3fb5c452226d5ca6a3981ae852 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 20:39:34 +0200 Subject: [PATCH 0356/1452] add sanity check into compile_function --- src/comp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/comp.c b/src/comp.c index c2bd135495e..8422c7d3431 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2698,6 +2698,7 @@ compile_function (Lisp_Object func) Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = FUNCALL1 (comp-block-insns, block); + eassert (!NILP (block) && !NILP (insns)); comp.block = retrive_block (block_name); while (CONSP (insns)) From b32900474fb5e4afdfd0c0015f6b08d58b5e7847 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 20:54:41 +0200 Subject: [PATCH 0357/1452] rework log mechanism to work non interactively too --- lisp/emacs-lisp/comp.el | 47 ++++++++++++++++++----------------------- 1 file changed, 21 insertions(+), 26 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 644bd2b8d1b..c18e3b8dc69 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -203,30 +203,27 @@ BODY is evaluate only if `comp-debug' is non nil." (goto-char (point-max)) ,@body)))) - -(defun comp-log (string) - "Log a STRING into the log-buffer." - (comp-within-log-buff - (cond (noninteractive - (message " %s" string)) - (t - (insert string "\n"))))) - -(defun comp-prettyprint (data) - "Nicely print DATA in the current buffer." - (mapc (lambda (x) - (insert (prin1-to-string x) "\n")) - data)) +(defun comp-log (data) + "Log DATA." + (if noninteractive + (if (atom data) + (message "%s" data) + (mapc (lambda (x) + (message "%s"(prin1-to-string x))) + data)) + (comp-within-log-buff + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data)))) (defun comp-log-func (func) - "Pretty print function FUNC in the log-buffer." - (comp-within-log-buff - (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (progn - (insert (concat "\n<" (symbol-name block-name) ">")) - (comp-prettyprint (comp-block-insns bb)))))) + "Log function FUNC." + (comp-log (format "\n\n Function: %s" (comp-func-symbol-name func))) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (progn + (comp-log (concat "\n<" (symbol-name block-name) ">")) + (comp-log (comp-block-insns bb))))) ;;; spill-lap pass specific code. @@ -276,8 +273,7 @@ Put PREFIX in front of it." (error "Can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (comp-within-log-buff - (comp-prettyprint byte-to-native-last-lap)) + (comp-log byte-to-native-last-lap) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) @@ -304,8 +300,7 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (aref bytecode 3)) - do (comp-within-log-buff - (comp-prettyprint lap)) + do (comp-log lap) collect func)) (defun comp-spill-lap (input) From 5f1039630dc8bf63f65df5c7882246f267d01295 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 21:42:37 +0200 Subject: [PATCH 0358/1452] add verbosity parameter --- lisp/emacs-lisp/comp.el | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c18e3b8dc69..0770d32f7a1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -47,6 +47,7 @@ ;; FIXME these has to be removed (defvar comp-speed 2) +(defvar comp-verbose nil) (defvar comp-pass nil "Every pass has the right to bind what it likes here.") @@ -205,16 +206,19 @@ BODY is evaluate only if `comp-debug' is non nil." (defun comp-log (data) "Log DATA." - (if noninteractive + (if (and noninteractive + comp-verbose) (if (atom data) (message "%s" data) (mapc (lambda (x) (message "%s"(prin1-to-string x))) data)) (comp-within-log-buff - (mapc (lambda (x) - (insert (prin1-to-string x) "\n")) - data)))) + (if (and data (atom data)) + (insert data) + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data))))) (defun comp-log-func (func) "Log function FUNC." From c702e25a7a9e1ba2b75942dcc00402947757786d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Sep 2019 21:42:51 +0200 Subject: [PATCH 0359/1452] do not override existing basic blocks when branching backwards! --- lisp/emacs-lisp/comp.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0770d32f7a1..c398810186d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -500,9 +500,11 @@ If NEGATED non nil negate the tested condition." (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) - (puthash target - (make-comp-block :sp (+ target-offset (comp-sp))) - blocks) + (unless (gethash target blocks) + ;; Create the bb target only if does not exixsts already. + (puthash target + (make-comp-block :sp (+ target-offset (comp-sp))) + blocks)) (comp-mark-block-closed)) (comp-emit-block bb))) From b9f37a2a09ac6bcef1a03cc49489f15ff01a74b7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Sep 2019 12:01:03 +0200 Subject: [PATCH 0360/1452] pacify gcc and improve sanaity checks --- src/comp.c | 94 +++++++++++++++++++++++++++++++++--------------------- src/lisp.h | 4 +-- 2 files changed, 59 insertions(+), 39 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8422c7d3431..f966a2427b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -44,8 +44,6 @@ along with GNU Emacs. If not, see . */ generated code C-like code more bloated. */ -#define CONST_PROP_MAX 0 - /* C symbols emited for the load relocation mechanism. */ #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" @@ -79,6 +77,12 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME STR (SETJMP) +#define ICE_IF(test, msg) \ + do { \ + if (test) \ + ice (msg); \ + } while (0) + /* C side of the compiler context. */ typedef struct { @@ -186,8 +190,7 @@ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); -bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, - enum pvec_type code); +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) @@ -203,6 +206,16 @@ format_string (const char *format, ...) return scratch_area; } +static void +ice (const char* msg) +{ + if (msg) + msg = format_string ("Internal native compiler error: %s", msg); + else + msg = "Internal native compiler error"; + error ("%s", msg); +} + static void bcall0 (Lisp_Object f) { @@ -243,7 +256,7 @@ type_to_cast_field (gcc_jit_type *type) else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else - error ("Unsupported cast"); + ice ("unsupported cast"); return field; } @@ -252,8 +265,7 @@ static gcc_jit_block * retrive_block (Lisp_Object block_name) { Lisp_Object value = Fgethash (block_name, comp.func_blocks, Qnil); - if (NILP (value)) - error ("LIMPLE basic block inconsistency"); + ICE_IF (NILP (value), "missing basic block"); return (gcc_jit_block *) xmint_pointer (value); } @@ -264,8 +276,8 @@ declare_block (Lisp_Object block_name) char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - if (!NILP (Fgethash (block_name, comp.func_blocks, Qnil))) - error ("LIMPLE basic block inconsistency"); + ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks, Qnil)), + "double basic block declaration"); Fputhash (block_name, value, comp.func_blocks); } @@ -295,7 +307,8 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); + ICE_IF (!NILP (Fgethash (subr_sym, comp.func_hash, Qnil)), + "unexpected double function declaration"); if (nargs == MANY) { @@ -317,8 +330,6 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[i] = comp.lisp_obj_type; } - eassert (types); - /* String containing the function ptr name. */ Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), @@ -359,16 +370,17 @@ static gcc_jit_function * declare_exported_func (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - gcc_jit_type *type[nargs]; - + USE_SAFE_ALLOCA; + gcc_jit_type **type = SAFE_ALLOCA (nargs * sizeof (*type)); fill_declaration_types (type, args, nargs); - gcc_jit_param *param[nargs]; + gcc_jit_param **param = SAFE_ALLOCA (nargs *sizeof (*param)); for (int i = nargs - 1; i >= 0; i--) param[i] = gcc_jit_context_new_param(comp.ctxt, NULL, type[i], format_string ("par_%d", i)); + SAFE_FREE (); return gcc_jit_context_new_function(comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, ret_type, @@ -383,14 +395,14 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); - eassert (!NILP (value)); + ICE_IF (NILP (value), "missing function declaration"); gcc_jit_lvalue *f_ptr = gcc_jit_lvalue_access_field (comp.func_relocs, NULL, (gcc_jit_field *) xmint_pointer (value)); - if (!f_ptr) - error ("Undeclared function relocation."); + + ICE_IF (!f_ptr, "undeclared function relocation"); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); @@ -1050,7 +1062,7 @@ emit_set_internal (Lisp_Object args) #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ - eassert (list_length (args) == 3); + ICE_IF (list_length (args) != 3, "unexpected arg length for insns"); args = XCDR (args); int i = 0; gcc_jit_rvalue *gcc_args[4]; @@ -1069,14 +1081,16 @@ emit_set_internal (Lisp_Object args) static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { + USE_SAFE_ALLOCA; int i = 0; Lisp_Object callee = FIRST (args); args = XCDR (args); ptrdiff_t nargs = list_length (args); - gcc_jit_rvalue *gcc_args[nargs]; + gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args)); FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); + SAFE_FREE (); return emit_call (callee, ret_type, nargs, gcc_args); } @@ -1195,7 +1209,7 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0; + Lisp_Object arg0 UNINIT; gcc_jit_rvalue *res; if (CONSP (args)) @@ -1243,13 +1257,13 @@ emit_limple_insn (Lisp_Object insn) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); - int h_num; + int h_num UNINIT; if (EQ (SECOND (args), Qcatcher)) h_num = CATCHER; else if (EQ (SECOND (args), Qcondition_case)) h_num = CONDITION_CASE; else - eassert (false); + ice ("incoherent insn"); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1299,8 +1313,10 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (FIRST (arg1), Qcallref)) res = emit_limple_call_ref (XCDR (arg1)); else - error ("LIMPLE inconsistent arg1 for op ="); - eassert (res); + ice ("LIMPLE inconsistent arg1 for op ="); + + ICE_IF (!res, "incoherent insn"); + gcc_jit_block_add_assignment (comp.block, NULL, comp.frame[slot_n], @@ -1420,7 +1436,7 @@ emit_limple_insn (Lisp_Object insn) } else { - error ("LIMPLE op inconsistent"); + ice ("LIMPLE op inconsistent"); } } @@ -1690,6 +1706,8 @@ This emit the code needed by every compilation unit to be loaded. static void emit_ctxt_code (void) { + USE_SAFE_ALLOCA; + declare_runtime_imported_data (); /* Imported objects. */ EMACS_UINT d_reloc_len = @@ -1720,7 +1738,7 @@ emit_ctxt_code (void) Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); f_reloc_len += XFIXNUM (Flength (f_subr)); - gcc_jit_field *fields[f_reloc_len]; + gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); Lisp_Object f_reloc_list = Qnil; int n_frelocs = 0; @@ -1774,6 +1792,7 @@ emit_ctxt_code (void) /* Exported functions info. */ Lisp_Object func_list = FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt); emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); + SAFE_FREE (); } @@ -2626,6 +2645,7 @@ define_bool_to_lisp_obj (void) static void compile_function (Lisp_Object func) { + USE_SAFE_ALLOCA; char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); @@ -2666,7 +2686,7 @@ compile_function (Lisp_Object func) frame_size), "local"); - gcc_jit_lvalue *frame[frame_size]; + gcc_jit_lvalue **frame = SAFE_ALLOCA (frame_size * sizeof (*frame)); for (int i = 0; i < frame_size; ++i) frame[i] = gcc_jit_context_new_array_access ( @@ -2698,7 +2718,7 @@ compile_function (Lisp_Object func) Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = FUNCALL1 (comp-block-insns, block); - eassert (!NILP (block) && !NILP (insns)); + ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty"); comp.block = retrive_block (block_name); while (CONSP (insns)) @@ -2709,10 +2729,11 @@ compile_function (Lisp_Object func) } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); - if (err) - error ("Failing to compile function %s with error:%s", - SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), - err); + ICE_IF (err, + format_string ("failing to compile function %s with error: %s", + SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), + err)); + SAFE_FREE (); } @@ -2727,7 +2748,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, { if (comp.ctxt) { - error ("Compiler context already taken"); + ice ("compiler context already taken"); return Qnil; } @@ -3065,8 +3086,7 @@ helper_unbind_n (Lisp_Object n) } bool -helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, - enum pvec_type code) +helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) { return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, union vectorlike_header), @@ -3163,7 +3183,7 @@ load_comp_unit (dynlib_handle_ptr handle) f_relocs[i] = (void *) specbind; } else { - error ("Unexpected function relocation %s", f_str); + ice (format_string ("unexpected function relocation %s", f_str)); } } diff --git a/src/lisp.h b/src/lisp.h index 93a3ddea0cb..cb3487675e7 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4742,9 +4742,9 @@ extern void malloc_probe (size_t); extern void syms_of_profiler (void); /* Defined in comp.c. */ -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP extern void syms_of_comp (void); -#endif /* HAVE_LIBGCCJIT */ +#endif /* HAVE_NATIVE_COMP */ #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ From 63ecf01d0b0897b948296eaaffd690290d536b72 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Sep 2019 12:55:51 +0200 Subject: [PATCH 0361/1452] crank optimizations while running native compiler test suite --- test/src/comp-test-funcs.el | 1 - test/src/comp-tests.el | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 4fc62482a0d..dbc90771774 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -185,7 +185,6 @@ (defun comp-tests-err-foo-f () (error "foo")) -;;FIXME: horrible... (defun comp-tests-condition-case-0-f () ;; Bpushhandler Bpophandler (condition-case diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 331e1cfed16..4f4005bea66 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,7 +29,7 @@ (require 'cl-lib) (require 'comp) -(setq comp-speed 0) +(setq comp-speed 3) (defconst comp-test-src (concat (file-name-directory (or load-file-name buffer-file-name)) @@ -205,7 +205,7 @@ (ert-deftest comp-tests-bubble-sort () "Run bubble sort." - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) + (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) From 24dcbf47d826f46821ed484f93ffb89d306a0b2d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Sep 2019 21:35:31 +0200 Subject: [PATCH 0362/1452] fix broken selfcall optimization --- src/comp.c | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index f966a2427b7..98932f79bb0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -147,6 +147,7 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ + Lisp_Object lfunc; gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; @@ -210,7 +211,7 @@ static void ice (const char* msg) { if (msg) - msg = format_string ("Internal native compiler error: %s", msg); + msg = format_string ("Internal native compiler error: %s", msg); else msg = "Internal native compiler error"; error ("%s", msg); @@ -394,6 +395,16 @@ static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { + /* Self call optimization. */ + if (!NILP (comp.lfunc) && + comp_speed >= 2 && + EQ (subr_sym, FUNCALL1 (comp-func-symbol-name, comp.lfunc))) + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.func, + nargs, + args); + Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); ICE_IF (NILP (value), "missing function declaration"); @@ -2651,6 +2662,8 @@ compile_function (Lisp_Object func) EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); bool ncall = (FUNCALL1 (comp-nargs-p, args)); + comp.lfunc = func; + if (!ncall) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); @@ -2733,6 +2746,7 @@ compile_function (Lisp_Object func) format_string ("failing to compile function %s with error: %s", SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), err)); + comp.lfunc = Qnil; SAFE_FREE (); } From 59035c17d08f0999ba96c74d1763eedb0347d11e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Sep 2019 21:39:03 +0200 Subject: [PATCH 0363/1452] add test for recursive calls --- test/src/comp-test-funcs.el | 6 ++++++ test/src/comp-tests.el | 3 +++ 2 files changed, 9 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index dbc90771774..e43db6973b7 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -221,6 +221,12 @@ (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)))))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4f4005bea66..16726cb4bbe 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -262,6 +262,9 @@ (ert-deftest comp-tests-lambda-return () (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) +(ert-deftest comp-tests-recursive () + (should (= (comp-tests-fib-f 10) 55))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 6a69e49f01fdd025912e2d4397ebe2f51e3f188d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Sep 2019 22:56:09 +0200 Subject: [PATCH 0364/1452] style nit --- src/comp.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 98932f79bb0..33ed4d6397b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2699,9 +2699,9 @@ compile_function (Lisp_Object func) frame_size), "local"); - gcc_jit_lvalue **frame = SAFE_ALLOCA (frame_size * sizeof (*frame)); + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); for (int i = 0; i < frame_size; ++i) - frame[i] = + comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, NULL, @@ -2709,7 +2709,6 @@ compile_function (Lisp_Object func) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, i)); - comp.frame = frame; comp.func_blocks = CALLN (Fmake_hash_table); From 77e80ae0136d1d79c0ee33b9780445aa6498664d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Sep 2019 19:43:12 +0200 Subject: [PATCH 0365/1452] fix missing cl- prefix in comp.el --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c398810186d..bbef9fc3799 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -290,7 +290,7 @@ Put PREFIX in front of it." (byte-compile-file filename) (setf (comp-ctxt-top-level-defvars comp-ctxt) (reverse (mapcar (lambda (x) - (ecase (car x) + (cl-ecase (car x) ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) From 7edbb163b322072da6666240a698b5dc5fc6aaef Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Sep 2019 21:51:37 +0200 Subject: [PATCH 0366/1452] rework basic block creation --- lisp/emacs-lisp/comp.el | 54 ++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 31 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bbef9fc3799..4e3f0c91e31 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -114,9 +114,10 @@ To be used when ncall-conv is nil.")) (nonrest nil :type number :documentation "Number of non rest arguments.")) -(cl-defstruct (comp-block (:copier nil)) +(cl-defstruct (comp-block (:copier nil) (:constructor make--comp-block)) "A basic block." - ;; The first two slots are used during limplification. + (name nil :type symbol) + ;; These two slots are used during limplification. (sp nil :documentation "When non nil indicates the sp value while entering into it.") @@ -326,6 +327,11 @@ If INPUT is a string this is the file path to be compiled." (defvar comp-block) (defvar comp-func) +(cl-defun comp-block-maybe-add (&rest args &key name &allow-other-keys) + (let ((blocks (comp-func-blocks comp-func))) + (unless (gethash name blocks) + (puthash name (apply #'make--comp-block args) blocks)))) + ;; (defun comp-opt-call (inst) ;; "Optimize if possible a side-effect-free call in INST." ;; (cl-destructuring-bind (_ f &rest args) inst @@ -464,10 +470,8 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Emit basic block BLOCK-NAME." (let ((blocks (comp-func-blocks comp-func))) ;; In case does not exist register it into comp-func-blocks. - (unless (gethash block-name blocks) - (puthash block-name - (make-comp-block :sp (comp-sp)) - blocks)) + (comp-block-maybe-add :name block-name + :sp (comp-sp)) ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) @@ -491,20 +495,13 @@ If DST-N is specified use it otherwise assume it to be the current slot." TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non nil negate the tested condition." - (let ((blocks (comp-func-blocks comp-func)) - (bb (comp-new-block-sym))) ;; Fall through block - (puthash bb - (make-comp-block :sp (comp-sp)) - blocks) + (let ((bb (comp-new-block-sym))) ;; Fall through block + (comp-block-maybe-add :name bb :sp (comp-sp)) (let ((target (comp-lap-to-limple-bb lap-label))) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) - (unless (gethash target blocks) - ;; Create the bb target only if does not exixsts already. - (puthash target - (make-comp-block :sp (+ target-offset (comp-sp))) - blocks)) + (comp-block-maybe-add :name target :sp (+ target-offset (comp-sp))) (comp-mark-block-closed)) (comp-emit-block bb))) @@ -540,21 +537,16 @@ If NEGATED non nil negate the tested condition." (defun comp-emit-handler (guarded-label handler-type) "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." - (let ((blocks (comp-func-blocks comp-func)) - (guarded-bb (comp-new-block-sym))) - (puthash guarded-bb - (make-comp-block :sp (comp-sp)) - blocks) - (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler (comp-slot+1) - handler-type - handler-bb - guarded-bb)) - (puthash handler-bb - (make-comp-block :sp (1+ (comp-sp))) - blocks) - (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) + (let ((guarded-bb (comp-new-block-sym))) + (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) + (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-emit (list 'push-handler (comp-slot+1) + handler-type + handler-bb + guarded-bb)) + (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) (defun comp-emit-switch (var m-hash) "Emit a limple for a lap jump table given VAR and M-HASH." From d6d5062bbae5ee708a0b80ad9b5f400320239fcc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Sep 2019 21:56:26 +0200 Subject: [PATCH 0367/1452] rework comp-new-frame --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4e3f0c91e31..17a8a7ef9f6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -351,10 +351,10 @@ If INPUT is a string this is the file path to be compiled." (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." - (let ((v (make-vector size nil))) - (cl-loop for i below size - do (aset v i (make-comp-mvar :slot i))) - v)) + (cl-loop with v = (make-vector size nil) + for i below size + do (aset v i (make-comp-mvar :slot i)) + finally (return v))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld From 89c144b83077aea584e9bbbf04e1d786220aec4c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Sep 2019 22:18:41 +0200 Subject: [PATCH 0368/1452] rename comp-ctxt-funcs comp-ctxt-exp-funcs --- lisp/emacs-lisp/comp.el | 8 ++++---- src/comp.c | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 17a8a7ef9f6..deeff88d26a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -84,9 +84,9 @@ (output nil :type 'string :documentation "Target output filename for the compilation.") (top-level-defvars nil :type list - :documentation "List of top level form to be compiled.") - (funcs () :type list - :documentation "Exported functions list.") + :documentation "List of top level form to be exp.") + (exp-funcs () :type list + :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") @@ -918,7 +918,7 @@ Top level forms for the current context are rendered too." Prepare every functions for final compilation and drive the C side." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-funcs comp-ctxt) + (setf (comp-ctxt-exp-funcs comp-ctxt) (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h for args = (comp-func-args f) diff --git a/src/comp.c b/src/comp.c index 33ed4d6397b..1c201c16c93 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1801,7 +1801,7 @@ emit_ctxt_code (void) IMPORTED_FUNC_RELOC_SYM); /* Exported functions info. */ - Lisp_Object func_list = FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt); + Lisp_Object func_list = FUNCALL1 (comp-ctxt-exp-funcs, Vcomp_ctxt); emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); SAFE_FREE (); } From c158b52ea421b4ea49adb79c445b712d18ad8273 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Sep 2019 23:13:13 +0200 Subject: [PATCH 0369/1452] add edge computation --- lisp/emacs-lisp/comp.el | 56 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index deeff88d26a..3e77c8a0833 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,6 +54,7 @@ (defconst comp-passes '(comp-spill-lap comp-limplify + comp-ssa comp-final) "Passes to be executed in order.") @@ -146,6 +147,10 @@ structure.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block.") + (edges () :type list + :documentation "List of edges connecting basic blocks.") + (edges-n 0 :type number + :documentation "In use just to generate edges numbers.") (ssa-cnt -1 :type number :documentation "Counter to create ssa limple vars.")) @@ -230,6 +235,17 @@ BODY is evaluate only if `comp-debug' is non nil." (comp-log (concat "\n<" (symbol-name block-name) ">")) (comp-log (comp-block-insns bb))))) +(defun comp-log-edges (func) + "Log edges in FUNC." + (let ((edges (comp-func-edges func))) + (comp-log (format "\nEdges in function: %s\n" (comp-func-symbol-name func))) + (mapc (lambda (e) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))))) + edges))) + ;;; spill-lap pass specific code. @@ -910,6 +926,46 @@ Top level forms for the current context are rendered too." (cons (comp-limplify-top-level) (mapcar #'comp-limplify-function funcs))) + +;;; SSA pass specific code. + +(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) + "An edge connecting two basic blocks." + (src nil :type comp-block) + (dst nil :type comp-block) + (number nil :type number + :documentation "The index number corresponding to this edge in the + edge vector.")) + +(cl-defun comp-block-add (&rest args &key &allow-other-keys) + (push (apply #'make--comp-edge + :number (cl-incf (comp-func-edges-n comp-func)) args) + (comp-func-edges comp-func))) + +(defun comp-ssa (funcs) + (cl-loop for comp-func in funcs do + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first _ third forth) = last-insn + do (cl-ecase op + (jump (comp-block-add :src bb + :dst (gethash first + blocks))) + (cond-jump + (progn + (comp-block-add :src bb + :dst (gethash third + blocks)) + (comp-block-add :src bb + :dst (gethash forth + blocks)))) + (return)) + finally (progn + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + (comp-log-edges comp-func))))) + ;;; Final pass specific code. From 03045e2e73eba5578218e09127055ab07a7c398b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 13 Sep 2019 17:55:16 +0200 Subject: [PATCH 0370/1452] ssa and endge number generation with generator --- lisp/emacs-lisp/comp.el | 41 ++++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3e77c8a0833..c0796417b4d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -127,6 +127,20 @@ into it.") (insns () :type list :documentation "List of instructions.")) +(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) + "An edge connecting two basic blocks." + (src nil :type comp-block) + (dst nil :type comp-block) + (number nil :type number + :documentation "The index number corresponding to this edge in the + edge vector.")) + +(defun comp-gen-counter () + "Return a sequential number generator." + (let ((n -1)) + (lambda () + (cl-incf n)))) + (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." (symbol-name nil @@ -149,9 +163,9 @@ structure.") LIMPLE basic block.") (edges () :type list :documentation "List of edges connecting basic blocks.") - (edges-n 0 :type number - :documentation "In use just to generate edges numbers.") - (ssa-cnt -1 :type number + (edge-cnt-gen (funcall #'comp-gen-counter) :type number + :documentation "Generates edges numbers.") + (ssa-cnt-gen (funcall #'comp-gen-counter) :type number :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) @@ -375,7 +389,7 @@ If INPUT is a string this is the file path to be compiled." (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld (comp-add-const-to-relocs constant)) - (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -487,7 +501,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (let ((blocks (comp-func-blocks comp-func))) ;; In case does not exist register it into comp-func-blocks. (comp-block-maybe-add :name block-name - :sp (comp-sp)) + :sp (comp-sp)) ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) @@ -929,17 +943,14 @@ Top level forms for the current context are rendered too." ;;; SSA pass specific code. -(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) - "An edge connecting two basic blocks." - (src nil :type comp-block) - (dst nil :type comp-block) - (number nil :type number - :documentation "The index number corresponding to this edge in the - edge vector.")) +;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). +;; "A Simple, Fast Dominance Algorithm". -(cl-defun comp-block-add (&rest args &key &allow-other-keys) - (push (apply #'make--comp-edge - :number (cl-incf (comp-func-edges-n comp-func)) args) +(defun comp-block-add (&rest args) + (push + (apply #'make--comp-edge + :number (funcall (comp-func-edge-cnt-gen comp-func)) + args) (comp-func-edges comp-func))) (defun comp-ssa (funcs) From e39f5e5c806dc0f7ee0f3520993ba061af7cb040 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 13 Sep 2019 20:56:24 +0200 Subject: [PATCH 0371/1452] compute dominator tree --- lisp/emacs-lisp/comp.el | 147 ++++++++++++++++++++++++++++++++-------- 1 file changed, 118 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c0796417b4d..a153e46dac9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -125,7 +125,15 @@ into it.") (closed nil :type boolean :documentation "If the block was already closed.") (insns () :type list - :documentation "List of instructions.")) + :documentation "List of instructions.") + (in-edges () :type list + :documentation "List of incoming edges.") + (out-edges () :type list + :documentation "List of outcoming edges.") + (dom nil :type comp-block + :documentation "Immediate dominator.") + (post-num nil :type number + :documentation "Post order number.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -135,6 +143,10 @@ into it.") :documentation "The index number corresponding to this edge in the edge vector.")) +(defun comp-block-preds (basic-block) + "Given BASIC-BLOCK return the list of its predecessors." + (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) + (defun comp-gen-counter () "Return a sequential number generator." (let ((n -1)) @@ -553,7 +565,7 @@ If NEGATED non nil negate the tested condition." (defun comp-new-block-sym () "Return a symbol naming the next new basic block." - (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) + (intern (format "bb-%s" (hash-table-count (comp-func-blocks comp-func))))) (defun comp-lap-to-limple-bb (n) "Given the LAP label N return the limple basic block." @@ -930,7 +942,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block 'bb_1) + (comp-emit-block 'bb-1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) @@ -943,39 +955,116 @@ Top level forms for the current context are rendered too." ;;; SSA pass specific code. -;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). -;; "A Simple, Fast Dominance Algorithm". - (defun comp-block-add (&rest args) (push (apply #'make--comp-edge :number (funcall (comp-func-edge-cnt-gen comp-func)) args) - (comp-func-edges comp-func))) + (comp-func-edges comp-func))) + +(defun comp-compute-edges () + "Compute the basic block edges for the current function." + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first _ third forth) = last-insn + do (cl-ecase op + (jump + (comp-block-add :src bb + :dst (gethash first + blocks))) + (cond-jump + (comp-block-add :src bb + :dst (gethash third + blocks)) + (comp-block-add :src bb + :dst (gethash forth + blocks))) + (return)) + finally (progn + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + do (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func)))) + +(defun comp-collect-rev-post-order (basic-block) + "Walk BASIC-BLOCK childs and return their name in reversed post-oder." + (let ((visited (make-hash-table)) + (acc ())) + (cl-labels ((collect-rec (bb) + (let ((name (comp-block-name bb))) + (unless (gethash name visited) + (puthash name t visited) + (cl-loop for e in (comp-block-out-edges bb) + for dst-block = (comp-edge-dst e) + do (collect-rec dst-block)) + (push name acc))))) + (collect-rec basic-block) + acc))) + +(defun comp-compute-dominator-tree () + "Compute immediate dominators for each basic block in current function." + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + ;; "A Simple, Fast Dominance Algorithm". + (cl-flet ((intersect (b1 b2) + (let ((finger1 (comp-block-post-num b1)) + (finger2 (comp-block-post-num b2))) + (while (not (= finger1 finger2)) + (while (< finger1 finger2) + (setf b1 (comp-block-dom b1)) + (setf finger1 (comp-block-post-num b1))) + (while (< finger2 finger1) + (setf b2 (comp-block-dom b2)) + (setf finger2 (comp-block-post-num b2)))) + b1)) + (first-processed (l) + (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) + p + (error "Cant't find first preprocessed")))) + (when-let ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the onli bb is entry. + (bb1 (gethash 'bb-1 blocks))) + (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) + with changed = t + while changed + initially (progn + (comp-log "Computing dominator tree...\n") + (setf (comp-block-dom entry) entry) + ;; Set the post order number. + (cl-loop for name in (reverse rev-bb-list) + for b = (gethash name blocks) + for i from 0 + do (setf (comp-block-post-num b) i))) + do (cl-loop + for name in (cdr rev-bb-list) + for b = (gethash name blocks) + for preds = (comp-block-preds b) + for new-idiom = (first-processed preds) + initially (setf changed nil) + do (cl-loop for p in (delq new-idiom preds) + when (comp-block-dom p) + do (setf new-idiom (intersect p new-idiom))) + unless (eq (comp-block-dom b) new-idiom) + do (progn + (setf (comp-block-dom b) new-idiom) + (setf changed t)))))) + (maphash (lambda (name bb) + (comp-log (format "block: %s dominator: %s\n" + name + (comp-block-name (comp-block-dom bb))))) + (comp-func-blocks comp-func))) (defun comp-ssa (funcs) - (cl-loop for comp-func in funcs do - (cl-loop with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - for last-insn = (car (last (comp-block-insns bb))) - for (op first _ third forth) = last-insn - do (cl-ecase op - (jump (comp-block-add :src bb - :dst (gethash first - blocks))) - (cond-jump - (progn - (comp-block-add :src bb - :dst (gethash third - blocks)) - (comp-block-add :src bb - :dst (gethash forth - blocks)))) - (return)) - finally (progn - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - (comp-log-edges comp-func))))) + (cl-loop for comp-func in funcs + do (progn + (comp-compute-edges) + (comp-compute-dominator-tree)))) ;;; Final pass specific code. From 634f71a2238b9e29d6bcab196092edfef19ebaef Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 10:13:38 +0200 Subject: [PATCH 0372/1452] add dominator frontiers computation --- lisp/emacs-lisp/comp.el | 59 +++++++++++++++++++++++++++++------------ 1 file changed, 42 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a153e46dac9..38a084f4d32 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -126,12 +126,15 @@ into it.") :documentation "If the block was already closed.") (insns () :type list :documentation "List of instructions.") + ;; All the followings are for SSA and CGF analysis. (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list :documentation "List of outcoming edges.") (dom nil :type comp-block :documentation "Immediate dominator.") + (df (make-hash-table) :type hash-table + :documentation "Dominance frontier set. Block -> block-name") (post-num nil :type number :documentation "Post order number.")) @@ -997,13 +1000,13 @@ Top level forms for the current context are rendered too." (let ((visited (make-hash-table)) (acc ())) (cl-labels ((collect-rec (bb) - (let ((name (comp-block-name bb))) - (unless (gethash name visited) - (puthash name t visited) - (cl-loop for e in (comp-block-out-edges bb) - for dst-block = (comp-edge-dst e) - do (collect-rec dst-block)) - (push name acc))))) + (let ((name (comp-block-name bb))) + (unless (gethash name visited) + (puthash name t visited) + (cl-loop for e in (comp-block-out-edges bb) + for dst-block = (comp-edge-dst e) + do (collect-rec dst-block)) + (push name acc))))) (collect-rec basic-block) acc))) @@ -1045,26 +1048,48 @@ Top level forms for the current context are rendered too." for name in (cdr rev-bb-list) for b = (gethash name blocks) for preds = (comp-block-preds b) - for new-idiom = (first-processed preds) + for new-idom = (first-processed preds) initially (setf changed nil) - do (cl-loop for p in (delq new-idiom preds) + do (cl-loop for p in (delq new-idom preds) when (comp-block-dom p) - do (setf new-idiom (intersect p new-idiom))) - unless (eq (comp-block-dom b) new-idiom) + do (setf new-idom (intersect p new-idom))) + unless (eq (comp-block-dom b) new-idom) do (progn - (setf (comp-block-dom b) new-idiom) - (setf changed t)))))) + (setf (comp-block-dom b) new-idom) + (setf changed t))))))) + +(defun comp-compute-dominator-frontiers () + ;; Again from : "A Simple, Fast Dominance Algorithm" + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + (cl-loop with blocks = (comp-func-blocks comp-func) + for b-name being each hash-keys of blocks + using (hash-value b) + for preds = (comp-block-preds b) + when (>= (length preds) 2) ; All joins + do (cl-loop for p in preds + for runner = p + do (while (not (eq runner (comp-block-dom b))) + (puthash b-name b (comp-block-df runner)) + (setf runner (comp-block-dom runner)))))) + +(defun comp-log-block-info () + "Log basic blocks info for the current function." (maphash (lambda (name bb) - (comp-log (format "block: %s dominator: %s\n" - name - (comp-block-name (comp-block-dom bb))))) + (let ((dom (comp-block-dom bb))) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of (comp-block-df bb) + collect b))))) (comp-func-blocks comp-func))) (defun comp-ssa (funcs) (cl-loop for comp-func in funcs do (progn (comp-compute-edges) - (comp-compute-dominator-tree)))) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info)))) ;;; Final pass specific code. From deeae4c415166eb144d008f0e904ffa70034c146 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 10:52:57 +0200 Subject: [PATCH 0373/1452] some code massage + doc into the SSA pass --- lisp/emacs-lisp/comp.el | 82 ++++++++++++++++++++++------------------- 1 file changed, 45 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 38a084f4d32..60a4c0ff008 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -957,43 +957,47 @@ Top level forms for the current context are rendered too." ;;; SSA pass specific code. - -(defun comp-block-add (&rest args) - (push - (apply #'make--comp-edge - :number (funcall (comp-func-edge-cnt-gen comp-func)) - args) - (comp-func-edges comp-func))) +;; After limplification no edges are present between basic blocks and an +;; implicit phi is present for every slot at the beginning of every basic block. +;; This pass is responsible for building all the edges and replace all m-vars +;; plus placing the needed phis. +;; Becase the number of phis placed is (supposed) to be the minimum necessary +;; this form is called 'minimal SSA form'. +;; This pass should be run every time basic blocks or mvar are shuffled. (defun comp-compute-edges () "Compute the basic block edges for the current function." - (cl-loop with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - for last-insn = (car (last (comp-block-insns bb))) - for (op first _ third forth) = last-insn - do (cl-ecase op - (jump - (comp-block-add :src bb - :dst (gethash first - blocks))) - (cond-jump - (comp-block-add :src bb - :dst (gethash third - blocks)) - (comp-block-add :src bb - :dst (gethash forth - blocks))) - (return)) - finally (progn - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - ;; Update edge refs into blocks. - (cl-loop for edge in (comp-func-edges comp-func) - do (push edge - (comp-block-out-edges (comp-edge-src edge))) - do (push edge - (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func)))) + (cl-flet ((edge-add (&rest args) + (push + (apply #'make--comp-edge + :number (funcall (comp-func-edge-cnt-gen comp-func)) + args) + (comp-func-edges comp-func)))) + + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first _ third forth) = last-insn + do (cl-ecase op + (jump + (edge-add :src bb :dst (gethash first + blocks))) + (cond-jump + (edge-add :src bb :dst (gethash third + blocks)) + (edge-add :src bb :dst (gethash forth + blocks))) + (return)) + finally (progn + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + do (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func))))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK childs and return their name in reversed post-oder." @@ -1031,7 +1035,7 @@ Top level forms for the current context are rendered too." (error "Cant't find first preprocessed")))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) - ;; No point to go on if the onli bb is entry. + ;; No point to go on if the only bb is 'entry'. (bb1 (gethash 'bb-1 blocks))) (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) with changed = t @@ -1075,17 +1079,21 @@ Top level forms for the current context are rendered too." (defun comp-log-block-info () "Log basic blocks info for the current function." (maphash (lambda (name bb) - (let ((dom (comp-block-dom bb))) + (let ((dom (comp-block-dom bb)) + (df (comp-block-df bb))) (comp-log (format "block: %s idom: %s DF %s\n" name (when dom (comp-block-name dom)) - (cl-loop for b being each hash-keys of (comp-block-df bb) + (cl-loop for b being each hash-keys of df collect b))))) (comp-func-blocks comp-func))) (defun comp-ssa (funcs) + "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs do (progn + ;; TODO: if run more than once should clean all CFG data + ;; plus phis here. (comp-compute-edges) (comp-compute-dominator-tree) (comp-compute-dominator-frontiers) From e4b32e3c572ef0786d2e6215ceeffb21d6046177 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 12:39:53 +0200 Subject: [PATCH 0374/1452] place phis --- lisp/emacs-lisp/comp.el | 66 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 58 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60a4c0ff008..30381e5fd47 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -61,6 +61,9 @@ (defconst comp-known-ret-types '((cons . cons)) "Alist used for type propagation.") +(defconst comp-limple-assignments '(set setimm set-par-to-local) + "Limple operators used to assign to mvars.") + (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax @@ -134,7 +137,7 @@ into it.") (dom nil :type comp-block :documentation "Immediate dominator.") (df (make-hash-table) :type hash-table - :documentation "Dominance frontier set. Block -> block-name") + :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number :documentation "Post order number.")) @@ -178,11 +181,16 @@ structure.") LIMPLE basic block.") (edges () :type list :documentation "List of edges connecting basic blocks.") - (edge-cnt-gen (funcall #'comp-gen-counter) :type number + (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") - (ssa-cnt-gen (funcall #'comp-gen-counter) :type number + (ssa-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Counter to create ssa limple vars.")) +(defun comp-func-reset-generators (func) + "Reset unique id generators for FUNC." + (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) + (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) + (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type number @@ -261,7 +269,7 @@ BODY is evaluate only if `comp-debug' is non nil." (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn - (comp-log (concat "\n<" (symbol-name block-name) ">")) + (comp-log (concat "\n<" (symbol-name block-name) ">\n")) (comp-log (comp-block-insns bb))))) (defun comp-log-edges (func) @@ -486,7 +494,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (comp-emit (list 'set (comp-slot) src-slot))))) + (comp-emit `(set ,(comp-slot) ,src-slot))))) (defun comp-emit-annotation (str) "Emit annotation STR." @@ -1033,6 +1041,7 @@ Top level forms for the current context are rendered too." (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) p (error "Cant't find first preprocessed")))) + (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. @@ -1088,16 +1097,57 @@ Top level forms for the current context are rendered too." collect b))))) (comp-func-blocks comp-func))) +(defun comp-place-phis () + "Place phi insns into the current function." + ;; Static Single Assignment Book + ;; Algorithm 3.1: Standard algorithm for inserting phi-functions + (cl-flet ((add-phi (slot-n bb) + ;; Add a phi func for slot SLOT-N at the top of BB. + (push `(phi ,slot-n) (comp-block-insns bb))) + (slot-assigned-p (slot-n bb) + ;; Return t if a SLOT-N was assigned within BB. + (cl-loop for insn in (comp-block-insns bb) + for op = (car insn) + when (and (cl-find op comp-limple-assignments) + (= slot-n (comp-mvar-slot (cadr insn)))) + do (return t)))) + + (cl-loop for i from 0 below (comp-func-frame-size comp-func) + ;; List of blocks with a definition of mvar i + with defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) + for b being each hash-value of blocks + when (slot-assigned-p i b) + collect b) + ;; Set of basic blocks where phi is added. + with f = () + ;; Worklist, set of basic blocks that contain definitions of v. + with w = defs-v + do + (while w + (let ((x (pop w))) + (cl-loop for y being each hash-value of (comp-block-df x) + unless (cl-find y f) + do (progn + (add-phi i y) + (push y f) + ;; Adding a phi implies mentioning the + ;; correspondig slot so in case adjust w. + (unless (cl-find y defs-v) + (push y w))))))))) + (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs do (progn - ;; TODO: if run more than once should clean all CFG data - ;; plus phis here. + ;; TODO: if this is run more than once we should clean all CFG + ;; data including phis here. + (comp-func-reset-generators comp-func) (comp-compute-edges) (comp-compute-dominator-tree) (comp-compute-dominator-frontiers) - (comp-log-block-info)))) + (comp-log-block-info) + (comp-place-phis) + (comp-log-func comp-func)))) ;;; Final pass specific code. From 6963deed24b13b448835be0d72d9b943ae2a345f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 14:51:43 +0200 Subject: [PATCH 0375/1452] add comp-dominator-tree-walker --- lisp/emacs-lisp/comp.el | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 30381e5fd47..2679ea390a3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1024,8 +1024,8 @@ Top level forms for the current context are rendered too." (defun comp-compute-dominator-tree () "Compute immediate dominators for each basic block in current function." + ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). - ;; "A Simple, Fast Dominance Algorithm". (cl-flet ((intersect (b1 b2) (let ((finger1 (comp-block-post-num b1)) (finger2 (comp-block-post-num b2))) @@ -1072,7 +1072,7 @@ Top level forms for the current context are rendered too." (setf changed t))))))) (defun comp-compute-dominator-frontiers () - ;; Again from : "A Simple, Fast Dominance Algorithm" + ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). (cl-loop with blocks = (comp-func-blocks comp-func) for b-name being each hash-keys of blocks @@ -1099,7 +1099,7 @@ Top level forms for the current context are rendered too." (defun comp-place-phis () "Place phi insns into the current function." - ;; Static Single Assignment Book + ;; Originally based on: Static Single Assignment Book ;; Algorithm 3.1: Standard algorithm for inserting phi-functions (cl-flet ((add-phi (slot-n bb) ;; Add a phi func for slot SLOT-N at the top of BB. @@ -1135,6 +1135,27 @@ Top level forms for the current context are rendered too." (unless (cl-find y defs-v) (push y w))))))))) +(defun comp-dominator-tree-walker (bb pre-lambda post-lambda) + "Dominator tree walker function starting from basic block BB. +PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." + (when pre-lambda + (funcall pre-lambda bb)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + when (eq bb (comp-block-dom child)) + ;; Current block is the immediate dominator the recur. + do (comp-dominator-tree-walker child pre-lambda post-lambda))) + (when post-lambda + (funcall post-lambda bb))) + +(defun comp-rename-mvars () + "Rename all mvar accoring to the new SSA rapresentation." + ;; Originally based on: Static Single Assignment Book + ;; Algorithm 3.3: Renaming algorithm + (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) nil + (lambda (bb) (comp-log (format "\n%s" (comp-block-name bb)))))) + (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs @@ -1147,7 +1168,8 @@ Top level forms for the current context are rendered too." (comp-compute-dominator-frontiers) (comp-log-block-info) (comp-place-phis) - (comp-log-func comp-func)))) + (comp-log-func comp-func) + (comp-rename-mvars)))) ;;; Final pass specific code. From cb2e6461f3db45df70334016b2a8411605eb847f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 15:25:11 +0200 Subject: [PATCH 0376/1452] core reorder --- lisp/emacs-lisp/comp.el | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2679ea390a3..47b034d0938 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -205,17 +205,12 @@ LIMPLE basic block.") (type nil :documentation "When non nil is used for type propagation.")) -(cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during function limplification." - (sp 0 :type fixnum - :documentation "Current stack pointer while walking LAP.") - (frame nil :type vector - :documentation "Meta-stack used to flat LAP.") - (block-name nil :type symbol - :documentation "Current basic block name.")) - (defvar comp-ctxt) ;; FIXME (to be removed) +;; Special vars used by some passes +(defvar comp-block) +(defvar comp-func) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. @@ -376,9 +371,14 @@ If INPUT is a string this is the file path to be compiled." ;;; Limplification pass specific code. -;; Special vars used during limplifications -(defvar comp-block) -(defvar comp-func) +(cl-defstruct (comp-limplify (:copier nil)) + "Support structure used during function limplification." + (sp 0 :type fixnum + :documentation "Current stack pointer while walking LAP.") + (frame nil :type vector + :documentation "Meta-stack used to flat LAP.") + (block-name nil :type symbol + :documentation "Current basic block name.")) (cl-defun comp-block-maybe-add (&rest args &key name &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) From b7d1b2e9462e8d81ec44c41d82d1b840ebc831f0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 17:00:16 +0200 Subject: [PATCH 0377/1452] add ssa renaming --- lisp/emacs-lisp/comp.el | 61 +++++++++++++++++++++++++++++++---------- 1 file changed, 47 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 47b034d0938..ab2d77d76c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,10 +193,10 @@ LIMPLE basic block.") (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (id nil :type number - :documentation "SSA number.") (slot nil :type fixnum :documentation "Slot position.") + (id nil :type number + :documentation "SSA number.") (const-vld nil :documentation "Valid signal for the following slot.") (constant nil @@ -212,6 +212,10 @@ LIMPLE basic block.") (defvar comp-func) +(defun comp-assign-op-p (op) + "Assignment predicate for OP." + (cl-find op comp-limple-assignments)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." @@ -1107,8 +1111,7 @@ Top level forms for the current context are rendered too." (slot-assigned-p (slot-n bb) ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) - for op = (car insn) - when (and (cl-find op comp-limple-assignments) + when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) do (return t)))) @@ -1131,7 +1134,7 @@ Top level forms for the current context are rendered too." (add-phi i y) (push y f) ;; Adding a phi implies mentioning the - ;; correspondig slot so in case adjust w. + ;; corresponding slot so in case adjust w. (unless (cl-find y defs-v) (push y w))))))))) @@ -1144,17 +1147,47 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-loop for ed in out-edges for child = (comp-edge-dst ed) when (eq bb (comp-block-dom child)) - ;; Current block is the immediate dominator the recur. + ;; Current block is the immediate dominator then recur. do (comp-dominator-tree-walker child pre-lambda post-lambda))) (when post-lambda (funcall post-lambda bb))) -(defun comp-rename-mvars () - "Rename all mvar accoring to the new SSA rapresentation." - ;; Originally based on: Static Single Assignment Book - ;; Algorithm 3.3: Renaming algorithm - (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) nil - (lambda (bb) (comp-log (format "\n%s" (comp-block-name bb)))))) +(cl-defstruct (comp-ssa (:copier nil)) + "Support structure used while SSA renaming." + (frame (comp-new-frame (comp-func-frame-size comp-func)) :type vector + :documentation "Vector of mvars.")) + +(defun comp-ssa-rename-insn (insn slot-n) + (cl-flet ((target-p (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x))))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-mvar :slot slot-n))) + (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) + (setf (cadr insn) mvar))) + (_ + (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) + ;; Should we have to recur? + (cl-nsubstitute-if mvar #'target-p (cdr insn))))))) + +(defun comp-ssa-rename-in-blocks (n) + "Given slot number N rename in the blocks." + (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) + (lambda (b) + (cl-loop for insn in (comp-block-insns b) + do (comp-ssa-rename-insn insn n))) + nil)) + +(defun comp-ssa-rename () + "Entry point to rename SSA within the current function." + (comp-log "Renaming\n") + (cl-loop with comp-pass = (make-comp-ssa) + for n from 0 below (comp-func-frame-size comp-func) + ;; For every slot frame rename down to the dominator tree. + do (comp-ssa-rename-in-blocks n))) (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." @@ -1168,8 +1201,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-compute-dominator-frontiers) (comp-log-block-info) (comp-place-phis) - (comp-log-func comp-func) - (comp-rename-mvars)))) + (comp-ssa-rename) + (comp-log-func comp-func)))) ;;; Final pass specific code. From 7abf1ca1212d91d0d50d3dd4f6386fac98fd2209 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 17:55:03 +0200 Subject: [PATCH 0378/1452] add phi finalizer --- lisp/emacs-lisp/comp.el | 55 ++++++++++++++++++++++++++++++----------- 1 file changed, 41 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ab2d77d76c8..7804f97bf64 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -139,7 +139,10 @@ into it.") (df (make-hash-table) :type hash-table :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number - :documentation "Post order number.")) + :documentation "Post order number.") + (final-frame nil :type vector + :documentation "This is a copy of the frame when leaving the block. +Is in use to help the SSA rename pass.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -1138,7 +1141,7 @@ Top level forms for the current context are rendered too." (unless (cl-find y defs-v) (push y w))))))))) -(defun comp-dominator-tree-walker (bb pre-lambda post-lambda) +(defun comp-dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (when pre-lambda @@ -1148,7 +1151,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for child = (comp-edge-dst ed) when (eq bb (comp-block-dom child)) ;; Current block is the immediate dominator then recur. - do (comp-dominator-tree-walker child pre-lambda post-lambda))) + do (comp-dom-tree-walker child pre-lambda post-lambda))) (when post-lambda (funcall post-lambda bb))) @@ -1161,25 +1164,48 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-flet ((target-p (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) - (eql slot-n (comp-mvar-slot x))))) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-mvar :slot slot-n))) + (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) + (setf (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-mvar :slot slot-n))) - (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) - (setf (cadr insn) mvar))) + (new-lvalue)) + (`(phi . ,_) + (new-lvalue)) (_ (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - ;; Should we have to recur? + ;; Should we have to recur for nested args? (cl-nsubstitute-if mvar #'target-p (cdr insn))))))) (defun comp-ssa-rename-in-blocks (n) "Given slot number N rename in the blocks." - (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) - (lambda (b) - (cl-loop for insn in (comp-block-insns b) - do (comp-ssa-rename-insn insn n))) - nil)) + (comp-dom-tree-walker (gethash 'entry (comp-func-blocks comp-func)) + (lambda (b) + (cl-loop for insn in (comp-block-insns b) + do (comp-ssa-rename-insn insn n)) + ;; Save a copy of the frame while leaving. + (setf (comp-block-final-frame b) + (copy-sequence (comp-ssa-frame comp-pass)))) + nil)) + +(defun comp-finalize-phis () + "Fixup r-values into phis in all basic blocks." + (cl-flet ((finalize-phi (args b) + ;; Concatenate into args all incoming mvars for this phi. + (setcdr args + (cl-loop with slot-n = (comp-mvar-slot (car args)) + for e in (comp-block-in-edges b) + for b = (comp-edge-src e) + for in-frame = (comp-block-final-frame b) + collect (aref in-frame slot-n))) )) + + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for (op . args) in (comp-block-insns b) + when (eq op 'phi) + do (finalize-phi args b))))) (defun comp-ssa-rename () "Entry point to rename SSA within the current function." @@ -1202,6 +1228,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-log-block-info) (comp-place-phis) (comp-ssa-rename) + (comp-finalize-phis) (comp-log-func comp-func)))) From d7173579a7e9a0f71ccd02fdc9f694b49aadbd47 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Sep 2019 18:12:16 +0200 Subject: [PATCH 0379/1452] remove incomplete propagation during limplification pass --- lisp/emacs-lisp/comp.el | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7804f97bf64..08a6d59ff9c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -197,8 +197,8 @@ LIMPLE basic block.") (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum - :documentation "Slot position.") - (id nil :type number + :documentation "Slot number.") + (id nil :type (or null number) :documentation "SSA number.") (const-vld nil :documentation "Valid signal for the following slot.") @@ -409,6 +409,12 @@ If INPUT is a string this is the file path to be compiled." (comp-add-subr-to-relocs func) `(callref ,func ,@args)) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) + (when const-vld + (comp-add-const-to-relocs constant)) + (make--comp-mvar :slot slot :const-vld const-vld :constant constant + :type type)) + (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." (cl-loop with v = (make-vector size nil) @@ -416,13 +422,6 @@ If INPUT is a string this is the file path to be compiled." do (aset v i (make-comp-mvar :slot i)) finally (return v))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) - (when const-vld - (comp-add-const-to-relocs constant)) - (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) - :slot slot :const-vld const-vld :constant constant - :type type)) - (defmacro comp-sp () "Current stack pointer." '(comp-limplify-sp comp-pass)) @@ -459,11 +458,6 @@ Restore the original value afterwards." "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." (cl-assert call) - (setf (comp-slot) - (make-comp-mvar :slot (comp-sp) - :type (when (> comp-speed 0) - (alist-get (cadr call) - comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) (defmacro comp-emit-set-call-subr (subr-name sp-delta) @@ -511,8 +505,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Set constant VAL to current slot." (let ((rel-idx (comp-add-const-to-relocs val))) (cl-assert (numberp rel-idx)) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :constant val)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) (defun comp-mark-block-closed () @@ -976,10 +968,15 @@ Top level forms for the current context are rendered too." ;; implicit phi is present for every slot at the beginning of every basic block. ;; This pass is responsible for building all the edges and replace all m-vars ;; plus placing the needed phis. -;; Becase the number of phis placed is (supposed) to be the minimum necessary +;; Because the number of phis placed is (supposed) to be the minimum necessary ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or mvar are shuffled. +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + (defun comp-compute-edges () "Compute the basic block edges for the current function." (cl-flet ((edge-add (&rest args) @@ -1167,7 +1164,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (eql slot-n (comp-mvar-slot x)))) (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-mvar :slot slot-n))) + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) (setf (cadr insn) mvar)))) (pcase insn From c74f30c8e0f1799ebca7eb144c56506a53290243 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Sep 2019 10:50:33 +0200 Subject: [PATCH 0380/1452] fix ssa renaming --- lisp/emacs-lisp/comp.el | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 08a6d59ff9c..0ad8b1a310a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1169,13 +1169,13 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setf (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - (new-lvalue)) - (`(phi . ,_) - (new-lvalue)) + (cl-nsubst-if (new-lvalue) #'target-p (cddr insn))) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) (_ (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - ;; Should we have to recur for nested args? - (cl-nsubstitute-if mvar #'target-p (cdr insn))))))) + (cl-nsubst-if mvar #'target-p (cdr insn))))))) (defun comp-ssa-rename-in-blocks (n) "Given slot number N rename in the blocks." From 33ce5fe9da02f0d0f4e0c32b86dde5c5e81c9565 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Sep 2019 12:07:04 +0200 Subject: [PATCH 0381/1452] clean-up limplify --- lisp/emacs-lisp/comp.el | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0ad8b1a310a..11da06cc022 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -491,10 +491,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-with-sp (if dst-n dst-n (comp-sp)) (let ((src-slot (comp-slot-n src-n))) (cl-assert src-slot) - ;; FIXME id should encrease here. - (setf (comp-slot) - (copy-sequence src-slot)) - (setf (comp-mvar-slot (comp-slot)) (comp-sp)) (comp-emit `(set ,(comp-slot) ,src-slot))))) (defun comp-emit-annotation (str) @@ -533,10 +529,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit-jump block-name)) ;; Set this a currently compiled block. (setf comp-block (gethash block-name blocks)) - ;; Every new block we are forced to wipe out all the frame. - ;; This will be optimized by proper flow analysis. - (setf (comp-limplify-frame comp-pass) - (comp-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name blocks))) @@ -1154,7 +1146,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func)) :type vector + (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector :documentation "Vector of mvars.")) (defun comp-ssa-rename-insn (insn slot-n) From bbde29c012868e130388d9975beded563643a7a7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Sep 2019 12:08:22 +0200 Subject: [PATCH 0382/1452] add ssa param to comp-new-frame --- lisp/emacs-lisp/comp.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 11da06cc022..51a120bb405 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -415,11 +415,13 @@ If INPUT is a string this is the file path to be compiled." (make--comp-mvar :slot slot :const-vld const-vld :constant constant :type type)) -(defun comp-new-frame (size) +(defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE." (cl-loop with v = (make-vector size nil) for i below size - do (aset v i (make-comp-mvar :slot i)) + for mvar = (if ssa (make-comp-ssa-mvar :slot i) + (make-comp-mvar :slot i)) + do (aset v i mvar) finally (return v))) (defmacro comp-sp () From 94cae7b2bc02f49f238496ae4c386bcb9cafaeea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Sep 2019 12:31:44 +0200 Subject: [PATCH 0383/1452] fix again ssa renaming --- lisp/emacs-lisp/comp.el | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 51a120bb405..963e7e03c4d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1163,7 +1163,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setf (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - (cl-nsubst-if (new-lvalue) #'target-p (cddr insn))) + (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) + (cl-nsubst-if mvar #'target-p (cdr insn))) + (new-lvalue)) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) @@ -1177,9 +1179,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (lambda (b) (cl-loop for insn in (comp-block-insns b) do (comp-ssa-rename-insn insn n)) - ;; Save a copy of the frame while leaving. - (setf (comp-block-final-frame b) - (copy-sequence (comp-ssa-frame comp-pass)))) + ;; Save a copy into final frame while leaving. + (setf (aref (comp-block-final-frame b) n) + (aref (comp-ssa-frame comp-pass) n))) nil)) (defun comp-finalize-phis () @@ -1201,10 +1203,15 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename () "Entry point to rename SSA within the current function." (comp-log "Renaming\n") - (cl-loop with comp-pass = (make-comp-ssa) - for n from 0 below (comp-func-frame-size comp-func) - ;; For every slot frame rename down to the dominator tree. - do (comp-ssa-rename-in-blocks n))) + (let ((frame-size (comp-func-frame-size comp-func))) + ;; Initialize the final frame. + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (setf (comp-block-final-frame b) (make-vector frame-size nil))) + ;; Do the renaming for each frame slot. + (cl-loop with comp-pass = (make-comp-ssa) + for n from 0 below frame-size + ;; For every slot frame rename down to the dominator tree. + do (comp-ssa-rename-in-blocks n)))) (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." @@ -1220,7 +1227,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func)))) + (comp-log-func comp-func))) + funcs) + ;;; Final pass specific code. @@ -1234,8 +1243,7 @@ Prepare every functions for final compilation and drive the C side." (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h for args = (comp-func-args f) - for doc = (when (> (length (comp-func-byte-func f)) - 4) + for doc = (when (> (length (comp-func-byte-func f)) 4) (aref (comp-func-byte-func f) 4)) collect (vector (comp-func-symbol-name f) (comp-func-c-func-name f) From 351576f913ded76fc2e984c3ad42d47c5c5bc482 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Sep 2019 14:43:30 +0200 Subject: [PATCH 0384/1452] adding propagation --- lisp/emacs-lisp/comp.el | 82 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 79 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 963e7e03c4d..21a80c04725 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -55,10 +55,19 @@ (defconst comp-passes '(comp-spill-lap comp-limplify comp-ssa + comp-propagate comp-final) "Passes to be executed in order.") -(defconst comp-known-ret-types '((cons . cons)) +;; TODO hash here. +(defconst comp-known-ret-types '((cons . cons) + (1+ . number) + (1- . number) + (+ . number) + (- . number) + (* . number) + (/ . number) + (% . number)) "Alist used for type propagation.") (defconst comp-limple-assignments '(set setimm set-par-to-local) @@ -200,13 +209,15 @@ LIMPLE basic block.") :documentation "Slot number.") (id nil :type (or null number) :documentation "SSA number.") - (const-vld nil + (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil :documentation "When const-vld non nil this is used for constant propagation.") (type nil - :documentation "When non nil is used for type propagation.")) + :documentation "When non nil is used for type propagation.") + (ref nil :type boolean + :documentation "When t this is used by reference.")) (defvar comp-ctxt) ;; FIXME (to be removed) @@ -215,6 +226,13 @@ LIMPLE basic block.") (defvar comp-func) + +(defsubst comp-mvar-propagate (lval rval) + "Propagate into LVAL properties of RVAL." + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) + (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) + (setf (comp-mvar-type lval) (comp-mvar-type rval))) + (defun comp-assign-op-p (op) "Assignment predicate for OP." (cl-find op comp-limple-assignments)) @@ -1230,6 +1248,64 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-log-func comp-func))) funcs) + +;;; propagate pass specific code. +;; A very basic propagation pass follows. + +(defun comp-basic-const-propagate () + "Propagate simple constants for setimm operands. +This can run just once." + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for insn in (comp-block-insns b) + do (pcase insn + (`(setimm ,lval ,_ ,v) + (setf (comp-mvar-const-vld lval) t) + (setf (comp-mvar-constant lval) v) + (setf (comp-mvar-type lval) (type-of v))))))) + +(defun comp-propagate-insn (insn) + (pcase insn + (`(set ,lval ,rval) + (pcase rval + (`(call ,f . ,_) + (setf (comp-mvar-type lval) + (cdr (assq f comp-known-ret-types)))) + (`(callref ,f . ,args) + (cl-loop for v in args + do (setf (comp-mvar-ref v) t)) + (setf (comp-mvar-type lval) + (cdr (assq f comp-known-ret-types)))) + (_ + (comp-mvar-propagate lval rval)))) + (`(phi ,lval . ,rest) + ;; Const prop here. + (when (and (cl-every #'comp-mvar-const-vld rest) + (cl-reduce #'equal (mapcar #'comp-mvar-constant rest))) + (setf (comp-mvar-constant lval) (comp-mvar-constant (car rest)))) + ;; Type propagation. + ;; FIXME: checking for type equality is not sufficient cause does not + ;; account type hierarchy!! + (when (cl-reduce #'eq (mapcar #'comp-mvar-type rest)) + (setf (comp-mvar-type lval) (comp-mvar-type (car rest)))) + ;; Reference propagation. + (setf (comp-mvar-ref lval) (cl-every #'comp-mvar-ref rest))))) + +(defun comp-propagate* () + "Propagate for set and phi operands." + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for insn in (comp-block-insns b) + do (comp-propagate-insn insn)))) + +(defun comp-propagate (funcs) + (cl-loop for comp-func in funcs + do + (progn + (comp-basic-const-propagate) + ;; FIXME: unbelievably dumb... + (cl-loop repeat 10 + do (comp-propagate*)) + (comp-log-func comp-func))) + funcs) ;;; Final pass specific code. From 747c6a0dc8e53d66c785500d122957f4a17a9325 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Sep 2019 15:41:42 +0200 Subject: [PATCH 0385/1452] modify callref format to explicitate mvars --- lisp/emacs-lisp/comp.el | 5 ++++- src/comp.c | 7 ++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 21a80c04725..615d34268aa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -425,7 +425,10 @@ If INPUT is a string this is the file path to be compiled." (defun comp-callref (func &rest args) "Emit a call usign narg abi for FUNC with ARGS." (comp-add-subr-to-relocs func) - `(callref ,func ,@args)) + `(callref ,func ,@(cl-loop with (nargs off) = args + repeat nargs + for sp from off + collect (comp-slot-n sp)))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld diff --git a/src/comp.c b/src/comp.c index 1c201c16c93..f2733625b51 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1143,11 +1143,12 @@ emit_limple_call (Lisp_Object insn) static gcc_jit_rvalue * emit_limple_call_ref (Lisp_Object insn) { - /* Ex: (callref Fplus 2 0). */ + /* Ex: (callref < #s(comp-mvar 1 6 nil nil nil t) + #s(comp-mvar 2 11 t 10 integer t)). */ Lisp_Object callee = FIRST (insn); - EMACS_UINT nargs = XFIXNUM (SECOND (insn)); - EMACS_UINT base_ptr = XFIXNUM (THIRD (insn)); + EMACS_UINT nargs = XFIXNUM (Flength (CDR (CDR (insn)))); + EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, THIRD (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } From 6d1c453726cf8a903c6bc555bacf20b7a4ac8651 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Sep 2019 19:47:49 +0200 Subject: [PATCH 0386/1452] fix switch emission due to missing const prop --- lisp/emacs-lisp/comp.el | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 615d34268aa..da2c488ef74 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -615,13 +615,15 @@ If NEGATED non nil negate the tested condition." (comp-mark-block-closed) (comp-emit-block guarded-bb)))) -(defun comp-emit-switch (var m-hash) - "Emit a limple for a lap jump table given VAR and M-HASH." - (cl-assert (comp-mvar-const-vld m-hash)) - (cl-loop for test being each hash-keys of (comp-mvar-constant m-hash) - using (hash-value target-label) - for m-test = (make-comp-mvar :constant test) - do (comp-emit-cond-jump var m-test 0 target-label nil))) +(defun comp-emit-switch (var last-insn) + "Emit a limple for a lap jump table given VAR and LAST-INSN." + (pcase last-insn + (`(setimm ,_ ,_ ,const) + (cl-loop for test being each hash-keys of const + using (hash-value target-label) + for m-test = (make-comp-mvar :constant test) + do (comp-emit-cond-jump var m-test 0 target-label nil))) + (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-funcall (narg) "Avoid Ffuncall trampoline if possibile. @@ -888,7 +890,9 @@ the annotation emission." (byte-discardN (comp-stack-adjust (- arg))) (byte-switch - (comp-emit-switch (comp-slot+1) (comp-slot-n (+ 2 (comp-sp))))) + ;; Assume to follow the emission of a setimm. + ;; This is checked into comp-emit-switch. + (comp-emit-switch (comp-slot+1) (cl-second (comp-block-insns comp-block)))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos From ca28d5fd72d3cc7e960f4f2bd1d8cf00ac3622dd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Sep 2019 19:48:13 +0200 Subject: [PATCH 0387/1452] add some notes --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da2c488ef74..04096d65a94 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -222,7 +222,7 @@ LIMPLE basic block.") (defvar comp-ctxt) ;; FIXME (to be removed) ;; Special vars used by some passes -(defvar comp-block) +(defvar comp-block) ; Can probably be removed (defvar comp-func) @@ -884,7 +884,7 @@ the annotation emission." (comp-stack-adjust (- 1 arg)) (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set - (comp-with-sp (1+ (comp-sp)) + (comp-with-sp (1+ (comp-sp)) ;; FIXME!! (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN From 05b733e86c108bdacd3ff45d05d560d7b8778a9b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Sep 2019 20:11:05 +0200 Subject: [PATCH 0388/1452] fix comp-compute-edges handling all kind of branches --- lisp/emacs-lisp/comp.el | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 04096d65a94..c7d9ab37958 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1008,16 +1008,19 @@ Top level forms for the current context are rendered too." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) - for (op first _ third forth) = last-insn + for (op first second third forth) = last-insn do (cl-ecase op (jump - (edge-add :src bb :dst (gethash first - blocks))) + (edge-add :src bb :dst (gethash first blocks))) (cond-jump - (edge-add :src bb :dst (gethash third - blocks)) - (edge-add :src bb :dst (gethash forth - blocks))) + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) + (cond-jump-narg-leq + (edge-add :src bb :dst (gethash second blocks)) + (edge-add :src bb :dst (gethash third blocks))) + (push-handler + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) (return)) finally (progn (setf (comp-func-edges comp-func) From aba160b043588171eac8235105d45b30a7f141f5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Sep 2019 20:23:57 +0200 Subject: [PATCH 0389/1452] fix callref parsing into C back-end --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index f2733625b51..2846037e5a0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1147,8 +1147,8 @@ emit_limple_call_ref (Lisp_Object insn) #s(comp-mvar 2 11 t 10 integer t)). */ Lisp_Object callee = FIRST (insn); - EMACS_UINT nargs = XFIXNUM (Flength (CDR (CDR (insn)))); - EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, THIRD (insn))); + EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); + EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } From 17ecb1c728edebd00a787fd6c4bdf8b7722e9a2f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Sep 2019 22:18:19 +0200 Subject: [PATCH 0390/1452] give back basic block a C like name --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c7d9ab37958..e15a29e779d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -590,7 +590,7 @@ If NEGATED non nil negate the tested condition." (defun comp-new-block-sym () "Return a symbol naming the next new basic block." - (intern (format "bb-%s" (hash-table-count (comp-func-blocks comp-func))))) + (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) (defun comp-lap-to-limple-bb (n) "Given the LAP label N return the limple basic block." @@ -971,7 +971,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block 'bb-1) + (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) @@ -1071,7 +1071,7 @@ Top level forms for the current context are rendered too." (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. - (bb1 (gethash 'bb-1 blocks))) + (bb1 (gethash 'bb_1 blocks))) (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) with changed = t while changed From 83a146b24ec230539c4520a4315b8bcdeebdb434 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Sep 2019 22:18:58 +0200 Subject: [PATCH 0391/1452] rewriting ssa rename --- lisp/emacs-lisp/comp.el | 101 +++++++++++++++++++--------------------- 1 file changed, 47 insertions(+), 54 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e15a29e779d..f56a66a5666 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -148,10 +148,7 @@ into it.") (df (make-hash-table) :type hash-table :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number - :documentation "Post order number.") - (final-frame nil :type vector - :documentation "This is a copy of the frame when leaving the block. -Is in use to help the SSA rename pass.")) + :documentation "Post order number.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -227,12 +224,6 @@ LIMPLE basic block.") -(defsubst comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) - (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) - (setf (comp-mvar-type lval) (comp-mvar-type rval))) - (defun comp-assign-op-p (op) "Assignment predicate for OP." (cl-find op comp-limple-assignments)) @@ -1179,38 +1170,47 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector :documentation "Vector of mvars.")) -(defun comp-ssa-rename-insn (insn slot-n) - (cl-flet ((target-p (x) - ;; Ret t if x is an mvar and target the correct slot number. - (and (comp-mvar-p x) - (eql slot-n (comp-mvar-slot x)))) - (new-lvalue () - ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) - (setf (cadr insn) mvar)))) - (pcase insn - (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - (cl-nsubst-if mvar #'target-p (cdr insn))) - (new-lvalue)) - (`(phi ,n) - (when (equal n slot-n) - (new-lvalue))) - (_ - (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - (cl-nsubst-if mvar #'target-p (cdr insn))))))) +(defun comp-ssa-rename-insn (insn frame) + (dotimes (slot-n (comp-func-frame-size comp-func)) + (cl-flet ((target-p (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (setf (aref frame slot-n) mvar) + (setf (cadr insn) mvar)))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) + (let ((mvar (aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn)))) + (new-lvalue)) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) + (_ + (let ((mvar (aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn))))))))) -(defun comp-ssa-rename-in-blocks (n) - "Given slot number N rename in the blocks." - (comp-dom-tree-walker (gethash 'entry (comp-func-blocks comp-func)) - (lambda (b) - (cl-loop for insn in (comp-block-insns b) - do (comp-ssa-rename-insn insn n)) - ;; Save a copy into final frame while leaving. - (setf (aref (comp-block-final-frame b) n) - (aref (comp-ssa-frame comp-pass) n))) - nil)) +(defun comp-ssa-rename () + "Entry point to rename SSA within the current function." + (comp-log "Renaming\n") + (let ((frame-size (comp-func-frame-size comp-func)) + (visited (make-hash-table))) + (cl-labels ((ssa-rename-rec (bb in-frame) + (unless (gethash bb visited) + (puthash bb t visited) + (cl-loop for insn in (comp-block-insns bb) + do (comp-ssa-rename-insn insn in-frame)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + ;; Provide a copy of the same frame to all childs. + do (ssa-rename-rec child (copy-sequence in-frame))))))) + + (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) + (comp-new-frame frame-size t))))) (defun comp-finalize-phis () "Fixup r-values into phis in all basic blocks." @@ -1228,19 +1228,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-ssa-rename () - "Entry point to rename SSA within the current function." - (comp-log "Renaming\n") - (let ((frame-size (comp-func-frame-size comp-func))) - ;; Initialize the final frame. - (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (setf (comp-block-final-frame b) (make-vector frame-size nil))) - ;; Do the renaming for each frame slot. - (cl-loop with comp-pass = (make-comp-ssa) - for n from 0 below frame-size - ;; For every slot frame rename down to the dominator tree. - do (comp-ssa-rename-in-blocks n)))) - (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs @@ -1273,6 +1260,12 @@ This can run just once." (setf (comp-mvar-constant lval) v) (setf (comp-mvar-type lval) (type-of v))))))) +(defsubst comp-mvar-propagate (lval rval) + "Propagate into LVAL properties of RVAL." + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) + (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) + (setf (comp-mvar-type lval) (comp-mvar-type rval))) + (defun comp-propagate-insn (insn) (pcase insn (`(set ,lval ,rval) From 69cbf2b2f304f82c6d77cd663d4211bf125ebe74 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 17 Sep 2019 01:01:34 +0200 Subject: [PATCH 0392/1452] keep on fixing ssa --- lisp/emacs-lisp/comp.el | 25 +++++++++++++++++-------- src/comp.c | 19 +++++++++++++------ 2 files changed, 30 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f56a66a5666..c390225e064 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -70,7 +70,11 @@ (% . number)) "Alist used for type propagation.") -(defconst comp-limple-assignments '(set setimm set-par-to-local) +(defconst comp-limple-assignments '(set + setimm + set-par-to-local + set-args-to-local + set-rest-args-to-local) "Limple operators used to assign to mvars.") (defconst comp-mostly-pure-funcs @@ -148,7 +152,10 @@ into it.") (df (make-hash-table) :type hash-table :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number - :documentation "Post order number.")) + :documentation "Post order number.") + (final-frame nil :type vector + :documentation "This is a copy of the frame when leaving the block. +Is in use to help the SSA rename pass.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -894,7 +901,7 @@ the annotation emission." "Emit the prologue for a narg function." (cl-loop for i below minarg do (progn - (comp-emit `(set-args-to-local ,i)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) @@ -903,7 +910,7 @@ the annotation emission." (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) (comp-mark-block-closed) (comp-emit-block bb) - (comp-emit `(set-args-to-local ,i)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args))) finally (comp-emit-jump 'entry_rest_args)) (cl-loop for i from minarg below nonrest @@ -911,7 +918,7 @@ the annotation emission." (comp-emit-block (intern (format "entry_fallback_%s" i))) (comp-emit-set-const nil))) (comp-emit-block 'entry_rest_args) - (comp-emit `(set-rest-args-to-local ,nonrest))) + (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (defun comp-limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." @@ -1130,14 +1137,14 @@ Top level forms for the current context are rendered too." (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i - with defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) + for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) for b being each hash-value of blocks when (slot-assigned-p i b) collect b) ;; Set of basic blocks where phi is added. - with f = () + for f = () ;; Worklist, set of basic blocks that contain definitions of v. - with w = defs-v + for w = defs-v do (while w (let ((x (pop w))) @@ -1203,6 +1210,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (puthash bb t visited) (cl-loop for insn in (comp-block-insns bb) do (comp-ssa-rename-insn insn in-frame)) + (setf (comp-block-final-frame bb) + (copy-sequence in-frame)) (when-let ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) diff --git a/src/comp.c b/src/comp.c index 2846037e5a0..8aadd5acc91 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1265,6 +1265,10 @@ emit_limple_insn (Lisp_Object insn) n); emit_cond_jump (test, target2, target1); } + else if (EQ (op, Qphi)) + { + /* Nothing to do for phis into the backend. */ + } else if (EQ (op, Qpush_handler)) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1350,7 +1354,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_args_to_local)) { /* - Limple: (set-args-to-local 1) + Limple: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) C: local[1] = *args; */ gcc_jit_rvalue *gcc_args = @@ -1360,7 +1364,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *res = gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); - EMACS_UINT slot_n = XFIXNUM (arg0); + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_block_add_assignment (comp.block, NULL, comp.frame[slot_n], @@ -1369,13 +1373,15 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_rest_args_to_local)) { /* - Limple: (set-rest-args-to-local 3) - C: local[3] = list (nargs - 3, args); + Limple: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) + C: local[2] = list (nargs - 2, args); */ + + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, - XFIXNUM (arg0)); + slot_n); gcc_jit_lvalue *nargs = gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); gcc_jit_lvalue *args = @@ -1395,7 +1401,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block_add_assignment (comp.block, NULL, - comp.frame[XFIXNUM (arg0)], + comp.frame[slot_n], res); } else if (EQ (op, Qinc_args)) @@ -3274,6 +3280,7 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qphi, "phi"); /* In use for prologue emission. */ DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); From 47b22e55141da090a3d4688851eaa808f9489078 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 17 Sep 2019 13:18:40 +0200 Subject: [PATCH 0393/1452] add pushhandler to clobber operators --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c390225e064..076380732f9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,8 +74,9 @@ setimm set-par-to-local set-args-to-local - set-rest-args-to-local) - "Limple operators used to assign to mvars.") + set-rest-args-to-local + push-handler) + "Limple operators that clobbers the first mvar argument.") (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior From a317620a52746ea4346eabf4559a1caac2b63011 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Sep 2019 11:30:23 +0200 Subject: [PATCH 0394/1452] add comp-call-optim pass --- lisp/emacs-lisp/comp.el | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 076380732f9..8f93efd73ad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -56,6 +56,7 @@ comp-limplify comp-ssa comp-propagate + comp-call-optim comp-final) "Passes to be executed in order.") @@ -1320,6 +1321,31 @@ This can run just once." (comp-log-func comp-func))) funcs) + +;;; Call optimizer pass specific code. +;; Try to avoid funcall trampoline use when possible. + +(defun comp-call-optim (funcs) + (cl-loop + for comp-func in funcs + for self = (comp-func-symbol-name comp-func) + for self-callref = (comp-nargs-p (comp-func-args comp-func)) + when (and (>= comp-speed 2) + (not self-callref) ;; Could improve this + ) + do (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when (eq self (comp-mvar-constant f)) + (setcar insn-cell + `(set ,lval (call ,(comp-mvar-constant f) ,@rest)))))))) + (comp-log-func comp-func)) + funcs) + ;;; Final pass specific code. From bd3cd579cb43ace253e245a7026b172f216f3a1f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Sep 2019 11:55:25 +0200 Subject: [PATCH 0395/1452] remove comp-emit-funcall --- lisp/emacs-lisp/comp.el | 35 ++--------------------------------- 1 file changed, 2 insertions(+), 33 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8f93efd73ad..6463b02054c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -625,38 +625,6 @@ If NEGATED non nil negate the tested condition." do (comp-emit-cond-jump var m-test 0 target-label nil))) (_ (error "Missing previous setimm while creating a switch")))) -(defun comp-emit-funcall (narg) - "Avoid Ffuncall trampoline if possibile. -NARG is the number of Ffuncall arguments." - (comp-stack-adjust (- narg)) - (let* ((callee (comp-slot)) - (callee-sym-name (comp-mvar-constant callee)) - (optimize nil) - (callref nil)) - (and (comp-mvar-const-vld callee) - (or (and (>= comp-speed 2) - (eq callee-sym-name (comp-func-symbol-name comp-func)) - (setq optimize t) - (setq callref (comp-nargs-p (comp-func-args comp-func)))) - ;; (and (>= comp-speed 3) - ;; (symbol-function callee-sym-name) - ;; (subrp (symbol-function callee-sym-name)) - ;; (setq optimize t) - ;; (setq callref (eq 'many - ;; (cdr (subr-arity - ;; (symbol-function callee-sym-name))))) - ;; (setf callee-sym-name )) - )) - (if optimize - (if callref - (comp-emit-set-call (comp-callref callee-sym-name - narg (1+ (comp-sp)))) - (comp-emit-set-call `(call ,callee-sym-name - ,@(cl-loop for i from (1+ (comp-sp)) - repeat narg - collect (comp-slot-n i))))) - (comp-emit-set-call (comp-callref 'funcall (1+ narg) (comp-sp)))))) - (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -722,7 +690,8 @@ the annotation emission." (make-comp-mvar :constant arg) (comp-slot+1)))) (byte-call - (comp-emit-funcall arg)) + (comp-stack-adjust (- arg)) + (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) (byte-unbind (comp-emit (comp-call 'helper_unbind_n (make-comp-mvar :constant arg)))) From 9709ff1436d547664e6b3ca252cd37665467b4de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Sep 2019 12:46:45 +0200 Subject: [PATCH 0396/1452] add native_elisp field into Lisp_Subr --- src/comp.c | 1 + src/data.c | 14 ++++++++++++++ src/lisp.h | 3 +++ src/pdumper.c | 6 +++++- 4 files changed, 23 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 8aadd5acc91..ca22b81de13 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3228,6 +3228,7 @@ load_comp_unit (dynlib_handle_ptr handle) x->s.min_args = minargs; x->s.max_args = maxargs; x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); + x->s.native_elisp = true; defsubr(x); func_list = XCDR (func_list); diff --git a/src/data.c b/src/data.c index 56e363f16b6..70068c30a71 100644 --- a/src/data.c +++ b/src/data.c @@ -864,6 +864,17 @@ SUBR must be a built-in function. */) return build_string (name); } +#ifdef HAVE_NATIVE_COMP +DEFUN ("subr-native-elispp", Fsubr_native_elispp, Ssubr_native_elispp, 1, 1, 0, + doc: /* Return t if the subr is native compiled elisp, +nil otherwise. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_elisp ? Qt : Qnil; +} +#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. @@ -3983,6 +3994,9 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); +#ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_elispp); +#endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); #endif diff --git a/src/lisp.h b/src/lisp.h index cb3487675e7..a84c08e5669 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2088,6 +2088,9 @@ struct Lisp_Subr const char *symbol_name; const char *intspec; EMACS_INT doc; +#ifdef HAVE_NATIVE_COMP + bool native_elisp; +#endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { diff --git a/src/pdumper.c b/src/pdumper.c index 3ee11460405..7b3109607b4 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2922,7 +2922,10 @@ 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 (HAVE_NATIVE_COMP) \ + && !defined (HASH_Lisp_Subr_D4F15794AF)) \ + || (!defined (HAVE_NATIVE_COMP) \ + && !defined (HASH_Lisp_Subr_594AB72B54))) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2934,6 +2937,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) 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); + DUMP_FIELD_COPY (&out, subr, native_elisp); return dump_object_finish (ctx, &out, sizeof (out)); } From a8d358ed231b7656be50b034484b498b0b222445 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Sep 2019 23:25:37 +0200 Subject: [PATCH 0397/1452] adding comp-call-optim pass --- lisp/emacs-lisp/comp.el | 65 ++++++++++++++++++++++++++++------------- 1 file changed, 44 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6463b02054c..583a77815e9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -944,11 +944,18 @@ This will be called at runtime." (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (puthash (comp-func-symbol-name func) + func + (comp-ctxt-funcs-h comp-ctxt))) + (defun comp-limplify (funcs) "Compute the LIMPLE ir for FUNCS. Top level forms for the current context are rendered too." - (cons (comp-limplify-top-level) - (mapcar #'comp-limplify-function funcs))) + (mapc #'comp-add-func-to-ctxt + (cons (comp-limplify-top-level) + (mapcar #'comp-limplify-function funcs)))) ;;; SSA pass specific code. @@ -1294,14 +1301,34 @@ This can run just once." ;;; Call optimizer pass specific code. ;; Try to avoid funcall trampoline use when possible. +(defun comp-call-optim-form-call (calle args self) + "" + (let* ((f (symbol-function calle)) + (subrp (subrp f)) + (calle-in-unit (gethash calle + (comp-ctxt-funcs-h comp-ctxt)))) + (when-let* ((optimize (or (and subrp + (or + (not (subr-native-elispp f))) + ;; Attention speed 3 optimize inter compilation unit + ;; calls!! +) + (eq calle self) + (and (>= comp-speed 3) + calle-in-unit))) + (call-type (if (if subrp + (not (numberp (cdr (subr-arity f)))) + (comp-nargs-p calle-in-unit)) + 'callref + 'call))) + `(,call-type ,calle ,@args)))) + (defun comp-call-optim (funcs) + "Given FUNCS try to avoid funcall trampoline usage when possible." (cl-loop for comp-func in funcs for self = (comp-func-symbol-name comp-func) - for self-callref = (comp-nargs-p (comp-func-args comp-func)) - when (and (>= comp-speed 2) - (not self-callref) ;; Could improve this - ) + when (>= comp-speed 2) do (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1309,9 +1336,13 @@ This can run just once." for insn = (car insn-cell) do (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when (eq self (comp-mvar-constant f)) - (setcar insn-cell - `(set ,lval (call ,(comp-mvar-constant f) ,@rest)))))))) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell ,new-form)))))) (comp-log-func comp-func)) funcs) @@ -1338,21 +1369,13 @@ Prepare every functions for final compilation and drive the C side." doc))) (comp--compile-ctxt-to-file name)) -(defun comp-add-func-to-ctxt (func) - "Add FUNC to the current compiler contex." - (puthash (comp-func-symbol-name func) - func - (comp-ctxt-funcs-h comp-ctxt))) - -(defun comp-final (data) - "Final pass driving DATA into the C side for code emission." +(defun comp-final (_) + "Final pass driving DATA into the C back-end for code emission." (let (compile-result) (comp--init-ctxt) (unwind-protect - (progn - (mapc #'comp-add-func-to-ctxt data) - (setq compile-result - (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))) + (setq compile-result + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) (and (comp--release-ctxt) compile-result)))) From 403a7e59d5c79d81ee018fd9e648a2af744211c1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Sep 2019 00:07:10 +0200 Subject: [PATCH 0398/1452] fix compilation for comp.el --- lisp/emacs-lisp/comp.el | 58 ++++++++++++++++++++--------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 583a77815e9..ad64ee76183 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -396,6 +396,34 @@ If INPUT is a string this is the file path to be compiled." ;;; Limplification pass specific code. +(defmacro comp-sp () + "Current stack pointer." + '(comp-limplify-sp comp-pass)) + +(defmacro comp-with-sp (sp &rest body) + "Execute BODY setting the stack pointer to SP. +Restore the original value afterwards." + (declare (debug (form body)) + (indent defun)) + (let ((sym (gensym))) + `(let ((,sym (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) ,sym)))) + +(defmacro comp-slot-n (n) + "Slot N into the meta-stack." + (declare (debug (form))) + `(aref (comp-limplify-frame comp-pass) ,n)) + +(defmacro comp-slot () + "Current slot into the meta-stack pointed by sp." + '(comp-slot-n (comp-sp))) + +(defmacro comp-slot+1 () + "Slot into the meta-stack pointed by sp + 1." + '(comp-slot-n (1+ (comp-sp)))) + (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during function limplification." (sp 0 :type fixnum @@ -445,34 +473,6 @@ If INPUT is a string this is the file path to be compiled." do (aset v i mvar) finally (return v))) -(defmacro comp-sp () - "Current stack pointer." - '(comp-limplify-sp comp-pass)) - -(defmacro comp-with-sp (sp &rest body) - "Execute BODY setting the stack pointer to SP. -Restore the original value afterwards." - (declare (debug (form body)) - (indent defun)) - (let ((sym (gensym))) - `(let ((,sym (comp-sp))) - (setf (comp-sp) ,sp) - (progn ,@body) - (setf (comp-sp) ,sym)))) - -(defmacro comp-slot-n (n) - "Slot N into the meta-stack." - (declare (debug (form))) - `(aref (comp-limplify-frame comp-pass) ,n)) - -(defmacro comp-slot () - "Current slot into the meta-stack pointed by sp." - '(comp-slot-n (comp-sp))) - -(defmacro comp-slot+1 () - "Slot into the meta-stack pointed by sp + 1." - '(comp-slot-n (1+ (comp-sp)))) - (defun comp-emit (insn) "Emit INSN into current basic block." (push insn (comp-block-insns comp-block))) @@ -1111,7 +1111,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - do (return t)))) + do (cl-return t)))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i From 2cd60cb592930d985565612e0f22766b98fcf341 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Sep 2019 01:25:46 +0200 Subject: [PATCH 0399/1452] guard comp-call-optim-form-call for byte compiled callee --- lisp/emacs-lisp/comp.el | 40 ++++++++++++++++++++-------------------- src/comp.c | 2 +- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ad64ee76183..551fdf80389 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1301,27 +1301,27 @@ This can run just once." ;;; Call optimizer pass specific code. ;; Try to avoid funcall trampoline use when possible. -(defun comp-call-optim-form-call (calle args self) +(defun comp-call-optim-form-call (callee args self) "" - (let* ((f (symbol-function calle)) - (subrp (subrp f)) - (calle-in-unit (gethash calle - (comp-ctxt-funcs-h comp-ctxt)))) - (when-let* ((optimize (or (and subrp - (or - (not (subr-native-elispp f))) - ;; Attention speed 3 optimize inter compilation unit - ;; calls!! -) - (eq calle self) - (and (>= comp-speed 3) - calle-in-unit))) - (call-type (if (if subrp - (not (numberp (cdr (subr-arity f)))) - (comp-nargs-p calle-in-unit)) - 'callref - 'call))) - `(,call-type ,calle ,@args)))) + (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (let* ((f (symbol-function callee)) + (subrp (subrp f)) + (callee-in-unit (gethash callee + (comp-ctxt-funcs-h comp-ctxt)))) + (when-let* ((optimize (or (and subrp + (not (subr-native-elispp f))) + (eq callee self) + ;; Attention speed 3 optimize inter compilation + ;; unit calls!! + (and (>= comp-speed 3) + callee-in-unit))) + (call-type (if (if subrp + (not (numberp (cdr (subr-arity f)))) + (comp-nargs-p callee-in-unit)) + 'callref + 'call))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@args))))) (defun comp-call-optim (funcs) "Given FUNCS try to avoid funcall trampoline usage when possible." diff --git a/src/comp.c b/src/comp.c index ca22b81de13..ef10c466cf2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1048,7 +1048,7 @@ emit_mvar_val (Lisp_Object mvar) if (FIXNUMP (constant)) { /* We can still emit directly objects that are selfcontained in a word - read (fixnums). */ + (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, From 8124ddf387451ec95ee4f8e0f726ab234bd8b762 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Sep 2019 14:29:14 +0200 Subject: [PATCH 0400/1452] dead code removal --- src/comp.c | 56 ------------------------------------------------------ 1 file changed, 56 deletions(-) diff --git a/src/comp.c b/src/comp.c index ef10c466cf2..9cdb35f1105 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3008,62 +3008,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return Qt; } -/* DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, */ -/* Scomp_compile_and_load_ctxt, */ -/* 0, 1, 0, */ -/* doc: /\* Compile as native code the current context and load its */ -/* functions. *\/) */ -/* (Lisp_Object disassemble) */ -/* { */ -/* gcc_jit_context_set_int_option (comp.ctxt, */ -/* GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, */ -/* comp_speed); */ -/* /\* Gcc doesn't like being interrupted at all. *\/ */ -/* sigset_t oldset; */ -/* sigset_t blocked; */ -/* sigemptyset (&blocked); */ -/* sigaddset (&blocked, SIGALRM); */ -/* sigaddset (&blocked, SIGINT); */ -/* sigaddset (&blocked, SIGIO); */ -/* pthread_sigmask (SIG_BLOCK, &blocked, &oldset); */ - -/* if (COMP_DEBUG) */ -/* gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); */ -/* gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); */ - -/* if (!NILP (disassemble)) */ -/* gcc_jit_context_compile_to_file (comp.ctxt, */ -/* GCC_JIT_OUTPUT_KIND_ASSEMBLER, */ -/* "gcc-ctxt-dump.s"); */ - -/* while (CONSP (comp.funcs)) */ -/* { */ -/* union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); */ -/* Lisp_Object func = XCAR (comp.funcs); */ -/* Lisp_Object args = FUNCALL1 (comp-func-args, func); */ -/* char *symbol_name = */ -/* (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); */ -/* char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); */ - -/* x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; */ -/* x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); */ -/* eassert (x->s.function.a0); */ -/* x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); */ -/* if (FUNCALL1 (comp-args-p, args)) */ -/* x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ -/* else */ -/* x->s.max_args = MANY; */ -/* x->s.symbol_name = symbol_name; */ -/* defsubr(x); */ - -/* comp.funcs = XCDR (comp.funcs); */ -/* } */ - -/* pthread_sigmask (SIG_SETMASK, &oldset, 0); */ - -/* return Qt; */ -/* } */ - /******************************************************************************/ /* Helper functions called from the runtime. */ From 4088e467b3be3fcf6a1813bc74de7c4d3c193f1f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Sep 2019 14:55:44 +0200 Subject: [PATCH 0401/1452] better naming func_hash -> imported_func_h --- src/comp.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9cdb35f1105..ed658ee5b3e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -167,7 +167,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object func_hash; /* subr_name -> reloc_field. */ + Lisp_Object imported_func_h; /* subr_name -> reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -308,7 +308,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - ICE_IF (!NILP (Fgethash (subr_sym, comp.func_hash, Qnil)), + ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_func_h, Qnil)), "unexpected double function declaration"); if (nargs == MANY) @@ -349,7 +349,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, f_ptr_type, SSDATA (f_ptr_name)); - Fputhash (subr_sym, make_mint_ptr (field), comp.func_hash); + Fputhash (subr_sym, make_mint_ptr (field), comp.imported_func_h); return field; } @@ -405,7 +405,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, nargs, args); - Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); + Lisp_Object value = Fgethash (subr_sym, comp.imported_func_h, Qnil); ICE_IF (NILP (value), "missing function declaration"); gcc_jit_lvalue *f_ptr = @@ -2910,7 +2910,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. */ - comp.func_hash = CALLN (Fmake_hash_table); + comp.imported_func_h = CALLN (Fmake_hash_table); /* Define data structures. */ @@ -3265,8 +3265,8 @@ syms_of_comp (void) defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Snative_elisp_load); - staticpro (&comp.func_hash); - comp.func_hash = Qnil; + staticpro (&comp.imported_func_h); + comp.imported_func_h = Qnil; staticpro (&comp.func_blocks); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; From c31b471cadcb9b8171de04b09a044bb775682a3a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 09:47:02 +0200 Subject: [PATCH 0402/1452] add direct-call direct-callref into frontend --- lisp/emacs-lisp/comp.el | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 551fdf80389..3ccdf4f2e46 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1308,20 +1308,22 @@ This can run just once." (subrp (subrp f)) (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) - (when-let* ((optimize (or (and subrp - (not (subr-native-elispp f))) - (eq callee self) - ;; Attention speed 3 optimize inter compilation - ;; unit calls!! - (and (>= comp-speed 3) - callee-in-unit))) - (call-type (if (if subrp - (not (numberp (cdr (subr-arity f)))) - (comp-nargs-p callee-in-unit)) - 'callref - 'call))) - (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@args))))) + (if (and subrp (not (subr-native-elispp f))) + (let ((call-type (if (if subrp + (not (numberp (cdr (subr-arity f)))) + (comp-nargs-p callee-in-unit)) + 'callref + 'call))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@args)) + ;; Intra compilation unit procedure call optimization. + (when (or (eq callee self) + ;; Attention speed 3 triggers that for non self calls too!! + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((nargs (comp-nargs-p (comp-func-args callee-in-unit))) + (call-type (if nargs 'direct-callref 'direct-call))) + `(,call-type ,callee ,@args))))))) (defun comp-call-optim (funcs) "Given FUNCS try to avoid funcall trampoline usage when possible." From 89172ac4376403b987bad897cdcfd22f9e5d97c8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 09:48:15 +0200 Subject: [PATCH 0403/1452] split declaration and compilation --- src/comp.c | 130 ++++++++++++++++++++++++----------------------------- 1 file changed, 59 insertions(+), 71 deletions(-) diff --git a/src/comp.c b/src/comp.c index ed658ee5b3e..a29e56203d9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -147,7 +147,6 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ - Lisp_Object lfunc; gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; @@ -166,8 +165,9 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; - Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object imported_func_h; /* subr_name -> reloc_field. */ + Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ + Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ + Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -265,7 +265,7 @@ type_to_cast_field (gcc_jit_type *type) static gcc_jit_block * retrive_block (Lisp_Object block_name) { - Lisp_Object value = Fgethash (block_name, comp.func_blocks, Qnil); + Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); ICE_IF (NILP (value), "missing basic block"); return (gcc_jit_block *) xmint_pointer (value); @@ -277,9 +277,9 @@ declare_block (Lisp_Object block_name) char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks, Qnil)), + ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)), "double basic block declaration"); - Fputhash (block_name, value, comp.func_blocks); + Fputhash (block_name, value, comp.func_blocks_h); } static void @@ -308,7 +308,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_func_h, Qnil)), + ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)), "unexpected double function declaration"); if (nargs == MANY) @@ -349,63 +349,15 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, f_ptr_type, SSDATA (f_ptr_name)); - Fputhash (subr_sym, make_mint_ptr (field), comp.imported_func_h); + Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h); return field; } -static void -fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, - unsigned nargs) -{ - /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ - if (args) - for (unsigned i = 0; i < nargs; i++) - type[i] = gcc_jit_rvalue_get_type (args[i]); - else - for (unsigned i = 0; i < nargs; i++) - type[i] = comp.lisp_obj_type; -} - -static gcc_jit_function * -declare_exported_func (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args) -{ - USE_SAFE_ALLOCA; - gcc_jit_type **type = SAFE_ALLOCA (nargs * sizeof (*type)); - fill_declaration_types (type, args, nargs); - - gcc_jit_param **param = SAFE_ALLOCA (nargs *sizeof (*param)); - for (int i = nargs - 1; i >= 0; i--) - param[i] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[i], - format_string ("par_%d", i)); - SAFE_FREE (); - return gcc_jit_context_new_function(comp.ctxt, NULL, - GCC_JIT_GLOBAL_EXPORTED, - ret_type, - f_name, - nargs, - param, - 0); -} - static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - /* Self call optimization. */ - if (!NILP (comp.lfunc) && - comp_speed >= 2 && - EQ (subr_sym, FUNCALL1 (comp-func-symbol-name, comp.lfunc))) - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - nargs, - args); - - Lisp_Object value = Fgethash (subr_sym, comp.imported_func_h, Qnil); + Lisp_Object value = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); ICE_IF (NILP (value), "missing function declaration"); gcc_jit_lvalue *f_ptr = @@ -2660,22 +2612,36 @@ define_bool_to_lisp_obj (void) } +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ static void -compile_function (Lisp_Object func) +declare_function (Lisp_Object func) { - USE_SAFE_ALLOCA; + gcc_jit_function *gcc_func; char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); - EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); bool ncall = (FUNCALL1 (comp-nargs-p, args)); - - comp.lfunc = func; + USE_SAFE_ALLOCA; if (!ncall) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - comp.func - = declare_exported_func (c_name, comp.lisp_obj_type, max_args, NULL); + gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); + for (unsigned i = 0; i < max_args; i++) + type[i] = comp.lisp_obj_type; + + gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); + for (int i = max_args - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param (comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + param, + 0); } else { @@ -2688,7 +2654,7 @@ compile_function (Lisp_Object func) NULL, comp.lisp_obj_ptr_type, "args") }; - comp.func = + gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, @@ -2696,6 +2662,22 @@ compile_function (Lisp_Object func) c_name, 2, param, 0); } + Fputhash (FUNCALL1 (comp-func-symbol-name, func), + make_mint_ptr (gcc_func), + comp.exported_funcs_h); + + SAFE_FREE (); +} + +static void +compile_function (Lisp_Object func) +{ + USE_SAFE_ALLOCA; + EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + + comp.func = xmint_pointer (Fgethash (FUNCALL1 (comp-func-symbol-name, func), + comp.exported_funcs_h, Qnil)); + gcc_jit_lvalue *frame_array = gcc_jit_function_new_local ( comp.func, @@ -2717,7 +2699,7 @@ compile_function (Lisp_Object func) comp.int_type, i)); - comp.func_blocks = CALLN (Fmake_hash_table); + comp.func_blocks_h = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ @@ -2752,7 +2734,6 @@ compile_function (Lisp_Object func) format_string ("failing to compile function %s with error: %s", SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), err)); - comp.lfunc = Qnil; SAFE_FREE (); } @@ -2906,11 +2887,12 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (void *), false); + comp.exported_funcs_h = CALLN (Fmake_hash_table); /* Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. */ - comp.imported_func_h = CALLN (Fmake_hash_table); + comp.imported_funcs_h = CALLN (Fmake_hash_table); /* Define data structures. */ @@ -2983,6 +2965,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, relocation structs has to be already defined. */ struct Lisp_Hash_Table *func_h = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); + for (ptrdiff_t i = 0; i < func_h->count; i++) + declare_function (HASH_VALUE (func_h, i)); for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); @@ -3220,6 +3204,8 @@ syms_of_comp (void) DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); + DEFSYM (Qdirect_call, "direct-call"); + DEFSYM (Qdirect_callref, "direct-callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); @@ -3265,9 +3251,11 @@ syms_of_comp (void) defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Snative_elisp_load); - staticpro (&comp.imported_func_h); - comp.imported_func_h = Qnil; - staticpro (&comp.func_blocks); + staticpro (&comp.exported_funcs_h); + comp.exported_funcs_h = Qnil; + staticpro (&comp.imported_funcs_h); + comp.imported_funcs_h = Qnil; + staticpro (&comp.func_blocks_h); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; From d87d9e41f5890fbe7d279053c9c7328890c94b2f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 10:07:26 +0200 Subject: [PATCH 0404/1452] extend emit_call to perform direct calls --- src/comp.c | 77 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/src/comp.c b/src/comp.c index a29e56203d9..0365f0e09e9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -353,27 +353,39 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, return field; } +/* Emit calls fetching from existing declarations. */ static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) + gcc_jit_rvalue **args, bool direct) { - Lisp_Object value = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); - ICE_IF (NILP (value), "missing function declaration"); + Lisp_Object func = + Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, + Qnil); + ICE_IF (NILP (func), "missing function declaration"); - gcc_jit_lvalue *f_ptr = - gcc_jit_lvalue_access_field (comp.func_relocs, - NULL, - (gcc_jit_field *) xmint_pointer (value)); - - ICE_IF (!f_ptr, "undeclared function relocation"); - - emit_comment (format_string ("calling subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); - return gcc_jit_context_new_call_through_ptr(comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (f_ptr), - nargs, - args); + if (direct) + { + emit_comment (format_string ("direct call to subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + xmint_pointer (func), + nargs, + args); + } else { + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (func)); + ICE_IF (!f_ptr, "undeclared function relocation"); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); + } } static gcc_jit_rvalue * @@ -385,7 +397,7 @@ emit_call_ref (Lisp_Object subr_sym, unsigned nargs, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (subr_sym, comp.lisp_obj_type, 2, args); + return emit_call (subr_sym, comp.lisp_obj_type, 2, args, false); } /* Close current basic block emitting a conditional. */ @@ -1036,7 +1048,7 @@ emit_set_internal (Lisp_Object args) comp.int_type, SET_INTERNAL_SET); return emit_call (intern_c_string ("set_internal"), comp.void_type , 4, - gcc_args); + gcc_args, false); } /* This is for a regular function with arguments as m-var. */ @@ -1054,7 +1066,7 @@ emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) gcc_args[i++] = emit_mvar_val (XCAR (args)); SAFE_FREE (); - return emit_call (callee, ret_type, nargs, gcc_args); + return emit_call (callee, ret_type, nargs, gcc_args, false); } static gcc_jit_rvalue * @@ -1128,7 +1140,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, comp.block, NULL, c, - emit_call (intern_c_string ("push_handler"), comp.handler_ptr_type, 2, args)); + emit_call (intern_c_string ("push_handler"), + comp.handler_ptr_type, 2, args, false)); args[0] = gcc_jit_lvalue_get_address ( @@ -1139,7 +1152,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, NULL); gcc_jit_rvalue *res; - res = emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args); + res = + emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); emit_cond_jump (res, handler_bb, guarded_bb); /* This emit the handler part. */ @@ -1276,6 +1290,7 @@ emit_limple_insn (Lisp_Object insn) if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); + /* FIXME: should recurr here */ else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) @@ -1349,7 +1364,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue (args) }; res = emit_call (Qlist, comp.lisp_obj_type, 2, - list_args); + list_args, false); gcc_jit_block_add_assignment (comp.block, NULL, @@ -2158,7 +2173,8 @@ define_CHECK_TYPE (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.void_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args, + false)); gcc_jit_block_end_with_void_return (not_ok_block, NULL); } @@ -2240,7 +2256,8 @@ define_CAR_CDR (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.void_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args, + false)); gcc_jit_block_end_with_return (comp.block, NULL, emit_const_lisp_obj (Qnil)); @@ -2389,7 +2406,7 @@ define_add1_sub1 (void) comp.block = fcall_block; gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]), - comp.lisp_obj_type, 1, &n); + comp.lisp_obj_type, 1, &n, false); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); @@ -2521,9 +2538,7 @@ define_PSEUDOVECTORP (void) call_pseudovector_typep_b, NULL, emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), - comp.bool_type, - 2, - args)); + comp.bool_type, 2, args, false)); } static void @@ -2566,8 +2581,8 @@ define_CHECK_IMPURE (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("pure_write_error"), - comp.void_type, 1, - &pure_write_error_arg)); + comp.void_type, 1,&pure_write_error_arg, + false)); gcc_jit_block_end_with_void_return (err_block, NULL); } From bbf8b1df90f327a74423b2ccbfe557da9b04dd9d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 10:23:18 +0200 Subject: [PATCH 0405/1452] add direct-call direct-callref support into the backend --- src/comp.c | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0365f0e09e9..89eead5c6c4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -390,14 +390,14 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, static gcc_jit_rvalue * emit_call_ref (Lisp_Object subr_sym, unsigned nargs, - gcc_jit_lvalue *base_arg) + gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = { gcc_jit_context_new_rvalue_from_int(comp.ctxt, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (subr_sym, comp.lisp_obj_type, 2, args, false); + return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); } /* Close current basic block emitting a conditional. */ @@ -1054,7 +1054,7 @@ emit_set_internal (Lisp_Object args) /* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * -emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) +emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) { USE_SAFE_ALLOCA; int i = 0; @@ -1066,25 +1066,23 @@ emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) gcc_args[i++] = emit_mvar_val (XCAR (args)); SAFE_FREE (); - return emit_call (callee, ret_type, nargs, gcc_args, false); + return emit_call (callee, ret_type, nargs, gcc_args, direct); } static gcc_jit_rvalue * emit_simple_limple_call_lisp_ret (Lisp_Object args) { /* - Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)) */ - return emit_simple_limple_call (args, comp.lisp_obj_type); + return emit_simple_limple_call (args, comp.lisp_obj_type, false); } static gcc_jit_rvalue * emit_simple_limple_call_void_ret (Lisp_Object args) { - return emit_simple_limple_call (args, comp.void_type); + return emit_simple_limple_call (args, comp.void_type, false); } /* Entry point to dispatch emitting (call fun ...). */ @@ -1105,7 +1103,7 @@ emit_limple_call (Lisp_Object insn) } static gcc_jit_rvalue * -emit_limple_call_ref (Lisp_Object insn) +emit_limple_call_ref (Lisp_Object insn, bool direct) { /* Ex: (callref < #s(comp-mvar 1 6 nil nil nil t) #s(comp-mvar 2 11 t 10 integer t)). */ @@ -1113,7 +1111,7 @@ emit_limple_call_ref (Lisp_Object insn) Lisp_Object callee = FIRST (insn); EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); - return emit_call_ref (callee, nargs, comp.frame[base_ptr]); + return emit_call_ref (callee, nargs, comp.frame[base_ptr], false); } /* Register an handler for a non local exit. */ @@ -1290,11 +1288,14 @@ emit_limple_insn (Lisp_Object insn) if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); - /* FIXME: should recurr here */ else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) - res = emit_limple_call_ref (XCDR (arg1)); + res = emit_limple_call_ref (XCDR (arg1), false); + else if (EQ (FIRST (arg1), Qdirect_call)) + res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true); + else if (EQ (FIRST (arg1), Qcallref)) + res = emit_limple_call_ref (XCDR (arg1), true); else ice ("LIMPLE inconsistent arg1 for op ="); @@ -2479,7 +2480,7 @@ define_negate (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n); + gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); From 2fb2862facf3eb70897a2e5ba342971ce696bc5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 10:36:53 +0200 Subject: [PATCH 0406/1452] cleanup unnecessary code and allow inlining at speed 3 --- src/comp.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 89eead5c6c4..e0c332c89e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2820,9 +2820,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, } - /* Do not inline within a compilation unit. */ - gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); From baf16746960ad5f7baaf21b44feff9c8f3a4fc29 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 11:36:48 +0200 Subject: [PATCH 0407/1452] better error signaling when compilation fails --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index e0c332c89e4..b25013d65ad 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1299,7 +1299,7 @@ emit_limple_insn (Lisp_Object insn) else ice ("LIMPLE inconsistent arg1 for op ="); - ICE_IF (!res, "incoherent insn"); + ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); gcc_jit_block_add_assignment (comp.block, NULL, From 10d7284a2a1e8a543b31e5c99c2fc0c26c8eb681 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 11:38:40 +0200 Subject: [PATCH 0408/1452] add missing arguments if missing in comp-call-optim-form-call --- lisp/emacs-lisp/comp.el | 54 +++++++++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ccdf4f2e46..e94f3185b4b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1303,27 +1303,39 @@ This can run just once." (defun comp-call-optim-form-call (callee args self) "" - (when (symbolp callee) ; Do nothing if callee is a byte compiled func. - (let* ((f (symbol-function callee)) - (subrp (subrp f)) - (callee-in-unit (gethash callee - (comp-ctxt-funcs-h comp-ctxt)))) - (if (and subrp (not (subr-native-elispp f))) - (let ((call-type (if (if subrp - (not (numberp (cdr (subr-arity f)))) - (comp-nargs-p callee-in-unit)) - 'callref - 'call))) - (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@args)) - ;; Intra compilation unit procedure call optimization. - (when (or (eq callee self) - ;; Attention speed 3 triggers that for non self calls too!! - (and (>= comp-speed 3) - callee-in-unit)) - (let* ((nargs (comp-nargs-p (comp-func-args callee-in-unit))) - (call-type (if nargs 'direct-callref 'direct-call))) - `(,call-type ,callee ,@args))))))) + (cl-flet ((fill-args (args total) + ;; Fill missing args to reach TOTAL + (append args (cl-loop repeat (- total (length args)) + collect (make-comp-mvar :constant nil))))) + (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (let* ((f (symbol-function callee)) + (subrp (subrp f)) + (callee-in-unit (gethash callee + (comp-ctxt-funcs-h comp-ctxt)))) + (if (and subrp (not (subr-native-elispp f))) + (let* ((maxarg (cdr (subr-arity f))) + (call-type (if (if subrp + (not (numberp maxarg)) + (comp-nargs-p callee-in-unit)) + 'callref + 'call)) + (args (if (eq call-type 'callref) + args + (fill-args args maxarg)))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@args)) + ;; Intra compilation unit procedure call optimization. + (when (or (eq callee self) + ;; Attention speed 3 triggers that for non self calls too!! + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((func-args (comp-func-args callee-in-unit)) + (nargs (comp-nargs-p func-args)) + (call-type (if nargs 'direct-callref 'direct-call)) + (args (if (eq call-type 'direct-callref) + args + (fill-args args (comp-args-max func-args))))) + `(,call-type ,callee ,@args)))))))) (defun comp-call-optim (funcs) "Given FUNCS try to avoid funcall trampoline usage when possible." From 82778374fef72583ac7c64f96187f56b1641ddea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 14:06:13 +0200 Subject: [PATCH 0409/1452] better log output --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e94f3185b4b..1ca086659aa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -285,7 +285,7 @@ BODY is evaluate only if `comp-debug' is non nil." (defun comp-log-func (func) "Log function FUNC." - (comp-log (format "\n\n Function: %s" (comp-func-symbol-name func))) + (comp-log (format "\n Function: %s" (comp-func-symbol-name func))) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn @@ -1409,6 +1409,7 @@ If INPUT is a string, use it as the file path to be native compiled." (symbol-name input) (file-name-sans-extension input))))) (mapc (lambda (pass) + (comp-log (format "\nRunning pass %s: " pass)) (setq data (funcall pass data))) comp-passes))) From 0a014a386200532d92974d255b0b3f6b33d07a22 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 17:18:57 +0200 Subject: [PATCH 0410/1452] rework lap spilling --- lisp/emacs-lisp/bytecomp.el | 22 +++++++++++++++------- lisp/emacs-lisp/comp.el | 26 ++++++++++++++++---------- 2 files changed, 31 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 77cd408ce97..1666dff7117 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,8 +565,12 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) -(defvar byte-to-native-last-lap nil) -(defvar byte-to-native-output nil) +(defvar byte-to-native-lap nil + "Alist to accumulate lap. +Each element is (NAME . LAP)") +(defvar byte-to-native-bytecode nil + "Alist to accumulate bytecode. +Each element is (NAME . BYTECODE)") (defvar byte-to-native-top-level-forms nil) @@ -2273,8 +2277,9 @@ QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." (when byte-native-compiling - ;; Spill output for the native compiler here - (push (list name byte-to-native-last-lap (apply #'vector form)) byte-to-native-output)) + ;; Spill bytecode output for the native compiler here + (push (cons name (apply #'vector form)) + byte-to-native-bytecode)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -2377,7 +2382,8 @@ list that represents a doc string reference. (defun byte-compile-flush-pending () (if byte-compile-output - (let ((form (byte-compile-out-toplevel t 'file))) + (let* ((byte-compile-current-form nil) + (form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) (mapc 'byte-compile-output-file-form (cdr form))) (form @@ -3128,8 +3134,10 @@ for symbols generated by the byte compiler itself." (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling - ;; Spill output for the native compiler here - (setq byte-to-native-last-lap byte-compile-output)) + ;; Spill LAP for the native compiler here + (when byte-compile-current-form + (push (cons byte-compile-current-form byte-compile-output) + byte-to-native-lap))) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1ca086659aa..e1e0858985b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -351,13 +351,15 @@ Put PREFIX in front of it." (error "Can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (comp-log byte-to-native-last-lap) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list))) - (setf (comp-func-lap func) byte-to-native-last-lap) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) - func)) + (let ((lap (cdr (assoc function-name (reverse byte-to-native-bytecode))))) + (cl-assert lap) + (comp-log lap) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list))) + (setf (comp-func-lap func) lap) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + func))) (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." @@ -368,7 +370,11 @@ Put PREFIX in front of it." ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) - (cl-loop for (name lap bytecode) in byte-to-native-output + ;; Hacky! We need to reverse `byte-to-native-lap' to have the compiled top + ;; level form that matters (ex exclude lambdas)... + (cl-loop with lap-funcs = byte-to-native-lap + for (name . bytecode) in byte-to-native-bytecode + for lap = (cdr (assoc name lap-funcs)) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name :byte-func bytecode @@ -386,8 +392,8 @@ Put PREFIX in front of it." If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-last-lap nil) - (byte-to-native-output ()) + (byte-to-native-lap ()) + (byte-to-native-bytecode ()) (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) From 5976919a3325c4512e450b9649a510f05e7d4fcd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 17:19:20 +0200 Subject: [PATCH 0411/1452] better logging --- lisp/emacs-lisp/comp.el | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1e0858985b..9f0068681b8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -281,7 +281,8 @@ BODY is evaluate only if `comp-debug' is non nil." (insert data) (mapc (lambda (x) (insert (prin1-to-string x) "\n")) - data))))) + data) + (insert "\n"))))) (defun comp-log-func (func) "Log function FUNC." @@ -289,7 +290,7 @@ BODY is evaluate only if `comp-debug' is non nil." (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn - (comp-log (concat "\n<" (symbol-name block-name) ">\n")) + (comp-log (concat "<" (symbol-name block-name) ">\n")) (comp-log (comp-block-insns bb))))) (defun comp-log-edges (func) @@ -384,7 +385,9 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (aref bytecode 3)) - do (comp-log lap) + do (progn + (comp-log (format "Function %s:\n" name)) + (comp-log lap)) collect func)) (defun comp-spill-lap (input) @@ -1415,7 +1418,7 @@ If INPUT is a string, use it as the file path to be native compiled." (symbol-name input) (file-name-sans-extension input))))) (mapc (lambda (pass) - (comp-log (format "\nRunning pass %s: " pass)) + (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) comp-passes))) From c6be6fd6ccca9b9af1d9c5916d3da39f965e0ec5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 18:13:13 +0200 Subject: [PATCH 0412/1452] verify to never emit insns into a closed block --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9f0068681b8..83e8f8485b0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -484,6 +484,7 @@ Restore the original value afterwards." (defun comp-emit (insn) "Emit INSN into current basic block." + (cl-assert (not (comp-block-closed comp-block))) (push insn (comp-block-insns comp-block))) (defun comp-emit-set-call (call) From be1b64bdb515d8328228138982850475d15a0feb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 19:13:11 +0200 Subject: [PATCH 0413/1452] strengthening comp-compute-edges --- lisp/emacs-lisp/comp.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 83e8f8485b0..01edd2b18fe 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -995,7 +995,7 @@ Top level forms for the current context are rendered too." for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) for (op first second third forth) = last-insn - do (cl-ecase op + do (cl-case op (jump (edge-add :src bb :dst (gethash first blocks))) (cond-jump @@ -1007,7 +1007,10 @@ Top level forms for the current context are rendered too." (push-handler (edge-add :src bb :dst (gethash third blocks)) (edge-add :src bb :dst (gethash forth blocks))) - (return)) + (return) + (otherwise + (error "Block %s does not end with a branch in func %s" + bb (comp-func-symbol-name comp-func)))) finally (progn (setf (comp-func-edges comp-func) (nreverse (comp-func-edges comp-func))) From 4a0adfec2a1caabca3bf99881f98f24ad12216f9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Sep 2019 19:14:20 +0200 Subject: [PATCH 0414/1452] better doc for comp-func struct --- lisp/emacs-lisp/comp.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 01edd2b18fe..8761312a547 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -195,8 +195,7 @@ Is in use to help the SSA rename pass.")) :documentation "Key is the basic block symbol value is a comp-block structure.") (lap-block (make-hash-table :test #'equal) :type hash-table - :documentation "Key value to convert from LAP label number to -LIMPLE basic block.") + :documentation "LAP lable -> LIMPLE basic block.") (edges () :type list :documentation "List of edges connecting basic blocks.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function From 4c33696014d28975bce559a333c845fffc695428 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 09:57:15 +0200 Subject: [PATCH 0415/1452] remove unused field into comp-func --- lisp/emacs-lisp/comp.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8761312a547..dd3b5200bc2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -183,8 +183,6 @@ Is in use to help the SSA rename pass.")) :documentation "Function symbol's name.") (c-func-name nil :type string :documentation "The function name in the native world.") - (func nil - :documentation "Original form.") (byte-func nil :documentation "Byte compiled version.") (lap () :type list From a49be9dba96575b68f0657c21eebcfbb56463021 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 09:58:20 +0200 Subject: [PATCH 0416/1452] better comp-func doc --- lisp/emacs-lisp/comp.el | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dd3b5200bc2..b5d54289deb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,23 +186,26 @@ Is in use to help the SSA rename pass.")) (byte-func nil :documentation "Byte compiled version.") (lap () :type list - :documentation "Lap assembly representation.") + :documentation "LAP assembly representation.") (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block structure.") (lap-block (make-hash-table :test #'equal) :type hash-table - :documentation "LAP lable -> LIMPLE basic block.") + :documentation "LAP lable -> LIMPLE basic block name.") (edges () :type list :documentation "List of edges connecting basic blocks.") + (block-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Generates block numbers.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Generates edges numbers.") + :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Counter to create ssa limple vars.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." + ;; (setf (block-cnt-gen func) (comp-gen-counter)) (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) From fcab7f72e1765b883537a0ae2c3a82a802539375 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 09:59:14 +0200 Subject: [PATCH 0417/1452] fix comp-new-block-sym --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5d54289deb..527d855af6f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -599,11 +599,11 @@ If NEGATED non nil negate the tested condition." (comp-slot+1)))))) (defun comp-new-block-sym () - "Return a symbol naming the next new basic block." - (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) + "Return a unique symbol naming the next new basic block." + (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) (defun comp-lap-to-limple-bb (n) - "Given the LAP label N return the limple basic block." + "Given the LAP label N return the limple basic block name." (let ((hash (comp-func-lap-block comp-func))) (if-let ((bb (gethash n hash))) ;; If was already created return it. @@ -950,7 +950,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block 'bb_1) + (comp-emit-block (comp-new-block-sym)) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) From b45122b7132bb4b7e41fff5434e669e4ca671b8c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 15:02:00 +0200 Subject: [PATCH 0418/1452] rework basic block entry sp emission --- lisp/emacs-lisp/comp.el | 40 ++++++++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 527d855af6f..7d0c0671e8f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -442,9 +442,14 @@ Restore the original value afterwards." (block-name nil :type symbol :documentation "Current basic block name.")) -(cl-defun comp-block-maybe-add (&rest args &key name &allow-other-keys) +(cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) - (unless (gethash name blocks) + (if-let ((bb (gethash name blocks))) + (if-let ((bb-sp (comp-block-sp bb))) + ;; If was a sp was already registered sanity check it. + (cl-assert (or (null sp) (= sp bb-sp))) + ;; Otherwise set it. + (setf (comp-block-sp bb) sp)) (puthash name (apply #'make--comp-block args) blocks)))) ;; (defun comp-opt-call (inst) @@ -547,12 +552,13 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit (list 'jump target)) (comp-mark-block-closed)) -(defun comp-emit-block (block-name) - "Emit basic block BLOCK-NAME." +(defun comp-emit-block (block-name &optional entry-sp) + "Emit basic block BLOCK-NAME. +ENTRY-SP is the sp value when entering." (let ((blocks (comp-func-blocks comp-func))) ;; In case does not exist register it into comp-func-blocks. (comp-block-maybe-add :name block-name - :sp (comp-sp)) + :sp entry-sp) ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) @@ -562,9 +568,10 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit-jump block-name)) ;; Set this a currently compiled block. (setf comp-block (gethash block-name blocks)) - ;; If we are landing here form a recorded branch adjust sp accordingly. - (setf (comp-sp) - (comp-block-sp (gethash block-name blocks))) + ;; If we are landing here from a previously recorded branch with known sp + ;; adjust accordingly. + (when-let ((new-sp (comp-block-sp (gethash block-name blocks)))) + (setf (comp-sp) new-sp)) (setf (comp-limplify-block-name comp-pass) block-name))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -580,7 +587,7 @@ If NEGATED non nil negate the tested condition." (list 'cond-jump a b bb target))) (comp-block-maybe-add :name target :sp (+ target-offset (comp-sp))) (comp-mark-block-closed)) - (comp-emit-block bb))) + (comp-emit-block bb (comp-sp)))) (defun comp-stack-adjust (n) "Move sp by N." @@ -623,7 +630,7 @@ If NEGATED non nil negate the tested condition." guarded-bb)) (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) + (comp-emit-block guarded-bb (comp-sp))))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -890,15 +897,16 @@ the annotation emission." do (progn (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) (comp-mark-block-closed) - (comp-emit-block bb) + (comp-emit-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args))) finally (comp-emit-jump 'entry_rest_args)) (cl-loop for i from minarg below nonrest do (comp-with-sp i - (comp-emit-block (intern (format "entry_fallback_%s" i))) + (comp-emit-block (intern (format "entry_fallback_%s" i)) + (comp-sp)) (comp-emit-set-const nil))) - (comp-emit-block 'entry_rest_args) + (comp-emit-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (defun comp-limplify-finalize-function (func) @@ -921,7 +929,7 @@ This will be called at runtime." :sp -1 :frame (comp-new-frame 0))) (comp-block ())) - (comp-emit-block 'entry) + (comp-emit-block 'entry (comp-sp)) (comp-emit-annotation "Top level") (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) @@ -939,7 +947,7 @@ This will be called at runtime." (args-min (comp-args-base-min args)) (comp-block ())) ;; Prologue - (comp-emit-block 'entry) + (comp-emit-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (if (comp-args-p args) @@ -950,7 +958,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block (comp-new-block-sym)) + (comp-emit-block (comp-new-block-sym) (comp-sp)) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) From c8d745d10a45ca3f378d7434f1cff73ae02ba42d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 15:42:49 +0200 Subject: [PATCH 0419/1452] clean-up pass mechanism --- lisp/emacs-lisp/comp.el | 98 +++++++++++++++++++++-------------------- 1 file changed, 50 insertions(+), 48 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7d0c0671e8f..b66bccede54 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -968,12 +968,12 @@ This will be called at runtime." func (comp-ctxt-funcs-h comp-ctxt))) -(defun comp-limplify (funcs) - "Compute the LIMPLE ir for FUNCS. +(defun comp-limplify (lap-funcs) + "Compute the LIMPLE ir for LAP-FUNCS. Top level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (cons (comp-limplify-top-level) - (mapcar #'comp-limplify-function funcs)))) + (mapcar #'comp-limplify-function lap-funcs)))) ;;; SSA pass specific code. @@ -1236,22 +1236,22 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-ssa (funcs) +(defun comp-ssa (_) "Port FUNCS into mininal SSA form." - (cl-loop for comp-func in funcs - do (progn - ;; TODO: if this is run more than once we should clean all CFG - ;; data including phis here. - (comp-func-reset-generators comp-func) - (comp-compute-edges) - (comp-compute-dominator-tree) - (comp-compute-dominator-frontiers) - (comp-log-block-info) - (comp-place-phis) - (comp-ssa-rename) - (comp-finalize-phis) - (comp-log-func comp-func))) - funcs) + (maphash (lambda (_ f) + (let ((comp-func f)) + ;; TODO: if this is run more than once we should clean all CFG + ;; data including phis here. + (comp-func-reset-generators comp-func) + (comp-compute-edges) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info) + (comp-place-phis) + (comp-ssa-rename) + (comp-finalize-phis) + (comp-log-func comp-func))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; propagate pass specific code. @@ -1307,16 +1307,15 @@ This can run just once." do (cl-loop for insn in (comp-block-insns b) do (comp-propagate-insn insn)))) -(defun comp-propagate (funcs) - (cl-loop for comp-func in funcs - do - (progn - (comp-basic-const-propagate) - ;; FIXME: unbelievably dumb... - (cl-loop repeat 10 - do (comp-propagate*)) - (comp-log-func comp-func))) - funcs) +(defun comp-propagate (_) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-basic-const-propagate) + ;; FIXME: unbelievably dumb... + (cl-loop repeat 10 + do (comp-propagate*)) + (comp-log-func comp-func))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Call optimizer pass specific code. @@ -1358,28 +1357,31 @@ This can run just once." (fill-args args (comp-args-max func-args))))) `(,call-type ,callee ,@args)))))))) -(defun comp-call-optim (funcs) - "Given FUNCS try to avoid funcall trampoline usage when possible." +(defun comp-call-optim-func () + "Perform trampoline call optimization for the current function." (cl-loop - for comp-func in funcs - for self = (comp-func-symbol-name comp-func) - when (>= comp-speed 2) + with self = (comp-func-symbol-name comp-func) + for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop - for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) - (setcar insn-cell `(set ,lval ,new-form)))) - (`(callref funcall ,f . ,rest) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) - (setcar insn-cell ,new-form)))))) - (comp-log-func comp-func)) - funcs) + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell ,new-form))))))) + +(defun comp-call-optim (_) + "Given FUNCS try to avoid funcall trampoline usage when possible." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-call-optim-func))) + (comp-ctxt-funcs-h comp-ctxt)))) ;;; Final pass specific code. From 772357698a226cdbf123d04d58573b79fd8814a2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 16:11:48 +0200 Subject: [PATCH 0420/1452] fix nomenclature into declare_function --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index b25013d65ad..2abf4d2a2bd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2635,10 +2635,10 @@ declare_function (Lisp_Object func) gcc_jit_function *gcc_func; char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); - bool ncall = (FUNCALL1 (comp-nargs-p, args)); + bool nargs = (FUNCALL1 (comp-nargs-p, args)); USE_SAFE_ALLOCA; - if (!ncall) + if (!nargs) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); From 6e205873992a2f8eeaecb30adf56346481a2c192 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 16:37:57 +0200 Subject: [PATCH 0421/1452] floating frame in place --- src/comp.c | 99 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 59 insertions(+), 40 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2abf4d2a2bd..00fda6e7051 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,6 +149,7 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ + gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -282,6 +283,16 @@ declare_block (Lisp_Object block_name) Fputhash (block_name, value, comp.func_blocks_h); } +static gcc_jit_lvalue * +get_slot (Lisp_Object mvar) +{ + EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar)); + gcc_jit_lvalue **frame = + (FUNCALL1 (comp-mvar-ref, mvar) || comp_speed < 2) + ? comp.frame : comp.f_frame; + return frame[slot_n]; +} + static void register_emitter (Lisp_Object key, void *func) { @@ -1024,8 +1035,18 @@ emit_mvar_val (Lisp_Object mvar) return emit_const_lisp_obj (constant); } - return - gcc_jit_lvalue_as_rvalue(comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); +} + +static void +emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) +{ + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + get_slot (dst_mvar), + val); } static gcc_jit_rvalue * @@ -1119,7 +1140,7 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) static void emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, - EMACS_UINT clobber_slot) + Lisp_Object clobbered_mvar) { /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ @@ -1169,10 +1190,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_next_field))); - gcc_jit_block_add_assignment ( - comp.block, - NULL, - comp.frame[clobber_slot], + emit_frame_assignment ( + clobbered_mvar, gcc_jit_lvalue_as_rvalue( gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, @@ -1235,7 +1254,6 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qpush_handler)) { - EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); int h_num UNINIT; if (EQ (SECOND (args), Qcatcher)) @@ -1251,7 +1269,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *handler_bb = retrive_block (THIRD (args)); gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, - clobber_slot); + arg0); } else if (EQ (op, Qpop_handler)) { @@ -1283,7 +1301,6 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qset)) { - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = SECOND (args); if (EQ (Ftype_of (arg1), Qcomp_mvar)) @@ -1301,23 +1318,16 @@ emit_limple_insn (Lisp_Object insn) ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + emit_frame_assignment (arg0, res); } else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); EMACS_UINT param_n = XFIXNUM (SECOND (args)); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - param); + emit_frame_assignment (arg0, param); } else if (EQ (op, Qset_args_to_local)) { @@ -1332,11 +1342,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *res = gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + emit_frame_assignment (arg0, res); } else if (EQ (op, Qset_rest_args_to_local)) { @@ -1367,10 +1373,7 @@ emit_limple_insn (Lisp_Object insn) res = emit_call (Qlist, comp.lisp_obj_type, 2, list_args, false); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + emit_frame_assignment (arg0, res); } else if (EQ (op, Qinc_args)) { @@ -1393,21 +1396,18 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qsetimm)) { /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, XFIXNUM (SECOND (args))); emit_comment (SSDATA (Fprin1_to_string (THIRD (args), Qnil))); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - comp.data_relocs, - reloc_n))); + emit_frame_assignment ( + arg0, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + comp.data_relocs, + reloc_n))); } else if (EQ (op, Qcomment)) { @@ -2703,9 +2703,8 @@ compile_function (Lisp_Object func) comp.lisp_obj_type, frame_size), "local"); - comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (int i = 0; i < frame_size; ++i) + for (unsigned i = 0; i < frame_size; ++i) comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, @@ -2715,6 +2714,26 @@ compile_function (Lisp_Object func) comp.int_type, i)); + /* + The floating frame is a copy of the normal frame that can be used to store + locals if the are not going to be used in a nargs call. + This has two advantages: + - Enable gcc for better reordering (frame array is clobbered every time is + passed as parameter being invoved into an nargs function call). + - Allow gcc to trigger other optimizations that are prevented by memory + referencing (ex TCO). + */ + if (comp_speed >= 2) + { + comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); + for (unsigned i = 0; i < frame_size; ++i) + comp.f_frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("local%u", i)); + } + comp.func_blocks_h = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. From 86a22004c9bdd1e93aac773cfda1932061f3b724 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 17:11:53 +0200 Subject: [PATCH 0422/1452] repropagate after call-optim --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b66bccede54..c3ec012c4a1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -57,6 +57,7 @@ comp-ssa comp-propagate comp-call-optim + comp-propagate comp-final) "Passes to be executed in order.") @@ -1278,10 +1279,10 @@ This can run just once." (pcase insn (`(set ,lval ,rval) (pcase rval - (`(call ,f . ,_) + (`(,(or 'call 'direct-call) ,f . ,_) (setf (comp-mvar-type lval) (cdr (assq f comp-known-ret-types)))) - (`(callref ,f . ,args) + (`(,(or 'callref 'direct-callref) ,f . ,args) (cl-loop for v in args do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) From e3ed0208a8ce25ed1d6c82e7e5bb3058d074afc5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 17:58:35 +0200 Subject: [PATCH 0423/1452] better note --- src/comp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 00fda6e7051..042c536926e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1534,9 +1534,9 @@ emit_static_object (const char *name, Lisp_Object obj) /* libgccjit has no support for initialized static data. The mechanism below is certainly not aesthetic but I assume the bottle neck in terms of performance at load time will still be the reader. - NOTE: we can not relay on it even for valid C strings cause of - this funny bug that will affect all pre gcc10 era gccs: - https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + NOTE: we can not relay on libgccjit even for valid NULL terminated C + strings cause of this funny bug that will affect all pre gcc10 era gccs: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ Lisp_Object str = Fprin1_to_string (obj, Qnil); ptrdiff_t len = SBYTES (str); From d9670ef135893c41d33e5bd12c69659bb5d6158f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 18:49:11 +0200 Subject: [PATCH 0424/1452] add dead code removal pass --- lisp/emacs-lisp/comp.el | 96 ++++++++++++++++++++++++++++++++++++++--- src/comp.c | 10 +++-- 2 files changed, 96 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c3ec012c4a1..f65e779a178 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -58,6 +58,7 @@ comp-propagate comp-call-optim comp-propagate + comp-dead-code comp-final) "Passes to be executed in order.") @@ -72,14 +73,23 @@ (% . number)) "Alist used for type propagation.") -(defconst comp-limple-assignments '(set - setimm - set-par-to-local - set-args-to-local - set-rest-args-to-local - push-handler) +(defconst comp-limple-sets '(set + setimm + set-par-to-local + set-args-to-local + set-rest-args-to-local) + "Limple set operators.") + +(defconst comp-limple-assignments `(push-handler + ,@comp-limple-sets) "Limple operators that clobbers the first mvar argument.") +(defconst comp-limple-calls '(call + callref + direct-call + direct-callref) + "Limple operators use to call subrs.") + (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax @@ -234,10 +244,19 @@ structure.") +(defun comp-set-op-p (op) + "Assignment predicate for OP." + (cl-find op comp-limple-sets)) + (defun comp-assign-op-p (op) "Assignment predicate for OP." (cl-find op comp-limple-assignments)) +(defun comp-limple-insn-call-p (insn) + "Limple INSN call predicate." + (when (member (car-safe insn) comp-limple-calls) + t)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." @@ -1384,12 +1403,75 @@ This can run just once." (comp-call-optim-func))) (comp-ctxt-funcs-h comp-ctxt)))) + +;;; Dead code elimination pass specific code. +;; This simple pass try to eliminate insns became useful after propagation. +;; Even if gcc would take care of this is good to perform this here +;; in the hope of removing memory references (remember that most lisp +;; objects are loaded from the reloc array). +;; This pass can be run as last optim. + +(defun comp-collect-mvar-ids (insn) + "Collect the mvar unique identifiers into INSN." + (cl-loop for x in insn + if (consp x) + append (comp-collect-mvar-ids x) + else + when (comp-mvar-p x) + collect (comp-mvar-id x))) + +(defun comp-dead-code-func () + "Clean-up dead code into current function." + (let ((l-vals ()) + (r-vals ())) + ;; Collect used r and l values. + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op arg0 . rest) = insn + if (comp-set-op-p op) + do (push (comp-mvar-id arg0) l-vals) + and + do (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + else + do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) + ;; Every l-value appearing that does not appear as r-value has no right to + ;; exist and gets nuked. + (let ((nuke-list (cl-set-difference l-vals r-vals))) + (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) + (comp-log (format "l-vals %s\n" l-vals)) + (comp-log (format "r-vals %s\n" r-vals)) + (comp-log (format "Nuking ids: %s\n" nuke-list)) + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + for (op arg0 rest) = insn + when (and (comp-set-op-p op) + (member (comp-mvar-id arg0) nuke-list)) + do (setcar insn-cell + (if (comp-limple-insn-call-p rest) + rest + `(comment ,(format "optimized out %s" + insn))))))))) + +(defun comp-dead-code (_) + "Dead code elimination." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-dead-code-func) + (comp-log-func comp-func))) + (comp-ctxt-funcs-h comp-ctxt)))) + ;;; Final pass specific code. (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. -Prepare every functions for final compilation and drive the C side." +Prepare every function for final compilation and drive the C back-end." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-exp-funcs comp-ctxt) diff --git a/src/comp.c b/src/comp.c index 042c536926e..60502da1740 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1295,10 +1295,14 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qcall)) { - gcc_jit_block_add_eval (comp.block, - NULL, + gcc_jit_block_add_eval (comp.block, NULL, emit_limple_call (args)); } + else if (EQ (op, Qcallref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (args, false)); + } else if (EQ (op, Qset)) { Lisp_Object arg1 = SECOND (args); @@ -2721,7 +2725,7 @@ compile_function (Lisp_Object func) - Enable gcc for better reordering (frame array is clobbered every time is passed as parameter being invoved into an nargs function call). - Allow gcc to trigger other optimizations that are prevented by memory - referencing (ex TCO). + referencing. */ if (comp_speed >= 2) { From eaade31040503efdce5c0daccd4c06f856d3fe2f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 19:00:28 +0200 Subject: [PATCH 0425/1452] clean ref slot for mvars optimized by comp-call-optim-form-call --- lisp/emacs-lisp/comp.el | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f65e779a178..24548242c37 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1346,7 +1346,13 @@ This can run just once." (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) - collect (make-comp-mvar :constant nil))))) + collect (make-comp-mvar :constant nil)))) + (clean-args-ref (args) + ;; Clean-up the ref slot in all args + (mapc (lambda (arg) + (setf (comp-mvar-ref arg) nil)) + args) + args)) (when (symbolp callee) ; Do nothing if callee is a byte compiled func. (let* ((f (symbol-function callee)) (subrp (subrp f)) @@ -1363,7 +1369,7 @@ This can run just once." args (fill-args args maxarg)))) (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@args)) + `(,call-type ,callee ,@(clean-args-ref args))) ;; Intra compilation unit procedure call optimization. (when (or (eq callee self) ;; Attention speed 3 triggers that for non self calls too!! @@ -1375,7 +1381,7 @@ This can run just once." (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@args)))))))) + `(,call-type ,callee ,@(clean-args-ref args))))))))) (defun comp-call-optim-func () "Perform trampoline call optimization for the current function." From 6eb77feeee2d85cca1d6695f809072c357875ba8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 19:04:11 +0200 Subject: [PATCH 0426/1452] print object in comment when emitting with emit_const_lisp_obj --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 60502da1740..6daeae311c3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -800,7 +800,8 @@ emit_make_fixnum (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_const_lisp_obj (Lisp_Object obj) { - emit_comment ("const lisp obj"); + emit_comment (format_string ("const lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil)))); Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); From 84caa1a404cb89a6f02aa1cb517f5251e7e0e022 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 19:13:32 +0200 Subject: [PATCH 0427/1452] optimize nil emission --- src/comp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.c b/src/comp.c index 6daeae311c3..afc7a3b1873 100644 --- a/src/comp.c +++ b/src/comp.c @@ -803,6 +803,12 @@ emit_const_lisp_obj (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); + if (Qnil == NULL && EQ (obj, Qnil)) + return emit_cast (comp.lisp_obj_type, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL)); + Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); gcc_jit_rvalue *reloc_n = From 59d53e1fde516b911c29cedf338779df29f59dff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 20:58:26 +0200 Subject: [PATCH 0428/1452] fix push handler propagation --- lisp/emacs-lisp/comp.el | 10 ++++++---- src/comp.c | 20 +++++++++++++------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 24548242c37..34aafe401d4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -644,7 +644,9 @@ If NEGATED non nil negate the tested condition." (let ((guarded-bb (comp-new-block-sym))) (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler (comp-slot+1) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) handler-type handler-bb guarded-bb)) @@ -1022,7 +1024,7 @@ Top level forms for the current context are rendered too." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) - for (op first second third forth) = last-insn + for (op first second third forth fifth) = last-insn do (cl-case op (jump (edge-add :src bb :dst (gethash first blocks))) @@ -1033,8 +1035,8 @@ Top level forms for the current context are rendered too." (edge-add :src bb :dst (gethash second blocks)) (edge-add :src bb :dst (gethash third blocks))) (push-handler - (edge-add :src bb :dst (gethash third blocks)) - (edge-add :src bb :dst (gethash forth blocks))) + (edge-add :src bb :dst (gethash forth blocks)) + (edge-add :src bb :dst (gethash fifth blocks))) (return) (otherwise (error "Block %s does not end with a branch in func %s" diff --git a/src/comp.c b/src/comp.c index afc7a3b1873..4905dbfdcaf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -62,6 +62,8 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (XCDR (x))) #define FORTH(x) \ XCAR (XCDR (XCDR (XCDR (x)))) +#define FIFTH(x) \ + XCAR (XCDR (XCDR (XCDR (XCDR (x))))) #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) @@ -1149,7 +1151,11 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) { - /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ + /* + Ex: (push-handler #s(comp-mvar 1 8 nil nil nil nil) + #s(comp-mvar 1 7 t done symbol nil) + catcher bb_2 bb_1). + */ static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ @@ -1158,8 +1164,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, - format_string ("c_%u", - pushhandler_n)); + format_string ("c_%u", pushhandler_n)); gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( @@ -1263,9 +1268,10 @@ emit_limple_insn (Lisp_Object insn) { gcc_jit_rvalue *handler = emit_mvar_val (arg0); int h_num UNINIT; - if (EQ (SECOND (args), Qcatcher)) + Lisp_Object handler_spec = THIRD (args); + if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; - else if (EQ (SECOND (args), Qcondition_case)) + else if (EQ (handler_spec, Qcondition_case)) h_num = CONDITION_CASE; else ice ("incoherent insn"); @@ -1273,8 +1279,8 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, h_num); - gcc_jit_block *handler_bb = retrive_block (THIRD (args)); - gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); + gcc_jit_block *handler_bb = retrive_block (FORTH (args)); + gcc_jit_block *guarded_bb = retrive_block (FIFTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, arg0); } From 9b5f8ebb5bb970c34400b149190b2d16886ae814 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 21:28:05 +0200 Subject: [PATCH 0429/1452] fix missing direct call parsing in comp back-end --- src/comp.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 4905dbfdcaf..52309fe8217 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1316,6 +1316,17 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block_add_eval (comp.block, NULL, emit_limple_call_ref (args, false)); } + else if (EQ (op, Qdirect_call)) + { + gcc_jit_block_add_eval ( + comp.block, NULL, + emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true)); + } + else if (EQ (op, Qdirect_callref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (XCDR (insn), true)); + } else if (EQ (op, Qset)) { Lisp_Object arg1 = SECOND (args); @@ -1328,7 +1339,7 @@ emit_limple_insn (Lisp_Object insn) res = emit_limple_call_ref (XCDR (arg1), false); else if (EQ (FIRST (arg1), Qdirect_call)) res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true); - else if (EQ (FIRST (arg1), Qcallref)) + else if (EQ (FIRST (arg1), Qdirect_callref)) res = emit_limple_call_ref (XCDR (arg1), true); else ice ("LIMPLE inconsistent arg1 for op ="); From 89abc8d66f7668060305e9f0e5dc3ebfddfff3fa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 22:49:00 +0200 Subject: [PATCH 0430/1452] move gcc_jit_context_dump_reproducer_to_file --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 52309fe8217..ce6a43af798 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2863,8 +2863,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, 1); - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - } comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); @@ -3038,6 +3036,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_c)); gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); } + if (COMP_DEBUG > 1) + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); const char *filename = From 414a2b5bbc6ce441a8102254c593699e503d4f57 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Sep 2019 21:54:38 +0200 Subject: [PATCH 0431/1452] use type propagation into add1 sub1 negate --- src/comp.c | 100 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 66 insertions(+), 34 deletions(-) diff --git a/src/comp.c b/src/comp.c index ce6a43af798..8ee667e10b8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1459,25 +1459,36 @@ emit_limple_insn (Lisp_Object insn) /* Inliners. */ /**************/ +static gcc_jit_rvalue * +emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); +} + static gcc_jit_rvalue * emit_add1 (Lisp_Object insn) { - gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, NULL, comp.add1, 1, &n); + return emit_call_with_type_hint (comp.add1, insn, Qfixnum); } static gcc_jit_rvalue * emit_sub1 (Lisp_Object insn) { - gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); + return emit_call_with_type_hint (comp.sub1, insn, Qfixnum); } static gcc_jit_rvalue * emit_negate (Lisp_Object insn) { - gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, NULL, comp.negate, 1, &n); + return emit_call_with_type_hint (comp.negate, insn, Qfixnum); } static gcc_jit_rvalue * @@ -2369,7 +2380,6 @@ static void define_add1_sub1 (void) { gcc_jit_block *bb_orig = comp.block; - gcc_jit_function *func[2]; char const *f_name[] = {"add1", "sub1"}; char const *fall_back_func[] = {"1+", "1-"}; @@ -2377,32 +2387,46 @@ define_add1_sub1 (void) { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; - for (int i = 0; i < 2; i++) + for (unsigned i = 0; i < 2; i++) { - gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "n"); + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_fixnum") }; comp.func = func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, f_name[i], - 1, - ¶m, - 0); + 2, + param, 0); DECL_BLOCK (entry_block, func[i]); DECL_BLOCK (inline_block, func[i]); DECL_BLOCK (fcall_block, func[i]); comp.block = entry_block; - /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + /* is_fixnum || + ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM ? (XFIXNUM (n) + 1) : Fadd1 (n)) */ - gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param); + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + gcc_jit_rvalue *sure_fixnum = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_FIXNUMP (n))); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2410,8 +2434,7 @@ define_add1_sub1 (void) NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (n)), + sure_fixnum, gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2449,21 +2472,22 @@ static void define_negate (void) { gcc_jit_block *bb_orig = comp.block; - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "n") }; + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_fixnum") }; comp.func = comp.negate = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, "negate", - 1, - param, - 0); + 2, param, 0); DECL_BLOCK (entry_block, comp.negate); DECL_BLOCK (inline_block, comp.negate); @@ -2471,13 +2495,20 @@ define_negate (void) comp.block = entry_block; - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (- XFIXNUM (TOP)) - : Fminus (1, &TOP)) */ + /* (is_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); - gcc_jit_rvalue *n_fixnum = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + gcc_jit_rvalue *sure_fixnum = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2485,8 +2516,7 @@ define_negate (void) NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))), + sure_fixnum, gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -3305,6 +3335,8 @@ syms_of_comp (void) /* Returned values. */ DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); + /* Others. */ + DEFSYM (Qfixnum, "fixnum"); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); From bdea0f62b55e986136f5677369f354e4f5849863 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 09:13:46 +0200 Subject: [PATCH 0432/1452] add some call optimizer doc --- lisp/emacs-lisp/comp.el | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 34aafe401d4..913761b3735 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1341,7 +1341,19 @@ This can run just once." ;;; Call optimizer pass specific code. -;; Try to avoid funcall trampoline use when possible. +;; This pass is responsible for the following optimizations: +;; - Call to subrs that are in defined in the C source and are passing through +;; funcall trampoline gets optimized into normal indirect calls. +;; This makes effectively this calls equivalent to all the subrs that got +;; dedicated byte-code ops. +;; Triggered at comp-speed >= 2. +;; - Recursive calls gets optimized into direct calls. +;; Triggered at comp-speed >= 2. +;; - Intra compilation unit procedure calls gets optimized into direct calls. +;; This can be a big win and even allow gcc to inline but does not make +;; function in the compilation unit re-definable safely without recompiling +;; the full compilation unit. +;; For this reason this is triggered only at comp-speed == 3. (defun comp-call-optim-form-call (callee args self) "" @@ -1361,6 +1373,7 @@ This can run just once." (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) (if (and subrp (not (subr-native-elispp f))) + ;; Trampoline removal. (let* ((maxarg (cdr (subr-arity f))) (call-type (if (if subrp (not (numberp maxarg)) From 8f3af3f61f43f2090bef30edbb9f8ae1a36c2e5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 09:37:58 +0200 Subject: [PATCH 0433/1452] add type hint to car and cdr --- src/comp.c | 101 ++++++++++++++++++++++------------------------------- 1 file changed, 41 insertions(+), 60 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8ee667e10b8..1a22eccb430 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1506,21 +1506,13 @@ emit_consp (Lisp_Object insn) static gcc_jit_rvalue * emit_car (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.car, - 1, &x); + return emit_call_with_type_hint (comp.car, insn, Qcons); } static gcc_jit_rvalue * emit_cdr (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.cdr, - 1, &x); + return emit_call_with_type_hint (comp.cdr, insn, Qcons); } static gcc_jit_rvalue * @@ -2224,63 +2216,52 @@ define_CHECK_TYPE (void) static void define_CAR_CDR (void) { - gcc_jit_param *car_param = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "c"); - comp.car = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "CAR", - 1, - &car_param, - 0); - gcc_jit_param *cdr_param = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "c"); - comp.cdr = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "CDR", - 1, - &cdr_param, - 0); - - gcc_jit_function *f = comp.car; - gcc_jit_param *param = car_param; - + gcc_jit_function *func[2]; + char const *f_name[] = {"CAR", "CDR"}; for (int i = 0; i < 2; i++) { - gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - DECL_BLOCK (entry_block, f); - DECL_BLOCK (is_cons_b, f); - DECL_BLOCK (not_a_cons_b, f); + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_cons") }; + func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + f_name [i], + 2, param, 0); + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]); + DECL_BLOCK (entry_block, func[i]); + DECL_BLOCK (is_cons_b, func[i]); + DECL_BLOCK (not_a_cons_b, func[i]); comp.block = entry_block; - comp.func = f; - - emit_cond_jump (emit_CONSP (c), is_cons_b, not_a_cons_b); - + comp.func = func[i]; + emit_cond_jump ( + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_CONSP (c))), + is_cons_b, + not_a_cons_b); comp.block = is_cons_b; - - if (f == comp.car) - gcc_jit_block_end_with_return (comp.block, - NULL, - emit_XCAR (c)); + if (i == 0) + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); else - gcc_jit_block_end_with_return (comp.block, - NULL, - emit_XCDR (c)); + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c)); comp.block = not_a_cons_b; - DECL_BLOCK (is_nil_b, f); - DECL_BLOCK (not_nil_b, f); + DECL_BLOCK (is_nil_b, func[i]); + DECL_BLOCK (not_nil_b, func[i]); emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); @@ -2301,9 +2282,9 @@ define_CAR_CDR (void) gcc_jit_block_end_with_return (comp.block, NULL, emit_const_lisp_obj (Qnil)); - f = comp.cdr; - param = cdr_param; } + comp.car = func[0]; + comp.cdr = func[1]; } static void From c0ac7d039fb003444769700d60d06538341ba884 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 10:01:31 +0200 Subject: [PATCH 0434/1452] add type hint to setcar setcdr --- src/comp.c | 58 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1a22eccb430..c968d2bf705 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1473,6 +1473,23 @@ emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); } +/* Same as before but with two args. The type hint is on the 2th. */ +static gcc_jit_rvalue * +emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args); +} + + static gcc_jit_rvalue * emit_add1 (Lisp_Object insn) { @@ -1518,25 +1535,13 @@ emit_cdr (Lisp_Object insn) static gcc_jit_rvalue * emit_setcar (Lisp_Object insn) { - gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), - emit_mvar_val (THIRD (insn)) }; - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcar, - 2, args); + return emit_call2_with_type_hint (comp.setcar, insn, Qcons); } static gcc_jit_rvalue * emit_setcdr (Lisp_Object insn) { - gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), - emit_mvar_val (THIRD (insn)) }; - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcdr, - 2, args); + return emit_call2_with_type_hint (comp.setcdr, insn, Qcons); } static gcc_jit_rvalue * @@ -2217,7 +2222,7 @@ static void define_CAR_CDR (void) { gcc_jit_function *func[2]; - char const *f_name[] = {"CAR", "CDR"}; + char const *f_name[] = { "CAR", "CDR" }; for (int i = 0; i < 2; i++) { gcc_jit_param *param[] = @@ -2290,8 +2295,8 @@ define_CAR_CDR (void) static void define_setcar_setcdr (void) { - char const *f_name[] = {"setcar", "setcdr"}; - char const *par_name[] = {"new_car", "new_cdr"}; + char const *f_name[] = { "setcar", "setcdr" }; + char const *par_name[] = { "new_car", "new_cdr" }; for (int i = 0; i < 2; i++) { @@ -2306,16 +2311,20 @@ define_setcar_setcdr (void) comp.lisp_obj_type, par_name[i]); - gcc_jit_param *param[] = { cell, new_el }; + gcc_jit_param *param[] = + { cell, + new_el, + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_cons") }; gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, f_name[i], - 2, - param, - 0); + 3, param, 0); DECL_BLOCK (entry_block, *f_ref); comp.func = *f_ref; comp.block = entry_block; @@ -2328,8 +2337,7 @@ define_setcar_setcdr (void) { gcc_jit_param_as_rvalue (cell), emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; - gcc_jit_block_add_eval ( - entry_block, + gcc_jit_block_add_eval (entry_block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2362,8 +2370,8 @@ define_add1_sub1 (void) { gcc_jit_block *bb_orig = comp.block; gcc_jit_function *func[2]; - char const *f_name[] = {"add1", "sub1"}; - char const *fall_back_func[] = {"1+", "1-"}; + char const *f_name[] = { "add1", "sub1" }; + char const *fall_back_func[] = { "1+", "1-" }; gcc_jit_rvalue *compare[] = { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = From d9db77704026ab0871325d431cae765981d167c2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 10:51:40 +0200 Subject: [PATCH 0435/1452] rework comp-call-optim-form-call --- lisp/emacs-lisp/comp.el | 51 +++++++++++++++++++++-------------------- 1 file changed, 26 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 913761b3735..2525287716a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1372,31 +1372,32 @@ This can run just once." (subrp (subrp f)) (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) - (if (and subrp (not (subr-native-elispp f))) - ;; Trampoline removal. - (let* ((maxarg (cdr (subr-arity f))) - (call-type (if (if subrp - (not (numberp maxarg)) - (comp-nargs-p callee-in-unit)) - 'callref - 'call)) - (args (if (eq call-type 'callref) - args - (fill-args args maxarg)))) - (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@(clean-args-ref args))) - ;; Intra compilation unit procedure call optimization. - (when (or (eq callee self) - ;; Attention speed 3 triggers that for non self calls too!! - (and (>= comp-speed 3) - callee-in-unit)) - (let* ((func-args (comp-func-args callee-in-unit)) - (nargs (comp-nargs-p func-args)) - (call-type (if nargs 'direct-callref 'direct-call)) - (args (if (eq call-type 'direct-callref) - args - (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@(clean-args-ref args))))))))) + (cond + ((and subrp (not (subr-native-elispp f))) + ;; Trampoline removal. + (let* ((maxarg (cdr (subr-arity f))) + (call-type (if (if subrp + (not (numberp maxarg)) + (comp-nargs-p callee-in-unit)) + 'callref + 'call)) + (args (if (eq call-type 'callref) + args + (fill-args args maxarg)))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@(clean-args-ref args)))) + ;; Intra compilation unit procedure call optimization. + ;; Attention speed 3 triggers that for non self calls too!! + ((or (eq callee self) + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((func-args (comp-func-args callee-in-unit)) + (nargs (comp-nargs-p func-args)) + (call-type (if nargs 'direct-callref 'direct-call)) + (args (if (eq call-type 'direct-callref) + args + (fill-args args (comp-args-max func-args))))) + `(,call-type ,callee ,@(clean-args-ref args))))))))) (defun comp-call-optim-func () "Perform trampoline call optimization for the current function." From d66d6ec5138049b98d99c4dcdd2c78582a6afe0f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 11:41:36 +0200 Subject: [PATCH 0436/1452] initial add for compiler hits --- lisp/emacs-lisp/comp.el | 63 ++++++++++++++++++++++++++++++++++------- 1 file changed, 52 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2525287716a..78455d5e7e5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -70,9 +70,16 @@ (- . number) (* . number) (/ . number) - (% . number)) + (% . number) + ;; Type hint + (comp-hint-fixnum . fixnum) + (comp-hint-cons . cons)) "Alist used for type propagation.") +(defconst comp-type-hints '(comp-hint-fixnum + comp-hint-cons) + "List of fake functions used to give compiler hints.") + (defconst comp-limple-sets '(set setimm set-par-to-local @@ -257,6 +264,10 @@ structure.") (when (member (car-safe insn) comp-limple-calls) t)) +(defun comp-type-hint-p (func) + "Type hint predicate for function name FUNC." + (member func comp-type-hints)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." @@ -1200,7 +1211,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename-insn (insn frame) (dotimes (slot-n (comp-func-frame-size comp-func)) - (cl-flet ((target-p (x) + (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) (eql slot-n (comp-mvar-slot x)))) @@ -1210,16 +1221,16 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setf (aref frame slot-n) mvar) (setf (cadr insn) mvar)))) (pcase insn - (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) + (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) (let ((mvar (aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn)))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) (new-lvalue)) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) (_ (let ((mvar (aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn))))))))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () "Entry point to rename SSA within the current function." @@ -1397,7 +1408,9 @@ This can run just once." (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@(clean-args-ref args))))))))) + `(,call-type ,callee ,@(clean-args-ref args)))) + ((comp-type-hint-p callee) + `(call ,callee ,@args))))))) (defun comp-call-optim-func () "Perform trampoline call optimization for the current function." @@ -1431,6 +1444,7 @@ This can run just once." ;; Even if gcc would take care of this is good to perform this here ;; in the hope of removing memory references (remember that most lisp ;; objects are loaded from the reloc array). +;; ;; This pass can be run as last optim. (defun comp-collect-mvar-ids (insn) @@ -1442,8 +1456,8 @@ This can run just once." when (comp-mvar-p x) collect (comp-mvar-id x))) -(defun comp-dead-code-func () - "Clean-up dead code into current function." +(defun comp-dead-assignments-func () + "Clean-up dead assignments into current function." (let ((l-vals ()) (r-vals ())) ;; Collect used r and l values. @@ -1476,15 +1490,28 @@ This can run just once." do (setcar insn-cell (if (comp-limple-insn-call-p rest) rest - `(comment ,(format "optimized out %s" + `(comment ,(format "optimized out: %s" insn))))))))) +(defun comp-remove-type-hints-func () + "Remove type hints from the current function. +These are substituted with normals 'set'." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setcar insn-cell `(set ,l-val ,r-val))))))) + (defun comp-dead-code (_) "Dead code elimination." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-dead-code-func) + (comp-dead-assignments-func) + (comp-remove-type-hints-func) (comp-log-func comp-func))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -1522,7 +1549,21 @@ Prepare every function for final compilation and drive the C back-end." compile-result)))) -;;; Entry points. +;;; Compiler type hints. +;; These are public entry points be used in user code to give comp suggestion +;; about types. +;; Note that types will propagates. +;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions +;; are assumed just to be true. Use with extreme caution... + +(defun comp-hint-fixnum (x) + (cl-assert (fixnump x))) + +(defun comp-hint-cons (x) + (cl-assert (consp x))) + + +;;; Compiler entry points. (defun native-compile (input) "Compile INPUT into native code. From 82a018e0622221910a7a02f683601c9f8c569cb1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 12:45:06 +0200 Subject: [PATCH 0437/1452] better description --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 78455d5e7e5..c685a516667 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -24,7 +24,7 @@ ;;; Commentary: ;; This code is an attempt to make the pig fly. -;; Or, to put it another way to make a Carrera out of a turbocharged VW Bug. +;; Or, to put it another way to make a 911 out of a turbocharged VW Bug. ;;; Code: @@ -1552,7 +1552,8 @@ Prepare every function for final compilation and drive the C back-end." ;;; Compiler type hints. ;; These are public entry points be used in user code to give comp suggestion ;; about types. -;; Note that types will propagates. +;; These can be used to implement CL style 'the', 'declare' or something like. +;; Note: types will propagates. ;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions ;; are assumed just to be true. Use with extreme caution... From bb25117eb40a08824142a5a56acc14d3fb4c89a4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Sep 2019 11:48:19 +0200 Subject: [PATCH 0438/1452] add comp-native-compiling flag --- lisp/emacs-lisp/comp.el | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c685a516667..98d9e7376ff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -45,6 +45,10 @@ (defconst native-compile-log-buffer "*Native-compile-Log*" "Name of the native-compiler's log buffer.") +(defvar comp-native-compiling nil + "This gets bound to t while native compilation. +Can be used by code that wants to expand differently in this case.") + ;; FIXME these has to be removed (defvar comp-speed 2) (defvar comp-verbose nil) @@ -1575,6 +1579,7 @@ If INPUT is a string, use it as the file path to be native compiled." (stringp input)) (error "Trying to native compile something not a symbol function or file")) (let ((data input) + (comp-native-compiling t) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) (symbol-name input) (file-name-sans-extension input))))) From 9c31066ccdd6dbc7e9bd7a9a56de5c3103841018 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Sep 2019 22:08:28 +0200 Subject: [PATCH 0439/1452] fix comp.el compilation --- lisp/emacs-lisp/comp.el | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98d9e7376ff..13bc3de5ac9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -379,7 +379,6 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :symbol-name function-name - :func f :c-func-name (comp-c-func-name function-name "F")))) From 5630ebaf74f2f86e5d59fe4cba5ba96333e9fa6f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Sep 2019 22:15:24 +0200 Subject: [PATCH 0440/1452] do not force inlining for func involving ipa-pro --- src/comp.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index c968d2bf705..48ddba7eb27 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2234,9 +2234,14 @@ define_CAR_CDR (void) NULL, comp.bool_type, "is_cons") }; + /* TODO: understand why after ipa-prop pass gcc is less keen on inlining + and as consequence can refuse to compile these. (see dhrystone.el) + Flag this and all the one involved in ipa-prop as + GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case. + This seems at least to have no perf downside. */ func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, f_name [i], 2, param, 0); @@ -2321,7 +2326,7 @@ define_setcar_setcdr (void) gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, f_name[i], 3, param, 0); @@ -2389,7 +2394,7 @@ define_add1_sub1 (void) "is_fixnum") }; comp.func = func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, f_name[i], 2, @@ -2473,7 +2478,7 @@ define_negate (void) comp.func = comp.negate = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, "negate", 2, param, 0); From 7d3da0a37edd57f6a31dff4864bcf1753de48698 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 26 Sep 2019 12:11:13 +0200 Subject: [PATCH 0441/1452] fix subr-native-elisp-p predicate name --- lisp/emacs-lisp/comp.el | 2 +- src/data.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 13bc3de5ac9..209c4e68b6a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1387,7 +1387,7 @@ This can run just once." (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) (cond - ((and subrp (not (subr-native-elispp f))) + ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. (let* ((maxarg (cdr (subr-arity f))) (call-type (if (if subrp diff --git a/src/data.c b/src/data.c index 70068c30a71..2a32d47c49b 100644 --- a/src/data.c +++ b/src/data.c @@ -865,7 +865,7 @@ SUBR must be a built-in function. */) } #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-elispp", Fsubr_native_elispp, Ssubr_native_elispp, 1, 1, 0, +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, doc: /* Return t if the subr is native compiled elisp, nil otherwise. */) (Lisp_Object subr) @@ -3995,7 +3995,7 @@ syms_of_data (void) defsubr (&Ssubr_arity); defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP - defsubr (&Ssubr_native_elispp); + defsubr (&Ssubr_native_elisp_p); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); From 9da698575addc4b9c007d7d6c1590bc5ac245bdc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 11:05:54 +0200 Subject: [PATCH 0442/1452] always expand file name when bytecompiling --- lisp/emacs-lisp/comp.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 209c4e68b6a..cb88bd88525 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1579,9 +1579,10 @@ If INPUT is a string, use it as the file path to be native compiled." (error "Trying to native compile something not a symbol function or file")) (let ((data input) (comp-native-compiling t) - (comp-ctxt (make-comp-ctxt :output (if (symbolp input) - (symbol-name input) - (file-name-sans-extension input))))) + (comp-ctxt (make-comp-ctxt + :output (if (symbolp input) + (symbol-name input) + (file-name-sans-extension (expand-file-name input)))))) (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) From 8f1670b40fc9a779303207710a913b769170e82a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 14:32:02 +0200 Subject: [PATCH 0443/1452] don't crash when trying to format a very long string --- src/comp.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 48ddba7eb27..f55aa8191e3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -205,7 +205,11 @@ format_string (const char *format, ...) va_start (va, format); int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va); if (res >= sizeof (scratch_area)) - error ("Truncating string"); + { + scratch_area[sizeof (scratch_area) - 4] = '.'; + scratch_area[sizeof (scratch_area) - 3] = '.'; + scratch_area[sizeof (scratch_area) - 2] = '.'; + } va_end (va); return scratch_area; } @@ -302,7 +306,7 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } -INLINE static void +static void emit_comment (const char *str) { if (COMP_DEBUG) From 734eb8f940c197e4b3548e7b79d716203e37aa8d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 14:36:09 +0200 Subject: [PATCH 0444/1452] remove defvar that is not anymore necessary --- lisp/emacs-lisp/comp.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cb88bd88525..5f312e860fb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -49,8 +49,6 @@ "This gets bound to t while native compilation. Can be used by code that wants to expand differently in this case.") -;; FIXME these has to be removed -(defvar comp-speed 2) (defvar comp-verbose nil) (defvar comp-pass nil From de1f89c202427a8bcb783f0b44fd02326b320a65 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 17:54:10 +0200 Subject: [PATCH 0445/1452] remove comp-debug --- lisp/emacs-lisp/comp.el | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5f312e860fb..ef602c13811 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,9 +37,9 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-debug t - "Log compilation process." - :type 'boolean +(defcustom comp-verbose 1 + "Compiler verbosity. From 0 to 3." + :type 'number :group 'comp) (defconst native-compile-log-buffer "*Native-compile-Log*" @@ -49,8 +49,6 @@ "This gets bound to t while native compilation. Can be used by code that wants to expand differently in this case.") -(defvar comp-verbose nil) - (defvar comp-pass nil "Every pass has the right to bind what it likes here.") @@ -290,10 +288,10 @@ The corresponding index is returned." (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. -BODY is evaluate only if `comp-debug' is non nil." +BODY is evaluate only if `comp-verbose' is > 0." (declare (debug (form body)) (indent defun)) - `(when comp-debug + `(when (> comp-verbose 0) (with-current-buffer (get-buffer-create native-compile-log-buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) @@ -303,7 +301,7 @@ BODY is evaluate only if `comp-debug' is non nil." (defun comp-log (data) "Log DATA." (if (and noninteractive - comp-verbose) + (> comp-verbose 0)) (if (atom data) (message "%s" data) (mapc (lambda (x) From bf253dd2e9e41a14b813692828ffc43ed24391ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 18:41:31 +0200 Subject: [PATCH 0446/1452] regulate verbosity with comp-verbose --- lisp/emacs-lisp/comp.el | 60 +++++++++++++++++++++++++---------------- 1 file changed, 37 insertions(+), 23 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ef602c13811..cd1a6b2e931 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,8 +37,12 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-verbose 1 - "Compiler verbosity. From 0 to 3." +(defcustom comp-verbose 0 + "Compiler verbosity. From 0 to 3. +- 0 no logging +- 1 final limple is logged +- 2 LAP and final limple are logged +- 3 all passes are dumping" :type 'number :group 'comp) @@ -317,7 +321,7 @@ BODY is evaluate only if `comp-verbose' is > 0." (defun comp-log-func (func) "Log function FUNC." - (comp-log (format "\n Function: %s" (comp-func-symbol-name func))) + (comp-log (format "\nFunction: %s" (comp-func-symbol-name func))) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn @@ -327,12 +331,15 @@ BODY is evaluate only if `comp-verbose' is > 0." (defun comp-log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges func))) - (comp-log (format "\nEdges in function: %s\n" (comp-func-symbol-name func))) + (when (> comp-verbose 2) + (comp-log (format "\nEdges in function: %s\n" + (comp-func-symbol-name func)))) (mapc (lambda (e) - (comp-log (format "n: %d src: %s dst: %s\n" - (comp-edge-number e) - (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e))))) + (when (> comp-verbose 2) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e)))))) edges))) @@ -415,7 +422,7 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (aref bytecode 3)) - do (progn + do (when (> comp-verbose 1) (comp-log (format "Function %s:\n" name)) (comp-log lap)) collect func)) @@ -946,7 +953,8 @@ the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (nreverse (comp-block-insns bb)))) - (comp-log-func func) + (when (> comp-verbose 2) + (comp-log-func func)) func) (defun comp-limplify-top-level () @@ -1105,7 +1113,8 @@ Top level forms for the current context are rendered too." with changed = t while changed initially (progn - (comp-log "Computing dominator tree...\n") + (when (> comp-verbose 2) + (comp-log "Computing dominator tree...\n")) (setf (comp-block-dom entry) entry) ;; Set the post order number. (cl-loop for name in (reverse rev-bb-list) @@ -1145,11 +1154,12 @@ Top level forms for the current context are rendered too." (maphash (lambda (name bb) (let ((dom (comp-block-dom bb)) (df (comp-block-df bb))) - (comp-log (format "block: %s idom: %s DF %s\n" - name - (when dom (comp-block-name dom)) - (cl-loop for b being each hash-keys of df - collect b))))) + (when (> comp-verbose 2) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of df + collect b)))))) (comp-func-blocks comp-func))) (defun comp-place-phis () @@ -1233,7 +1243,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename () "Entry point to rename SSA within the current function." - (comp-log "Renaming\n") + (when (> comp-verbose 2) + (comp-log "Renaming\n")) (let ((frame-size (comp-func-frame-size comp-func)) (visited (make-hash-table))) (cl-labels ((ssa-rename-rec (bb in-frame) @@ -1282,7 +1293,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func))) + (when (> comp-verbose 2) + (comp-log-func comp-func)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1346,7 +1358,8 @@ This can run just once." ;; FIXME: unbelievably dumb... (cl-loop repeat 10 do (comp-propagate*)) - (comp-log-func comp-func))) + (when (> comp-verbose 2) + (comp-log-func comp-func)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1474,10 +1487,11 @@ This can run just once." ;; Every l-value appearing that does not appear as r-value has no right to ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) - (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) - (comp-log (format "l-vals %s\n" l-vals)) - (comp-log (format "r-vals %s\n" r-vals)) - (comp-log (format "Nuking ids: %s\n" nuke-list)) + (when (> comp-verbose 2) + (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) + (comp-log (format "l-vals %s\n" l-vals)) + (comp-log (format "r-vals %s\n" r-vals)) + (comp-log (format "Nuking ids: %s\n" nuke-list))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop From b8127e988e2af662bdcd7cf25d281469a5142df6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 19:31:19 +0200 Subject: [PATCH 0447/1452] remove unnecessary autostirng usage --- src/comp.c | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index f55aa8191e3..15699a02118 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3047,23 +3047,19 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_add1_sub1 (); define_negate (); - /* Compile all functions. Can't be done before because the - relocation structs has to be already defined. */ struct Lisp_Hash_Table *func_h = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) declare_function (HASH_VALUE (func_h, i)); + /* Compile all functions. Can't be done before because the + relocation structs has to be already defined. */ for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); - /* FIXME use format_string here */ if (COMP_DEBUG) - { - AUTO_STRING (dot_c, ".c"); - const char *filename = - (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_c)); - gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); - } + gcc_jit_context_dump_to_file (comp.ctxt, + format_string ("%s.c", SSDATA (ctxtname)), + 1); if (COMP_DEBUG > 1) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); From d19bb4861553fe82b86ef09db6cb6b1fe1eae829 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 19:58:09 +0200 Subject: [PATCH 0448/1452] fix missing direct parameter forwarding into emit_limple_call_ref --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 15699a02118..2ab9d034ebf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1145,7 +1145,7 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); - return emit_call_ref (callee, nargs, comp.frame[base_ptr], false); + return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } /* Register an handler for a non local exit. */ From 9ff098615f92cf9fe4aa0f1c6835dbf9198daa6c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 30 Sep 2019 04:43:01 +0200 Subject: [PATCH 0449/1452] remove INLINE hints from comp.c --- src/comp.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2ab9d034ebf..039daeeaadc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -230,7 +230,7 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -INLINE static gcc_jit_field * +static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { gcc_jit_field *field; @@ -419,7 +419,7 @@ emit_call_ref (Lisp_Object subr_sym, unsigned nargs, /* Close current basic block emitting a conditional. */ -INLINE static void +static void emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { @@ -506,7 +506,7 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, offset)); } -INLINE static gcc_jit_rvalue * +static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { emit_comment ("XLI"); @@ -516,7 +516,7 @@ emit_XLI (gcc_jit_rvalue *obj) comp.lisp_obj_as_num); } -INLINE static gcc_jit_lvalue * +static gcc_jit_lvalue * emit_lval_XLI (gcc_jit_lvalue *obj) { emit_comment ("lval_XLI"); @@ -526,7 +526,7 @@ emit_lval_XLI (gcc_jit_lvalue *obj) comp.lisp_obj_as_num); } -INLINE static gcc_jit_rvalue * +static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { emit_comment ("XLP"); @@ -536,7 +536,7 @@ emit_XLP (gcc_jit_rvalue *obj) comp.lisp_obj_as_ptr); } -INLINE static gcc_jit_lvalue * +static gcc_jit_lvalue * emit_lval_XLP (gcc_jit_lvalue *obj) { emit_comment ("lval_XLP"); From abac70f198fc6502e3b4d81f9d9590e9d7432378 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 30 Sep 2019 17:04:49 +0200 Subject: [PATCH 0450/1452] ignore anonymous forms (they are not functions) --- lisp/emacs-lisp/comp.el | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cd1a6b2e931..796c130efaa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -408,11 +408,8 @@ Put PREFIX in front of it." ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) - ;; Hacky! We need to reverse `byte-to-native-lap' to have the compiled top - ;; level form that matters (ex exclude lambdas)... - (cl-loop with lap-funcs = byte-to-native-lap - for (name . bytecode) in byte-to-native-bytecode - for lap = (cdr (assoc name lap-funcs)) + (cl-loop for (name . bytecode) in (remove-if-not #'car byte-to-native-bytecode) + for lap = (cdr (assoc name byte-to-native-lap)) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name :byte-func bytecode From 1f91b8c6eedc12fce03e76ebf8b9c039c5a0a0b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 30 Sep 2019 17:13:07 +0200 Subject: [PATCH 0451/1452] better immediate type propagation --- lisp/emacs-lisp/comp.el | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 796c130efaa..9f808d2704b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1298,16 +1298,25 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;;; propagate pass specific code. ;; A very basic propagation pass follows. +(defsubst comp-strict-type-of (obj) + "Given OBJ return its type understanding fixnums." + ;; Should be certainly smarter but now we take advantages just from fixnums. + (if (fixnump obj) + 'fixnum + (type-of obj))) + (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. This can run just once." - (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop for insn in (comp-block-insns b) - do (pcase insn - (`(setimm ,lval ,_ ,v) - (setf (comp-mvar-const-vld lval) t) - (setf (comp-mvar-constant lval) v) - (setf (comp-mvar-type lval) (type-of v))))))) + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(setimm ,lval ,_ ,v) + (setf (comp-mvar-const-vld lval) t) + (setf (comp-mvar-constant lval) v) + (setf (comp-mvar-type lval) (comp-strict-type-of v))))))) (defsubst comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." From 65c0d931f79672e15c6dfd633b619eabfbe9183a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 3 Oct 2019 22:15:43 +0200 Subject: [PATCH 0452/1452] alist-get instead of assoc cdr --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9f808d2704b..584a02af0e3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -389,7 +389,7 @@ Put PREFIX in front of it." (error "Can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (let ((lap (cdr (assoc function-name (reverse byte-to-native-bytecode))))) + (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) (cl-assert lap) (comp-log lap) (let ((lambda-list (aref (comp-func-byte-func func) 0))) @@ -409,7 +409,7 @@ Put PREFIX in front of it." ('defconst (cdr x)))) byte-to-native-top-level-forms))) (cl-loop for (name . bytecode) in (remove-if-not #'car byte-to-native-bytecode) - for lap = (cdr (assoc name byte-to-native-lap)) + for lap = (alist-get name byte-to-native-lap) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name :byte-func bytecode @@ -1330,12 +1330,12 @@ This can run just once." (pcase rval (`(,(or 'call 'direct-call) ,f . ,_) (setf (comp-mvar-type lval) - (cdr (assq f comp-known-ret-types)))) + (alist-get f comp-known-ret-types))) (`(,(or 'callref 'direct-callref) ,f . ,args) (cl-loop for v in args do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) - (cdr (assq f comp-known-ret-types)))) + (alist-get f comp-known-ret-types))) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) From 0ae14c17a24545dacf8ed309b2a75f8f1ed7da5c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 14:48:15 +0200 Subject: [PATCH 0453/1452] fix compilation of devar defconst with doc string --- lisp/emacs-lisp/bytecomp.el | 2 +- lisp/emacs-lisp/comp.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1666dff7117..72e58350209 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2276,7 +2276,7 @@ we output that argument and the following argument QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." - (when byte-native-compiling + (when (and byte-native-compiling name) ;; Spill bytecode output for the native compiler here (push (cons name (apply #'vector form)) byte-to-native-bytecode)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 584a02af0e3..3f8482b5d02 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -408,7 +408,7 @@ Put PREFIX in front of it." ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) - (cl-loop for (name . bytecode) in (remove-if-not #'car byte-to-native-bytecode) + (cl-loop for (name . bytecode) in byte-to-native-bytecode for lap = (alist-get name byte-to-native-lap) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name From 0cbe9c204e938977fef12dd4cc47d43a702ebfa9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 14:51:56 +0200 Subject: [PATCH 0454/1452] add comp-test-silly-frame to tests --- test/src/comp-test-funcs.el | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index e43db6973b7..3d8d3437bda 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -338,4 +338,15 @@ (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-frame (x) + (cl-case x + (0 (comp-test-callee + (pcase comp-tests-var1 + (1 1) + (2 2)) + 3)))) + ;;; comp-test-funcs.el ends here From 63078fb5af152934c5aa5facc5afd7f8e1907ade Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Sep 2019 21:43:57 +0200 Subject: [PATCH 0455/1452] fix frame size computation --- lisp/emacs-lisp/comp.el | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3f8482b5d02..25e5be28519 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -378,6 +378,12 @@ Put PREFIX in front of it." (make-comp-nargs :min mandatory :nonrest nonrest)))) +(defun comp-byte-frame-size (byte-compiled-func) + "Given BYTE-COMPILED-FUNC return the frame size to be allocated." + ;; Is this really correct? + ;; For the 1+ see bytecode.c:365 (finger crossed). + (1+ (aref byte-compiled-func 3))) + (defun comp-spill-lap-function (function-name) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) @@ -396,7 +402,8 @@ Put PREFIX in front of it." (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) (setf (comp-func-lap func) lap) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + (setf (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func))) func))) (defun comp-spill-lap-functions-file (filename) @@ -418,7 +425,8 @@ Put PREFIX in front of it." "F") :args (comp-decrypt-lambda-list lambda-list) :lap lap - :frame-size (aref bytecode 3)) + :frame-size (comp-byte-frame-size + bytecode)) do (when (> comp-verbose 1) (comp-log (format "Function %s:\n" name)) (comp-log lap)) From f8a454f3efa10d59b8228b5c1373bfc9fb8ed718 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 15:05:07 +0200 Subject: [PATCH 0456/1452] clean-up commented code --- lisp/emacs-lisp/comp.el | 7 ------- 1 file changed, 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 25e5be28519..2822760c895 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -494,13 +494,6 @@ Restore the original value afterwards." (setf (comp-block-sp bb) sp)) (puthash name (apply #'make--comp-block args) blocks)))) -;; (defun comp-opt-call (inst) -;; "Optimize if possible a side-effect-free call in INST." -;; (cl-destructuring-bind (_ f &rest args) inst -;; (when (and (member f comp-mostly-pure-funcs) -;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) -;; (apply f (mapcar #'comp-mvar-constant args))))) - (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." (comp-add-subr-to-relocs func) From 4cc1374786dcc28b80da546e708f7360f102abd4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 16:05:37 +0200 Subject: [PATCH 0457/1452] add comp-test-silly-frame2 to test funcs --- test/src/comp-test-funcs.el | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 3d8d3437bda..540170ea966 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -340,8 +340,8 @@ ;; Non tested functions that proved just to be difficult to compile. -(defun comp-test-callee (_ _) t) -(defun comp-test-silly-frame (x) +(defun comp-test-callee (_ __) t) +(defun comp-test-silly-frame1 (x) (cl-case x (0 (comp-test-callee (pcase comp-tests-var1 @@ -349,4 +349,10 @@ (2 2)) 3)))) +(defun comp-test-silly-frame2 (token) + (while c + (cl-case c + (?< 1) + (?> 2)))) + ;;; comp-test-funcs.el ends here From 4a526ab48d10a26c9f58bde504023dd83017b088 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 16:20:57 +0200 Subject: [PATCH 0458/1452] remove nasty nested macro usage in limplify pass --- lisp/emacs-lisp/comp.el | 123 ++++++++++++++++++++-------------------- 1 file changed, 63 insertions(+), 60 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2822760c895..a026ba9b2bf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -533,31 +533,6 @@ If the callee function is known to have a return type propagate it." (cl-assert call) (comp-emit (list 'set (comp-slot) call))) -(defmacro comp-emit-set-call-subr (subr-name sp-delta) - "Emit a call for SUBR-NAME. -SP-DELTA is the stack adjustment." - (let ((subr (symbol-function subr-name)) - (subr-str (symbol-name subr-name)) - (nargs (1+ (- sp-delta)))) - (cl-assert (subrp subr) nil - "%s not a subr" subr-str) - (let* ((arity (subr-arity subr)) - (minarg (car arity)) - (maxarg (cdr arity))) - (cl-assert (not (eq maxarg 'unevalled)) nil - "%s contains unevalled arg" subr-name) - (if (eq maxarg 'many) - ;; callref case. - `(comp-emit-set-call (comp-callref ',subr-name ,nargs (comp-sp))) - ;; Normal call. - (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) - (nargs maxarg minarg) - "Incoherent stack adjustment %d, maxarg %d minarg %d") - `(let* ((subr-name ',subr-name) - (slots (cl-loop for i from 0 below ,maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) - (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. If DST-N is specified use it otherwise assume it to be the current slot." @@ -679,47 +654,75 @@ If NEGATED non nil negate the tested condition." do (comp-emit-cond-jump var m-test 0 target-label nil))) (_ (error "Missing previous setimm while creating a switch")))) +(defun comp-emit-set-call-subr (subr-name sp-delta) + "Emit a call for SUBR-NAME. +SP-DELTA is the stack adjustment." + (let ((subr (symbol-function subr-name)) + (subr-str (symbol-name subr-name)) + (nargs (1+ (- sp-delta)))) + (cl-assert (subrp subr) nil + "%s not a subr" subr-str) + (let* ((arity (subr-arity subr)) + (minarg (car arity)) + (maxarg (cdr arity))) + (cl-assert (not (eq maxarg 'unevalled)) nil + "%s contains unevalled arg" subr-name) + (if (eq maxarg 'many) + ;; callref case. + (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + ;; Normal call. + (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) + (nargs maxarg minarg) + "Incoherent stack adjustment %d, maxarg %d minarg %d") + (let* ((subr-name subr-name) + (slots (cl-loop for i from 0 below maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) + +(eval-when-compile + (defun comp-op-to-fun (x) + "Given the LAP op strip \"byte-\" to have the subr name." + (intern (replace-regexp-in-string "byte-" "" x))) + + (defun comp-body-eff (body op-name sp-delta) + "Given the original body BODY compute the effective one. +When BODY is auto guess function name form the LAP bytecode +name. Othewise expect lname fnname." + (pcase (car body) + ('auto + (list `(comp-emit-set-call-subr + ',(comp-op-to-fun op-name) + ,sp-delta))) + ((pred symbolp) + (list `(comp-emit-set-call-subr + ',(car body) + ,sp-delta))) + (_ body)))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) (indent defun)) - (cl-labels ((op-to-fun (x) - ;; Given the LAP op strip "byte-" to have the subr name. - (intern (replace-regexp-in-string "byte-" "" x))) - (body-eff (body op-name sp-delta) - ;; Given the original body BODY compute the effective one. - ;; When BODY is auto guess function name form the LAP bytecode - ;; name. Othewise expect lname fnname. - (pcase (car body) - ('auto - (list `(comp-emit-set-call-subr - ,(op-to-fun op-name) - ,sp-delta))) - ((pred symbolp) - (list `(comp-emit-set-call-subr - ,(car body) - ,sp-delta))) - (_ body)))) - `(pcase op - ,@(cl-loop for (op . body) in cases - for sp-delta = (gethash op comp-op-stack-info) - for op-name = (symbol-name op) - if body - collect `(',op - ;; Log all LAP ops except the TAG one. - ,(unless (eq op 'TAG) - `(comp-emit-annotation - ,(concat "LAP op " op-name))) - ;; Emit the stack adjustment if present. - ,(when (and sp-delta (not (eq 0 sp-delta))) - `(comp-stack-adjust ,sp-delta)) - ,@(body-eff body op-name sp-delta)) - else - collect `(',op (error ,(concat "Unsupported LAP op " - op-name)))) - (_ (error "Unexpected LAP op %s" (symbol-name op)))))) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + if body + collect `(',op + ;; Log all LAP ops except the TAG one. + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ;; Emit the stack adjustment if present. + ,(when (and sp-delta (not (eq 0 sp-delta))) + `(comp-stack-adjust ,sp-delta)) + ,@(comp-body-eff body op-name sp-delta)) + else + collect `(',op (error ,(concat "Unsupported LAP op " + op-name)))) + (_ (error "Unexpected LAP op %s" (symbol-name op))))) (defun comp-limplify-lap-inst (insn) "Limplify LAP instruction INSN pushng it in the proper basic block." From 4a00e47d4d75528ec69291c03615bd669c58ed7e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 16:26:52 +0200 Subject: [PATCH 0459/1452] fix comp.el compilation warning --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a026ba9b2bf..349db109918 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1450,7 +1450,7 @@ This can run just once." (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call (comp-mvar-constant f) rest self))) - (setcar insn-cell ,new-form))))))) + (setcar insn-cell new-form))))))) (defun comp-call-optim (_) "Given FUNCS try to avoid funcall trampoline usage when possible." From f69a2b851d80602a158f8878811a63b219eb7fc4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 17:08:48 +0200 Subject: [PATCH 0460/1452] remove unnecessary macros into limplify pass --- lisp/emacs-lisp/comp.el | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 349db109918..e706756d8c4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -29,6 +29,7 @@ ;;; Code: (require 'bytecomp) +(require 'gv) (require 'cl-lib) (require 'cl-extra) (require 'subr-x) @@ -447,9 +448,20 @@ If INPUT is a string this is the file path to be compiled." ;;; Limplification pass specific code. -(defmacro comp-sp () +(cl-defstruct (comp-limplify (:copier nil)) + "Support structure used during function limplification." + (sp 0 :type fixnum + :documentation "Current stack pointer while walking LAP.") + (frame nil :type vector + :documentation "Meta-stack used to flat LAP.") + (block-name nil :type symbol + :documentation "Current basic block name.")) + +(defsubst comp-sp () "Current stack pointer." - '(comp-limplify-sp comp-pass)) + (comp-limplify-sp comp-pass)) +(gv-define-setter comp-sp (value) + `(setf (comp-limplify-sp comp-pass) ,value)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. @@ -462,27 +474,17 @@ Restore the original value afterwards." (progn ,@body) (setf (comp-sp) ,sym)))) -(defmacro comp-slot-n (n) +(defsubst comp-slot-n (n) "Slot N into the meta-stack." - (declare (debug (form))) - `(aref (comp-limplify-frame comp-pass) ,n)) + (aref (comp-limplify-frame comp-pass) n)) -(defmacro comp-slot () +(defsubst comp-slot () "Current slot into the meta-stack pointed by sp." - '(comp-slot-n (comp-sp))) + (comp-slot-n (comp-sp))) -(defmacro comp-slot+1 () +(defsubst comp-slot+1 () "Slot into the meta-stack pointed by sp + 1." - '(comp-slot-n (1+ (comp-sp)))) - -(cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during function limplification." - (sp 0 :type fixnum - :documentation "Current stack pointer while walking LAP.") - (frame nil :type vector - :documentation "Meta-stack used to flat LAP.") - (block-name nil :type symbol - :documentation "Current basic block name.")) + (comp-slot-n (1+ (comp-sp)))) (cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) From 01334409d6b03ef101bfd5cc8f5589220fa16483 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Oct 2019 17:51:49 +0200 Subject: [PATCH 0461/1452] doc fix --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e706756d8c4..b9203ca7806 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -962,7 +962,7 @@ the annotation emission." (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. -This will be called at runtime." +This will be called at load-time." (let* ((func (make-comp-func :symbol-name 'top-level-run :c-func-name "top_level_run" :args (make-comp-args :min 0 :max 0) From 6bbbf3fd829f5000acb63536b5019b5be62d3e66 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Oct 2019 10:36:22 +0200 Subject: [PATCH 0462/1452] reworking limplify --- lisp/emacs-lisp/comp.el | 185 +++++++++++++++++++++++----------------- 1 file changed, 105 insertions(+), 80 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b9203ca7806..491a0bfc25f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -160,11 +160,11 @@ To be used when ncall-conv is nil.")) "A basic block." (name nil :type symbol) ;; These two slots are used during limplification. - (sp nil + (sp nil :type number :documentation "When non nil indicates the sp value while entering into it.") - (closed nil :type boolean - :documentation "If the block was already closed.") + (addr nil :type number + :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") ;; All the followings are for SSA and CGF analysis. @@ -228,7 +228,6 @@ structure.") (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." - ;; (setf (block-cnt-gen func) (comp-gen-counter)) (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) @@ -251,7 +250,6 @@ structure.") (defvar comp-ctxt) ;; FIXME (to be removed) ;; Special vars used by some passes -(defvar comp-block) ; Can probably be removed (defvar comp-func) @@ -450,12 +448,26 @@ If INPUT is a string this is the file path to be compiled." (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during function limplification." - (sp 0 :type fixnum - :documentation "Current stack pointer while walking LAP.") (frame nil :type vector :documentation "Meta-stack used to flat LAP.") - (block-name nil :type symbol - :documentation "Current basic block name.")) + (curr-block nil :type comp-block + :documentation "Current block baing limplified.") + (sp 0 :type number + :documentation "Current stack pointer while walking LAP.") + (pc 0 :type number + :documentation "Current program counter while walking LAP.") + (pending-blocks () :type list + :documentation "List of blocks waiting for limplification.")) + +(defconst comp-lap-eob-ops + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop byte-return) + "LAP end of basic blocks op codes.") + +(defsubst comp-lap-eob-p (inst) + "Return t if INST closes the current basic blocks, nil otherwise." + (when (member (car inst) comp-lap-eob-ops) + t)) (defsubst comp-sp () "Current stack pointer." @@ -489,13 +501,23 @@ Restore the original value afterwards." (cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) (if-let ((bb (gethash name blocks))) - (if-let ((bb-sp (comp-block-sp bb))) - ;; If was a sp was already registered sanity check it. - (cl-assert (or (null sp) (= sp bb-sp))) - ;; Otherwise set it. - (setf (comp-block-sp bb) sp)) + ;; Sanity check sp. + (cl-assert (or (null sp) (= sp (comp-block-sp bb)))) (puthash name (apply #'make--comp-block args) blocks)))) +(cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) + "Create a basic block and mark it as pending." + (if-let ((bb (gethash name (comp-func-blocks comp-func)))) + ;; If was already limplified sanity check sp. + (cl-assert (or (null sp) (= sp (comp-block-sp bb))) + (sp (comp-block-sp bb)) "sp %d %d differs") + ;; Mark it pending in case is not already. + (unless (cl-find-if (lambda (bb) + (eq (comp-block-name bb) name)) + (comp-limplify-pending-blocks comp-pass)) + (push (apply #'make--comp-block args) + (comp-limplify-pending-blocks comp-pass))))) + (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." (comp-add-subr-to-relocs func) @@ -524,10 +546,9 @@ Restore the original value afterwards." do (aset v i mvar) finally (return v))) -(defun comp-emit (insn) +(defsubst comp-emit (insn) "Emit INSN into current basic block." - (cl-assert (not (comp-block-closed comp-block))) - (push insn (comp-block-insns comp-block))) + (push insn (comp-block-insns (comp-limplify-curr-block comp-pass)))) (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. @@ -553,53 +574,41 @@ If DST-N is specified use it otherwise assume it to be the current slot." (cl-assert (numberp rel-idx)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) -(defun comp-mark-block-closed () - "Mark current basic block as closed." - (setf (comp-block-closed (gethash (comp-limplify-block-name comp-pass) - (comp-func-blocks comp-func))) - t)) +(defun comp-make-curr-block (block-name entry-sp) + "Create a basic block with BLOCK-NAME and set it as current block. +ENTRY-SP is the sp value when entering. +The block is added to the current function. +The block is returned." + (let ((bb (make--comp-block :name block-name :sp entry-sp))) + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + bb)) -(defun comp-emit-jump (target) - "Emit an unconditional branch to block TARGET." - (comp-emit (list 'jump target)) - (comp-mark-block-closed)) - -(defun comp-emit-block (block-name &optional entry-sp) - "Emit basic block BLOCK-NAME. -ENTRY-SP is the sp value when entering." - (let ((blocks (comp-func-blocks comp-func))) - ;; In case does not exist register it into comp-func-blocks. - (comp-block-maybe-add :name block-name - :sp entry-sp) - ;; If we are abandoning an non closed basic block close it with a fall - ;; through. - (when (and (not (eq block-name 'entry)) - (not (comp-block-closed - (gethash (comp-limplify-block-name comp-pass) - blocks)))) - (comp-emit-jump block-name)) - ;; Set this a currently compiled block. - (setf comp-block (gethash block-name blocks)) - ;; If we are landing here from a previously recorded branch with known sp - ;; adjust accordingly. - (when-let ((new-sp (comp-block-sp (gethash block-name blocks)))) - (setf (comp-sp) new-sp)) - (setf (comp-limplify-block-name comp-pass) block-name))) +(defun comp-emit-uncond-jump (lap-label) + "Emit an unconditional branch to LAP-LABEL." + (let ((target (comp-lap-to-limple-bb lap-label))) + (comp-block-maybe-mark-pending :name target + :sp (comp-sp) + :addr lap-label) + (comp-emit `(jump ,target)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non nil negate the tested condition." - (let ((bb (comp-new-block-sym))) ;; Fall through block - (comp-block-maybe-add :name bb :sp (comp-sp)) - (let ((target (comp-lap-to-limple-bb lap-label))) - (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))) - (comp-block-maybe-add :name target :sp (+ target-offset (comp-sp))) - (comp-mark-block-closed)) - (comp-emit-block bb (comp-sp)))) + (let ((bb (comp-new-block-sym)) ; Fall through block. + (target (comp-lap-to-limple-bb lap-label))) + (comp-block-maybe-mark-pending :name bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name target + :sp (+ target-offset (comp-sp)) + :addr lap-label) + (comp-emit (if negated + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target))))) (defun comp-stack-adjust (n) "Move sp by N." @@ -642,9 +651,7 @@ If NEGATED non nil negate the tested condition." handler-type handler-bb guarded-bb)) - (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) - (comp-mark-block-closed) - (comp-emit-block guarded-bb (comp-sp))))) + (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp)))))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -734,7 +741,7 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - (comp-emit-block (comp-lap-to-limple-bb arg))) + (comp-lap-to-limple-bb arg)) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref @@ -847,9 +854,10 @@ the annotation emission." (byte-widen (comp-emit-set-call (comp-call 'widen))) (byte-end-of-line auto) - (byte-constant2) ;; TODO + (byte-constant2) ; TODO + ;; Branches. (byte-goto - (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) + (comp-emit-uncond-jump (cl-third insn))) (byte-goto-if-nil (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (cl-third insn) nil)) @@ -863,8 +871,7 @@ the annotation emission." (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (cl-third insn) t)) (byte-return - (comp-emit `(return ,(comp-slot+1))) - (comp-mark-block-closed)) + (comp-emit `(return ,(comp-slot+1)))) (byte-discard 'pass) (byte-dup (comp-copy-slot (1- (comp-sp)))) @@ -920,7 +927,9 @@ the annotation emission." (byte-switch ;; Assume to follow the emission of a setimm. ;; This is checked into comp-emit-switch. - (comp-emit-switch (comp-slot+1) (cl-second (comp-block-insns comp-block)))) + (comp-emit-switch (comp-slot+1) + (cl-second (comp-block-insns + (comp-limplify-curr-block comp-pass))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos @@ -938,17 +947,16 @@ the annotation emission." for fallback = (intern (format "entry_fallback_%s" i)) do (progn (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) - (comp-mark-block-closed) - (comp-emit-block bb (comp-sp)) + (comp-make-curr-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args))) - finally (comp-emit-jump 'entry_rest_args)) + finally (comp-emit '(jump entry_rest_args))) (cl-loop for i from minarg below nonrest do (comp-with-sp i - (comp-emit-block (intern (format "entry_fallback_%s" i)) - (comp-sp)) + (comp-make-curr-block (intern (format "entry_fallback_%s" i)) + (comp-sp)) (comp-emit-set-const nil))) - (comp-emit-block 'entry_rest_args (comp-sp)) + (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (defun comp-limplify-finalize-function (func) @@ -969,16 +977,29 @@ This will be called at load-time." :frame-size 0)) (comp-func func) (comp-pass (make-comp-limplify + :curr-block (make--comp-block) :sp -1 - :frame (comp-new-frame 0))) - (comp-block ())) - (comp-emit-block 'entry (comp-sp)) + :frame (comp-new-frame 0)))) + (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) (comp-emit `(return ,(make-comp-mvar :constant nil))) (comp-limplify-finalize-function func))) +(defun comp-limplify-block (bb) + "Limplify basic-block BB and add it to the current function." + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (cl-loop for inst in (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + do (progn + (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass))) + until (comp-lap-eob-p inst)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))) + (defun comp-limplify-function (func) "Limplify a single function FUNC." (let* ((frame-size (comp-func-frame-size func)) @@ -987,10 +1008,9 @@ This will be called at load-time." :sp -1 :frame (comp-new-frame frame-size))) (args (comp-func-args func)) - (args-min (comp-args-base-min args)) - (comp-block ())) + (args-min (comp-args-base-min args))) ;; Prologue - (comp-emit-block 'entry (comp-sp)) + (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (if (comp-args-p args) @@ -1000,9 +1020,14 @@ This will be called at load-time." (let ((nonrest (comp-nargs-nonrest args))) (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) + (comp-emit '(jump bb_0)) ;; Body - (comp-emit-block (comp-new-block-sym) (comp-sp)) - (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + (comp-block-maybe-mark-pending :name (comp-new-block-sym) + :sp (comp-sp) + :addr 0) + (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) + while next-bb + do (comp-limplify-block next-bb)) (comp-limplify-finalize-function func))) (defun comp-add-func-to-ctxt (func) From cae7d6cd58868916bcec34d9572736e7541b9710 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Oct 2019 17:41:26 +0200 Subject: [PATCH 0463/1452] fix label to addr computation --- lisp/emacs-lisp/comp.el | 69 +++++++++++++++++++++++------------------ 1 file changed, 38 insertions(+), 31 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 491a0bfc25f..06bbc40012b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -102,15 +102,6 @@ Can be used by code that wants to expand differently in this case.") direct-callref) "Limple operators use to call subrs.") -(defconst comp-mostly-pure-funcs - '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior - lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax - symbol-name) - "Functions on witch we do constant propagation." - ;; Is it acceptable to move into the compile time functions that are - ;; allocating memory? (these are technically not side effect free) -) - (eval-when-compile (defconst comp-op-stack-info (cl-loop with h = (make-hash-table) @@ -123,7 +114,7 @@ Can be used by code that wants to expand differently in this case.") (cl-defstruct comp-ctxt "Lisp side of the compiler context." - (output nil :type 'string + (output nil :type string :documentation "Target output filename for the compilation.") (top-level-defvars nil :type list :documentation "List of top level form to be exp.") @@ -456,12 +447,16 @@ If INPUT is a string this is the file path to be compiled." :documentation "Current stack pointer while walking LAP.") (pc 0 :type number :documentation "Current program counter while walking LAP.") + (label-to-addr nil :type hash-table + :documentation "LAP hash table -> address.") (pending-blocks () :type list :documentation "List of blocks waiting for limplification.")) (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop byte-return) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-pophandler ; ?? + ) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -498,13 +493,6 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." (comp-slot-n (1+ (comp-sp)))) -(cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) - (let ((blocks (comp-func-blocks comp-func))) - (if-let ((bb (gethash name blocks))) - ;; Sanity check sp. - (cl-assert (or (null sp) (= sp (comp-block-sp bb)))) - (puthash name (apply #'make--comp-block args) blocks)))) - (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) "Create a basic block and mark it as pending." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) @@ -590,7 +578,7 @@ The block is returned." (let ((target (comp-lap-to-limple-bb lap-label))) (comp-block-maybe-mark-pending :name target :sp (comp-sp) - :addr lap-label) + :addr (comp-label-to-addr lap-label)) (comp-emit `(jump ,target)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -605,7 +593,7 @@ If NEGATED non nil negate the tested condition." :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name target :sp (+ target-offset (comp-sp)) - :addr lap-label) + :addr (comp-label-to-addr lap-label)) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))))) @@ -640,18 +628,36 @@ If NEGATED non nil negate the tested condition." (puthash n name hash) name)))) +(defun comp-fill-label-h () + "Fill label-to-addr hash table for the current function." + (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) + (cl-loop for insn in (comp-func-lap comp-func) + for addr from 0 + do (pcase insn + (`(TAG ,label) + (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) + +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (and (gethash label (comp-limplify-label-to-addr comp-pass)) + (error "Can't find label %d" label))) + (defun comp-emit-handler (guarded-label handler-type) - "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." - (let ((guarded-bb (comp-new-block-sym))) - (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) - (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) - handler-type - handler-bb - guarded-bb)) - (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp)))))) + "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." + (let ((guarded-bb (comp-new-block-sym)) + (handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-block-maybe-mark-pending :name guarded-bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name handler-bb + :sp (1+ (comp-sp)) + :addr (comp-label-to-addr guarded-label)) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) + handler-type + handler-bb + guarded-bb)))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -1009,6 +1015,7 @@ This will be called at load-time." :frame (comp-new-frame frame-size))) (args (comp-func-args func)) (args-min (comp-args-base-min args))) + (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " From ca907fe89b16d59b067669f1c43af3eace1509ea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Oct 2019 18:58:46 +0200 Subject: [PATCH 0464/1452] fix missing fall through handling --- lisp/emacs-lisp/comp.el | 52 +++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 06bbc40012b..b2eee68b3ff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -454,9 +454,7 @@ If INPUT is a string this is the file path to be compiled." (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop byte-return byte-pushcatch - byte-pophandler ; ?? - ) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -493,6 +491,11 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." (comp-slot-n (1+ (comp-sp)))) +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (or (gethash label (comp-limplify-label-to-addr comp-pass)) + (error "Can't find label %d" label))) + (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) "Create a basic block and mark it as pending." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) @@ -634,14 +637,9 @@ If NEGATED non nil negate the tested condition." (cl-loop for insn in (comp-func-lap comp-func) for addr from 0 do (pcase insn - (`(TAG ,label) + (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) -(defsubst comp-label-to-addr (label) - "Find the address of LABEL." - (and (gethash label (comp-limplify-label-to-addr comp-pass)) - (error "Can't find label %d" label))) - (defun comp-emit-handler (guarded-label handler-type) "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." (let ((guarded-bb (comp-new-block-sym)) @@ -993,17 +991,41 @@ This will be called at load-time." (comp-emit `(return ,(make-comp-mvar :constant nil))) (comp-limplify-finalize-function func))) +(defun comp-addr-to-bb-name (addr) + "Search for a block starting at ADDR into pending or limplified blocks." + ;; FIXME: Actually we could have another hash for this. + (cl-flet ((pred (bb) + (equal (comp-block-addr bb) addr))) + (if-let ((pending (cl-find-if #'pred + (comp-limplify-pending-blocks comp-pass)))) + (comp-block-name pending) + (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) + when (pred bb) + do (return (comp-block-name bb)))))) + (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb) (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) - (cl-loop for inst in (nthcdr (comp-limplify-pc comp-pass) - (comp-func-lap comp-func)) - do (progn - (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass))) - until (comp-lap-eob-p inst)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + do (progn + (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass))) + when (eq (car next-inst) 'TAG) + do ; That's a fall through. + (let ((bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) + (comp-new-block-sym)))) + (comp-block-maybe-mark-pending :name bb + :sp (comp-sp) + :addr (comp-limplify-pc comp-pass)) + (comp-emit `(jump ,bb))) + and return nil + until (comp-lap-eob-p inst)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))) (defun comp-limplify-function (func) From a90803a4d1bc47fcfc3b9a3af519cd8441bd92de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Oct 2019 20:22:14 +0200 Subject: [PATCH 0465/1452] add stack sanity check --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b2eee68b3ff..adda0537a6e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -745,7 +745,8 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - (comp-lap-to-limple-bb arg)) + ;; Paranoically sanity check stack depth. + (cl-assert (= (cddr insn) (comp-limplify-sp comp-pass)))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref From c6d819ecb5dafddb7b4dffa4c84f5264a3061d53 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Oct 2019 20:22:37 +0200 Subject: [PATCH 0466/1452] fix initial stack depth --- lisp/emacs-lisp/comp.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index adda0537a6e..fd37d1645a2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -983,7 +983,6 @@ This will be called at load-time." (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block) - :sp -1 :frame (comp-new-frame 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") @@ -1034,7 +1033,6 @@ This will be called at load-time." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :sp -1 :frame (comp-new-frame frame-size))) (args (comp-func-args func)) (args-min (comp-args-base-min args))) From 26db0a032640a107bb0155b2f1eb7a586dbd8985 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Oct 2019 20:45:14 +0200 Subject: [PATCH 0467/1452] make stack depth computation robust in limplify --- lisp/emacs-lisp/comp.el | 88 ++++++++++++++++++++++------------------- 1 file changed, 47 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fd37d1645a2..8baad18e97b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -578,28 +578,51 @@ The block is returned." (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." - (let ((target (comp-lap-to-limple-bb lap-label))) - (comp-block-maybe-mark-pending :name target - :sp (comp-sp) - :addr (comp-label-to-addr lap-label)) - (comp-emit `(jump ,target)))) + (cl-destructuring-bind (label-num . stack-depth) lap-label + (cl-assert (= stack-depth (comp-sp))) + (let ((target (comp-lap-to-limple-bb label-num))) + (comp-block-maybe-mark-pending :name target + :sp stack-depth + :addr (comp-label-to-addr label-num)) + (comp-emit `(jump ,target))))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non nil negate the tested condition." - (let ((bb (comp-new-block-sym)) ; Fall through block. - (target (comp-lap-to-limple-bb lap-label))) - (comp-block-maybe-mark-pending :name bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name target - :sp (+ target-offset (comp-sp)) - :addr (comp-label-to-addr lap-label)) - (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))))) +If NEGATED non null negate the tested condition." + (cl-destructuring-bind (label-num . stack-depth) lap-label + (cl-assert (= stack-depth (+ target-offset (comp-sp)))) + (let ((bb (comp-new-block-sym)) ; Fall through block. + (target (comp-lap-to-limple-bb label-num))) + (comp-block-maybe-mark-pending :name bb + :sp stack-depth + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name target + :sp (+ target-offset stack-depth) + :addr (comp-label-to-addr label-num)) + (comp-emit (if negated + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target)))))) + +(defun comp-emit-handler (lap-label handler-type) + "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." + (cl-destructuring-bind (label-num . stack-depth) lap-label + (cl-assert (= stack-depth (comp-sp))) + (let ((guarded-bb (comp-new-block-sym)) + (handler-bb (comp-lap-to-limple-bb label-num))) + (comp-block-maybe-mark-pending :name guarded-bb + :sp stack-depth + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name handler-bb + :sp (1+ stack-depth) + :addr (comp-label-to-addr label-num)) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) + handler-type + handler-bb + guarded-bb))))) (defun comp-stack-adjust (n) "Move sp by N." @@ -640,23 +663,6 @@ If NEGATED non nil negate the tested condition." (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) -(defun comp-emit-handler (guarded-label handler-type) - "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." - (let ((guarded-bb (comp-new-block-sym)) - (handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-block-maybe-mark-pending :name guarded-bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name handler-bb - :sp (1+ (comp-sp)) - :addr (comp-label-to-addr guarded-label)) - (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) - handler-type - handler-bb - guarded-bb)))) - (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." (pcase last-insn @@ -769,9 +775,9 @@ the annotation emission." (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase - (comp-emit-handler (cl-third insn) 'condition-case)) + (comp-emit-handler (cddr insn) 'condition-case)) (byte-pushcatch - (comp-emit-handler (cl-third insn) 'catcher)) + (comp-emit-handler (cddr insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -862,19 +868,19 @@ the annotation emission." (byte-constant2) ; TODO ;; Branches. (byte-goto - (comp-emit-uncond-jump (cl-third insn))) + (comp-emit-uncond-jump (cddr insn))) (byte-goto-if-nil (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 - (cl-third insn) nil)) + (cddr insn) nil)) (byte-goto-if-not-nil (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 - (cl-third insn) t)) + (cddr insn) t)) (byte-goto-if-nil-else-pop (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 - (cl-third insn) nil)) + (cddr insn) nil)) (byte-goto-if-not-nil-else-pop (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 - (cl-third insn) t)) + (cddr insn) t)) (byte-return (comp-emit `(return ,(comp-slot+1)))) (byte-discard 'pass) From 3b58bac273b517844210c9ecd07757625dc9804d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Oct 2019 22:08:24 +0200 Subject: [PATCH 0468/1452] mega loop refactor --- lisp/emacs-lisp/comp.el | 63 ++++++++++++++++++----------------------- 1 file changed, 28 insertions(+), 35 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8baad18e97b..1d14289b467 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -314,9 +314,8 @@ BODY is evaluate only if `comp-verbose' is > 0." (comp-log (format "\nFunction: %s" (comp-func-symbol-name func))) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) - do (progn - (comp-log (concat "<" (symbol-name block-name) ">\n")) - (comp-log (comp-block-insns bb))))) + do (comp-log (concat "<" (symbol-name block-name) ">\n")) + (comp-log (comp-block-insns bb)))) (defun comp-log-edges (func) "Log edges in FUNC." @@ -346,7 +345,7 @@ Put PREFIX in front of it." for i across orig-name for byte = (format "%x" i) do (aset str j (aref byte 0)) - do (aset str (1+ j) (aref byte 1)) + (aset str (1+ j) (aref byte 1)) finally return str)) (human-readable (replace-regexp-in-string "-" "_" orig-name)) @@ -950,17 +949,15 @@ the annotation emission." (defun comp-emit-narg-prologue (minarg nonrest) "Emit the prologue for a narg function." (cl-loop for i below minarg - do (progn - (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args)))) + do (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) - do (progn - (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) - (comp-make-curr-block bb (comp-sp)) - (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args))) + do (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + (comp-make-curr-block bb (comp-sp)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args)) finally (comp-emit '(jump entry_rest_args))) (cl-loop for i from minarg below nonrest do (comp-with-sp i @@ -1019,9 +1016,8 @@ This will be called at load-time." (comp-func-lap comp-func)) for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) - do (progn - (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass))) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) when (eq (car next-inst) 'TAG) do ; That's a fall through. (let ((bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) @@ -1050,7 +1046,7 @@ This will be called at load-time." (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) - do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) (let ((nonrest (comp-nargs-nonrest args))) (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) @@ -1128,7 +1124,7 @@ Top level forms for the current context are rendered too." (cl-loop for edge in (comp-func-edges comp-func) do (push edge (comp-block-out-edges (comp-edge-src edge))) - do (push edge + (push edge (comp-block-in-edges (comp-edge-dst edge)))) (comp-log-edges comp-func))))) @@ -1193,9 +1189,8 @@ Top level forms for the current context are rendered too." when (comp-block-dom p) do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) - do (progn - (setf (comp-block-dom b) new-idom) - (setf changed t))))))) + do (setf (comp-block-dom b) new-idom) + (setf changed t)))))) (defun comp-compute-dominator-frontiers () ;; Originally based on: "A Simple, Fast Dominance Algorithm" @@ -1236,7 +1231,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - do (cl-return t)))) + return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i @@ -1253,13 +1248,12 @@ Top level forms for the current context are rendered too." (let ((x (pop w))) (cl-loop for y being each hash-value of (comp-block-df x) unless (cl-find y f) - do (progn - (add-phi i y) - (push y f) - ;; Adding a phi implies mentioning the - ;; corresponding slot so in case adjust w. - (unless (cl-find y defs-v) - (push y w))))))))) + do (add-phi i y) + (push y f) + ;; Adding a phi implies mentioning the + ;; corresponding slot so in case adjust w. + (unless (cl-find y defs-v) + (push y w)))))))) (defun comp-dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. @@ -1551,8 +1545,7 @@ This can run just once." for (op arg0 . rest) = insn if (comp-set-op-p op) do (push (comp-mvar-id arg0) l-vals) - and - do (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) else do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) ;; Every l-value appearing that does not appear as r-value has no right to @@ -1571,11 +1564,11 @@ This can run just once." for (op arg0 rest) = insn when (and (comp-set-op-p op) (member (comp-mvar-id arg0) nuke-list)) - do (setcar insn-cell - (if (comp-limple-insn-call-p rest) - rest - `(comment ,(format "optimized out: %s" - insn))))))))) + do (setcar insn-cell + (if (comp-limple-insn-call-p rest) + rest + `(comment ,(format "optimized out: %s" + insn))))))))) (defun comp-remove-type-hints-func () "Remove type hints from the current function. From 1a4aa391eea22fc053aa40c1827c7726de5fa7ac Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Oct 2019 11:20:15 +0200 Subject: [PATCH 0469/1452] reworking comp-limplify-block --- lisp/emacs-lisp/comp.el | 67 ++++++++++++++++++++++++----------------- 1 file changed, 40 insertions(+), 27 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1d14289b467..8782fd9facb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -461,6 +461,12 @@ If INPUT is a string this is the file path to be compiled." (when (member (car inst) comp-lap-eob-ops) t)) +(defsubst comp-lap-fall-through-p (inst) + "Return t if INST fall through. +nil otherwise." + (when (not (member (car inst) '(byte-goto byte-return))) + t)) + (defsubst comp-sp () "Current stack pointer." (comp-limplify-sp comp-pass)) @@ -498,7 +504,7 @@ Restore the original value afterwards." (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) "Create a basic block and mark it as pending." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) - ;; If was already limplified sanity check sp. + ;; If was already declared sanity check sp. (cl-assert (or (null sp) (= sp (comp-block-sp bb))) (sp (comp-block-sp bb)) "sp %d %d differs") ;; Mark it pending in case is not already. @@ -590,15 +596,15 @@ The block is returned." TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non null negate the tested condition." - (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= stack-depth (+ target-offset (comp-sp)))) + (cl-destructuring-bind (label-num . target-sp) lap-label + (cl-assert (= target-sp (+ target-offset (comp-sp)))) (let ((bb (comp-new-block-sym)) ; Fall through block. (target (comp-lap-to-limple-bb label-num))) (comp-block-maybe-mark-pending :name bb - :sp stack-depth + :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name target - :sp (+ target-offset stack-depth) + :sp target-sp :addr (comp-label-to-addr label-num)) (comp-emit (if negated (list 'cond-jump a b target bb) @@ -1008,27 +1014,34 @@ This will be called at load-time." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) - (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) - (cl-loop - for inst-cell on (nthcdr (comp-limplify-pc comp-pass) - (comp-func-lap comp-func)) - for inst = (car inst-cell) - for next-inst = (car-safe (cdr inst-cell)) - do (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass)) - when (eq (car next-inst) 'TAG) - do ; That's a fall through. - (let ((bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) - (comp-new-block-sym)))) - (comp-block-maybe-mark-pending :name bb - :sp (comp-sp) - :addr (comp-limplify-pc comp-pass)) - (comp-emit `(jump ,bb))) - and return nil - until (comp-lap-eob-p inst)) - (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))) + (cl-flet ((add-next-block (sp ff) + ;; Maybe create next block. Emit a jump to it if FF. + (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) + (comp-new-block-sym)))) + (comp-block-maybe-mark-pending :name next-bb + :sp sp + :addr (comp-limplify-pc comp-pass)) + (when ff + (comp-emit `(jump ,next-bb)))))) + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + for fall-through = (comp-lap-fall-through-p inst) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) + (pcase next-inst + (`(TAG ,_label . ,target-sp) + (when fall-through + (cl-assert (= target-sp (comp-sp)))) + (add-next-block target-sp fall-through) + (return))) + until (comp-lap-eob-p inst)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)))) (defun comp-limplify-function (func) "Limplify a single function FUNC." @@ -1231,7 +1244,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - return t))) + return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i From f0e83548ee9d08a558363f73d6ec8e6f30e1cab0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Oct 2019 16:31:02 +0200 Subject: [PATCH 0470/1452] re enable switch support --- lisp/emacs-lisp/comp.el | 112 ++++++++++++++++++++++++---------------- 1 file changed, 67 insertions(+), 45 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8782fd9facb..f99f42462ca 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -453,7 +453,8 @@ If INPUT is a string this is the file path to be compiled." (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop byte-return byte-pushcatch) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-switch) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -462,8 +463,7 @@ If INPUT is a string this is the file path to be compiled." t)) (defsubst comp-lap-fall-through-p (inst) - "Return t if INST fall through. -nil otherwise." + "Return t if INST fall through, nil otherwise." (when (not (member (car inst) '(byte-goto byte-return))) t)) @@ -570,17 +570,28 @@ If DST-N is specified use it otherwise assume it to be the current slot." (cl-assert (numberp rel-idx)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) -(defun comp-make-curr-block (block-name entry-sp) +(defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block :name block-name :sp entry-sp))) + (let ((bb (make--comp-block :name block-name :sp entry-sp :addr addr))) (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-pc comp-pass) addr) (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) +(defun comp-lap-to-limple-bb (n) + "Given the LAP label N return the limple basic block name." + (let ((hash (comp-func-lap-block comp-func))) + (if-let ((bb (gethash n hash))) + ;; If was already created return it. + bb + (let ((name (comp-new-block-sym))) + (puthash n name hash) + name)))) + (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label @@ -595,7 +606,8 @@ The block is returned." "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non null negate the tested condition." +If NEGATED non null negate the tested condition. +Return value is the fall through block name." (cl-destructuring-bind (label-num . target-sp) lap-label (cl-assert (= target-sp (+ target-offset (comp-sp)))) (let ((bb (comp-new-block-sym)) ; Fall through block. @@ -608,7 +620,8 @@ If NEGATED non null negate the tested condition." :addr (comp-label-to-addr label-num)) (comp-emit (if negated (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target)))))) + (list 'cond-jump a b bb target))) + bb))) (defun comp-emit-handler (lap-label handler-type) "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." @@ -649,16 +662,6 @@ If NEGATED non null negate the tested condition." "Return a unique symbol naming the next new basic block." (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) -(defun comp-lap-to-limple-bb (n) - "Given the LAP label N return the limple basic block name." - (let ((hash (comp-func-lap-block comp-func))) - (if-let ((bb (gethash n hash))) - ;; If was already created return it. - bb - (let ((name (comp-new-block-sym))) - (puthash n name hash) - name)))) - (defun comp-fill-label-h () "Fill label-to-addr hash table for the current function." (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) @@ -674,8 +677,24 @@ If NEGATED non null negate the tested condition." (`(setimm ,_ ,_ ,const) (cl-loop for test being each hash-keys of const using (hash-value target-label) + with len = (hash-table-count const) + for n from 1 + for last = (= n len) for m-test = (make-comp-mvar :constant test) - do (comp-emit-cond-jump var m-test 0 target-label nil))) + for ff-bb = (comp-new-block-sym) ; Fall through block. + for target = (comp-lap-to-limple-bb target-label) + do + (comp-emit (list 'cond-jump var m-test ff-bb target)) + (comp-block-maybe-mark-pending :name target + :sp (comp-sp) + :addr (comp-label-to-addr target-label)) + (if last + (comp-block-maybe-mark-pending :name ff-bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-make-curr-block ff-bb + (comp-sp) + (comp-limplify-pc comp-pass))))) (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) @@ -1012,36 +1031,39 @@ This will be called at load-time." when (pred bb) do (return (comp-block-name bb)))))) +(defun comp-add-pending-block (sp) + "Add next basic block to the pending queue. +The block name is returned." + (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) + (comp-new-block-sym)))) + (comp-block-maybe-mark-pending :name next-bb + :sp sp + :addr (comp-limplify-pc comp-pass)) + next-bb)) + (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." - (cl-flet ((add-next-block (sp ff) - ;; Maybe create next block. Emit a jump to it if FF. - (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) - (comp-new-block-sym)))) - (comp-block-maybe-mark-pending :name next-bb - :sp sp - :addr (comp-limplify-pc comp-pass)) - (when ff - (comp-emit `(jump ,next-bb)))))) - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) - (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) - (cl-loop - for inst-cell on (nthcdr (comp-limplify-pc comp-pass) - (comp-func-lap comp-func)) - for inst = (car inst-cell) - for next-inst = (car-safe (cdr inst-cell)) - for fall-through = (comp-lap-fall-through-p inst) - do (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass)) - (pcase next-inst - (`(TAG ,_label . ,target-sp) + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + for fall-through = (comp-lap-fall-through-p inst) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) + (pcase next-inst + (`(TAG ,_label . ,target-sp) + (when fall-through + (cl-assert (= target-sp (comp-sp)))) + (let ((next-bb (comp-add-pending-block target-sp))) (when fall-through - (cl-assert (= target-sp (comp-sp)))) - (add-next-block target-sp fall-through) - (return))) - until (comp-lap-eob-p inst)) - (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)))) + (comp-emit `(jump ,next-bb)))) + (return))) + until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) "Limplify a single function FUNC." From 661567b7cd8092e1b41346b77e97201ea4d2efc2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Oct 2019 18:15:00 +0200 Subject: [PATCH 0471/1452] remove comp-stack-adjust --- lisp/emacs-lisp/comp.el | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f99f42462ca..95fbe9f2de3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -642,10 +642,6 @@ Return value is the fall through block name." handler-bb guarded-bb))))) -(defun comp-stack-adjust (n) - "Move sp by N." - (cl-incf (comp-sp) n)) - (defun comp-limplify-listn (n) "Limplify list N." (comp-with-sp (+ (comp-sp) n -1) @@ -760,7 +756,7 @@ the annotation emission." ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) - `(comp-stack-adjust ,sp-delta)) + `(cl-incf (comp-sp) ,sp-delta)) ,@(comp-body-eff body op-name sp-delta)) else collect `(',op (error ,(concat "Unsupported LAP op " @@ -791,7 +787,7 @@ the annotation emission." (make-comp-mvar :constant arg) (comp-slot+1)))) (byte-call - (comp-stack-adjust (- arg)) + (cl-incf (comp-sp) (- arg)) (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) (byte-unbind (comp-emit (comp-call 'helper_unbind_n @@ -945,20 +941,20 @@ the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (comp-stack-adjust (- 1 arg)) + (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) (byte-concatN - (comp-stack-adjust (- 1 arg)) + (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) (byte-insertN - (comp-stack-adjust (- 1 arg)) + (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set (comp-with-sp (1+ (comp-sp)) ;; FIXME!! (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN - (comp-stack-adjust (- arg))) + (cl-incf (comp-sp) (- arg))) (byte-switch ;; Assume to follow the emission of a setimm. ;; This is checked into comp-emit-switch. @@ -968,7 +964,7 @@ the annotation emission." (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos - (comp-stack-adjust (- arg)) + (cl-incf (comp-sp) (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) (defun comp-emit-narg-prologue (minarg nonrest) From aadb83da748c6befaabab0583fd38bac7fb094ba Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 09:32:57 +0200 Subject: [PATCH 0472/1452] fix initial sp value --- lisp/emacs-lisp/comp.el | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 95fbe9f2de3..a01fce22d7b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -442,8 +442,9 @@ If INPUT is a string this is the file path to be compiled." :documentation "Meta-stack used to flat LAP.") (curr-block nil :type comp-block :documentation "Current block baing limplified.") - (sp 0 :type number - :documentation "Current stack pointer while walking LAP.") + (sp -1 :type number + :documentation "Current stack pointer while walking LAP. +Points to the next slot to be filled.") (pc 0 :type number :documentation "Current program counter while walking LAP.") (label-to-addr nil :type hash-table @@ -595,10 +596,10 @@ The block is returned." (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= stack-depth (comp-sp))) + (cl-assert (= (1- stack-depth) (comp-sp))) (let ((target (comp-lap-to-limple-bb label-num))) (comp-block-maybe-mark-pending :name target - :sp stack-depth + :sp (comp-sp) :addr (comp-label-to-addr label-num)) (comp-emit `(jump ,target))))) @@ -609,9 +610,10 @@ block. If NEGATED non null negate the tested condition. Return value is the fall through block name." (cl-destructuring-bind (label-num . target-sp) lap-label - (cl-assert (= target-sp (+ target-offset (comp-sp)))) - (let ((bb (comp-new-block-sym)) ; Fall through block. + (let ((target-sp (1- target-sp)) + (bb (comp-new-block-sym)) ; Fall through block. (target (comp-lap-to-limple-bb label-num))) + (cl-assert (= target-sp (+ target-offset (comp-sp)))) (comp-block-maybe-mark-pending :name bb :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) @@ -772,7 +774,7 @@ the annotation emission." (comp-op-case (TAG ;; Paranoically sanity check stack depth. - (cl-assert (= (cddr insn) (comp-limplify-sp comp-pass)))) + (cl-assert (= (1- (cddr insn)) (comp-limplify-sp comp-pass)))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref @@ -1054,8 +1056,8 @@ The block name is returned." (pcase next-inst (`(TAG ,_label . ,target-sp) (when fall-through - (cl-assert (= target-sp (comp-sp)))) - (let ((next-bb (comp-add-pending-block target-sp))) + (cl-assert (= (1- target-sp) (comp-sp)))) + (let ((next-bb (comp-add-pending-block (1- target-sp)))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) From 689bb582623450826a9e2cdcc2aa63aaa6ab5764 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 10:39:59 +0200 Subject: [PATCH 0473/1452] update emit-handler + rework comp-emit-cond-jump --- lisp/emacs-lisp/comp.el | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a01fce22d7b..a0ff1223626 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -455,7 +455,7 @@ Points to the next slot to be filled.") (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop byte-goto-if-not-nil-else-pop byte-return byte-pushcatch - byte-switch) + byte-switch byte-pushconditioncase) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -609,11 +609,11 @@ TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non null negate the tested condition. Return value is the fall through block name." - (cl-destructuring-bind (label-num . target-sp) lap-label - (let ((target-sp (1- target-sp)) - (bb (comp-new-block-sym)) ; Fall through block. - (target (comp-lap-to-limple-bb label-num))) - (cl-assert (= target-sp (+ target-offset (comp-sp)))) + (cl-destructuring-bind (label-num . label-sp) lap-label + (let ((bb (comp-new-block-sym)) ; Fall through block. + (target (comp-lap-to-limple-bb label-num)) + (target-sp (+ target-offset (comp-sp)))) + (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))) (comp-block-maybe-mark-pending :name bb :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) @@ -627,15 +627,15 @@ Return value is the fall through block name." (defun comp-emit-handler (lap-label handler-type) "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." - (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= stack-depth (comp-sp))) + (cl-destructuring-bind (label-num . label-sp) lap-label (let ((guarded-bb (comp-new-block-sym)) (handler-bb (comp-lap-to-limple-bb label-num))) + (cl-assert (= (- label-sp 2) (comp-sp))) (comp-block-maybe-mark-pending :name guarded-bb - :sp stack-depth + :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name handler-bb - :sp (1+ stack-depth) + :sp (1+ (comp-sp)) :addr (comp-label-to-addr label-num)) (comp-emit (list 'push-handler (comp-slot+1) @@ -1057,7 +1057,7 @@ The block name is returned." (`(TAG ,_label . ,target-sp) (when fall-through (cl-assert (= (1- target-sp) (comp-sp)))) - (let ((next-bb (comp-add-pending-block (1- target-sp)))) + (let ((next-bb (comp-add-pending-block (comp-sp)))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) From f24c0c7111d9a11921c057eb8d77ca4287294c0d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 10:40:28 +0200 Subject: [PATCH 0474/1452] log a page break when start compiling --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a0ff1223626..fe3c1dde93e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1690,6 +1690,7 @@ If INPUT is a string, use it as the file path to be native compiled." :output (if (symbolp input) (symbol-name input) (file-name-sans-extension (expand-file-name input)))))) + (comp-log "\n \n") (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) From 63a1f317d05c8eed256251e7952e621a37b5cf7b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 11:02:16 +0200 Subject: [PATCH 0475/1452] fix comp-limplify-block when falling through a return --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe3c1dde93e..03ace885f85 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1054,10 +1054,10 @@ The block name is returned." do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) (pcase next-inst - (`(TAG ,_label . ,target-sp) + (`(TAG ,_label . ,label-sp) (when fall-through - (cl-assert (= (1- target-sp) (comp-sp)))) - (let ((next-bb (comp-add-pending-block (comp-sp)))) + (cl-assert (= (1- label-sp) (comp-sp)))) + (let ((next-bb (comp-add-pending-block (1- label-sp)))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) From 50604ff3872a46baec8578b35db92d9892a35396 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 11:10:22 +0200 Subject: [PATCH 0476/1452] fix missing jump into comp-emit-narg-prologue --- lisp/emacs-lisp/comp.el | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 03ace885f85..4dd6cbce437 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -982,11 +982,13 @@ the annotation emission." (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) finally (comp-emit '(jump entry_rest_args))) - (cl-loop for i from minarg below nonrest - do (comp-with-sp i - (comp-make-curr-block (intern (format "entry_fallback_%s" i)) - (comp-sp)) - (comp-emit-set-const nil))) + (when (not (= minarg nonrest)) + (cl-loop for i from minarg below nonrest + do (comp-with-sp i + (comp-make-curr-block (intern (format "entry_fallback_%s" i)) + (comp-sp)) + (comp-emit-set-const nil)) + finally (comp-emit '(jump entry_rest_args)))) (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) From eab243d22203e0aa56576b00568a93f18e8196cd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 14:42:06 +0200 Subject: [PATCH 0477/1452] do not check label stack depth when this is not provided --- lisp/emacs-lisp/comp.el | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4dd6cbce437..775a0ee064b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -613,7 +613,8 @@ Return value is the fall through block name." (let ((bb (comp-new-block-sym)) ; Fall through block. (target (comp-lap-to-limple-bb label-num)) (target-sp (+ target-offset (comp-sp)))) - (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))) + (when label-sp + (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-block-maybe-mark-pending :name bb :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) @@ -773,8 +774,10 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - ;; Paranoically sanity check stack depth. - (cl-assert (= (1- (cddr insn)) (comp-limplify-sp comp-pass)))) + (cl-destructuring-bind (_TAG _label-num . label-sp) insn + ;; Paranoid? + (when label-sp + (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref @@ -1057,9 +1060,14 @@ The block name is returned." (cl-incf (comp-limplify-pc comp-pass)) (pcase next-inst (`(TAG ,_label . ,label-sp) - (when fall-through + (when (and label-sp fall-through) (cl-assert (= (1- label-sp) (comp-sp)))) - (let ((next-bb (comp-add-pending-block (1- label-sp)))) + (let* ((stack-depth (if label-sp + (1- label-sp) + (if fall-through + (comp-sp) + (error "Unknown stack depth.")))) + (next-bb (comp-add-pending-block stack-depth))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) From e4684a2f9d07ca6ad836028514dda8e3e6643bf8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 15:24:18 +0200 Subject: [PATCH 0478/1452] fix ice logging message --- src/comp.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 039daeeaadc..be966c2709a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -218,10 +218,9 @@ static void ice (const char* msg) { if (msg) - msg = format_string ("Internal native compiler error: %s", msg); + error ("Internal native compiler error: %s", msg); else - msg = "Internal native compiler error"; - error ("%s", msg); + error ("Internal native compiler error"); } static void From 922c4128034149abb130c6a9a06efa72659ffaf3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 16:04:29 +0200 Subject: [PATCH 0479/1452] fix limplification when TAG follow fall through eob --- lisp/emacs-lisp/comp.el | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 775a0ee064b..90500b9fc38 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -158,6 +158,8 @@ into it.") :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") + (closed nil :type boolean + :documentation "t if closed.") ;; All the followings are for SSA and CGF analysis. (in-edges () :type list :documentation "List of incoming edges.") @@ -545,6 +547,7 @@ Restore the original value afterwards." (defsubst comp-emit (insn) "Emit INSN into current basic block." + (cl-assert (not (comp-block-closed (comp-limplify-curr-block comp-pass)))) (push insn (comp-block-insns (comp-limplify-curr-block comp-pass)))) (defun comp-emit-set-call (call) @@ -601,7 +604,8 @@ The block is returned." (comp-block-maybe-mark-pending :name target :sp (comp-sp) :addr (comp-label-to-addr label-num)) - (comp-emit `(jump ,target))))) + (comp-emit `(jump ,target)) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. @@ -624,6 +628,7 @@ Return value is the fall through block name." (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) bb))) (defun comp-emit-handler (lap-label handler-type) @@ -643,7 +648,8 @@ Return value is the fall through block name." (comp-slot+1) handler-type handler-bb - guarded-bb))))) + guarded-bb)) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) (defun comp-limplify-listn (n) "Limplify list N." @@ -1068,7 +1074,8 @@ The block name is returned." (comp-sp) (error "Unknown stack depth.")))) (next-bb (comp-add-pending-block stack-depth))) - (when fall-through + (when (and fall-through + (not (comp-block-closed bb))) (comp-emit `(jump ,next-bb)))) (return))) until (comp-lap-eob-p inst))) From 7ba9a4c895b61d5c12118a18cb337f621bea4442 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Oct 2019 09:53:00 +0200 Subject: [PATCH 0480/1452] add autoload --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 90500b9fc38..34e0d02e3b1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1693,6 +1693,7 @@ Prepare every function for final compilation and drive the C back-end." ;;; Compiler entry points. +;;;###autoload (defun native-compile (input) "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. From 8d08a8a1070435e12b77517808df34a8093abc67 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Oct 2019 21:00:17 +0200 Subject: [PATCH 0481/1452] add fetch-handler operator --- lisp/emacs-lisp/comp.el | 50 +++++++++++-------- src/comp.c | 106 +++++++++++++++++++++++----------------- 2 files changed, 89 insertions(+), 67 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 34e0d02e3b1..9ce1e96b3c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -92,7 +92,7 @@ Can be used by code that wants to expand differently in this case.") set-rest-args-to-local) "Limple set operators.") -(defconst comp-limple-assignments `(push-handler +(defconst comp-limple-assignments `(fetch-handler ,@comp-limple-sets) "Limple operators that clobbers the first mvar argument.") @@ -217,7 +217,9 @@ structure.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.")) + :documentation "Counter to create ssa limple vars.") + (handler-cnt 0 :type number + :documentation "Number of non local handler buffers.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -505,7 +507,8 @@ Restore the original value afterwards." (error "Can't find label %d" label))) (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) - "Create a basic block and mark it as pending." + "Create a basic block and mark it as pending. +The basic block is returned." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) ;; If was already declared sanity check sp. (cl-assert (or (null sp) (= sp (comp-block-sp bb))) @@ -514,8 +517,8 @@ Restore the original value afterwards." (unless (cl-find-if (lambda (bb) (eq (comp-block-name bb) name)) (comp-limplify-pending-blocks comp-pass)) - (push (apply #'make--comp-block args) - (comp-limplify-pending-blocks comp-pass))))) + (car (push (apply #'make--comp-block args) + (comp-limplify-pending-blocks comp-pass)))))) (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." @@ -545,10 +548,11 @@ Restore the original value afterwards." do (aset v i mvar) finally (return v))) -(defsubst comp-emit (insn) - "Emit INSN into current basic block." - (cl-assert (not (comp-block-closed (comp-limplify-curr-block comp-pass)))) - (push insn (comp-block-insns (comp-limplify-curr-block comp-pass)))) +(defsubst comp-emit (insn &optional bb) + "Emit INSN in BB is specified or the current basic block otherwise." + (let ((bb (or bb (comp-limplify-curr-block comp-pass)))) + (cl-assert (not (comp-block-closed bb))) + (push insn (comp-block-insns bb)))) (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. @@ -634,22 +638,26 @@ Return value is the fall through block name." (defun comp-emit-handler (lap-label handler-type) "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label - (let ((guarded-bb (comp-new-block-sym)) - (handler-bb (comp-lap-to-limple-bb label-num))) - (cl-assert (= (- label-sp 2) (comp-sp))) - (comp-block-maybe-mark-pending :name guarded-bb + (cl-assert (= (- label-sp 2) (comp-sp))) + (let* ((guarded-name (comp-new-block-sym)) + (handler-name (comp-lap-to-limple-bb label-num)) + (handler-buff-n (comp-func-handler-cnt comp-func)) + (handler-bb (comp-block-maybe-mark-pending :name handler-name + :sp (1+ (comp-sp)) + :addr + (comp-label-to-addr label-num)))) + (comp-block-maybe-mark-pending :name guarded-name :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name handler-bb - :sp (1+ (comp-sp)) - :addr (comp-label-to-addr label-num)) (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) handler-type - handler-bb - guarded-bb)) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) + (comp-slot+1) + handler-buff-n + handler-name + guarded-name)) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) + (comp-emit `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) + (cl-incf (comp-func-handler-cnt comp-func))))) (defun comp-limplify-listn (n) "Limplify list N." diff --git a/src/comp.c b/src/comp.c index be966c2709a..6b3ca832d98 100644 --- a/src/comp.c +++ b/src/comp.c @@ -171,6 +171,7 @@ typedef struct { Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ + Lisp_Object buffer_handler_vec; /* All locals used to store non local exit values. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -280,7 +281,7 @@ retrive_block (Lisp_Object block_name) static void declare_block (Lisp_Object block_name) { - char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); + char *name_str = SSDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)), @@ -1151,23 +1152,12 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) static void emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, - gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, - Lisp_Object clobbered_mvar) + EMACS_UINT handler_buff_n, gcc_jit_block *handler_bb, + gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) { - /* - Ex: (push-handler #s(comp-mvar 1 8 nil nil nil nil) - #s(comp-mvar 1 7 t done symbol nil) - catcher bb_2 bb_1). - */ - - static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ - - /* struct handler *c = push_handler (POP, type); */ + /* struct handler *c = push_handler (POP, type); */ gcc_jit_lvalue *c = - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("c_%u", pushhandler_n)); + xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( @@ -1189,29 +1179,6 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, res = emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); emit_cond_jump (res, handler_bb, guarded_bb); - - /* This emit the handler part. */ - - comp.block = handler_bb; - gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); - gcc_jit_block_add_assignment ( - comp.block, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); - emit_frame_assignment ( - clobbered_mvar, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field))); - ++pushhandler_n; } static void @@ -1222,6 +1189,16 @@ emit_limple_insn (Lisp_Object insn) Lisp_Object arg0 UNINIT; gcc_jit_rvalue *res; + Lisp_Object arg[6]; + Lisp_Object p = XCDR (insn); + ptrdiff_t n_args = list_length (p); + unsigned i = 0; + FOR_EACH_TAIL (p) + { + eassert (i < n_args); + arg[i++] = XCAR (p); + } + if (CONSP (args)) arg0 = XCAR (args); @@ -1269,9 +1246,11 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qpush_handler)) { - gcc_jit_rvalue *handler = emit_mvar_val (arg0); + /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ + gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); int h_num UNINIT; - Lisp_Object handler_spec = THIRD (args); + Lisp_Object handler_spec = arg[0]; + EMACS_UINT handler_buff_n = XFIXNUM (arg[2]); if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; else if (EQ (handler_spec, Qcondition_case)) @@ -1282,10 +1261,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, h_num); - gcc_jit_block *handler_bb = retrive_block (FORTH (args)); - gcc_jit_block *guarded_bb = retrive_block (FIFTH (args)); - emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, - arg0); + gcc_jit_block *handler_bb = retrive_block (arg[3]); + gcc_jit_block *guarded_bb = retrive_block (arg[4]); + emit_limple_push_handler (handler, handler_type, handler_buff_n, + handler_bb, guarded_bb, arg0); } else if (EQ (op, Qpop_handler)) { @@ -1309,6 +1288,30 @@ emit_limple_insn (Lisp_Object insn) comp.handler_next_field))); } + else if (EQ (op, Qfetch_handler)) + { + EMACS_UINT handler_buff_n = XFIXNUM (SECOND (args)); + gcc_jit_lvalue *c = + xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); + emit_frame_assignment ( + arg0, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field))); + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, NULL, @@ -2759,7 +2762,7 @@ compile_function (Lisp_Object func) frame_size), "local"); comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (unsigned i = 0; i < frame_size; ++i) + for (EMACS_INT i = 0; i < frame_size; ++i) comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, @@ -2789,6 +2792,16 @@ compile_function (Lisp_Object func) format_string ("local%u", i)); } + EMACS_UINT non_local_handlers = XFIXNUM (FUNCALL1 (comp-func-handler-cnt, func)); + comp.buffer_handler_vec = make_vector (non_local_handlers, Qnil); + for (unsigned i = 0; i < non_local_handlers; ++i) + ASET (comp.buffer_handler_vec, i, + make_mint_ptr ( + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + format_string ("handler_%u", i)))); + comp.func_blocks_h = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. @@ -3304,6 +3317,7 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qfetch_handler, "fetch-handler"); DEFSYM (Qcondition_case, "condition-case"); /* call operands. */ DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */ From 96e2863f2e85bc907e5fc0cb7d86e0b6ff54317a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Oct 2019 10:51:25 +0200 Subject: [PATCH 0482/1452] rework emit_limple_insn arg parsing --- src/comp.c | 55 +++++++++++++++++++++++++----------------------------- 1 file changed, 25 insertions(+), 30 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6b3ca832d98..f71df794185 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1186,35 +1186,30 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0 UNINIT; gcc_jit_rvalue *res; - Lisp_Object arg[6]; + Lisp_Object p = XCDR (insn); - ptrdiff_t n_args = list_length (p); unsigned i = 0; FOR_EACH_TAIL (p) { - eassert (i < n_args); + eassert (i < sizeof (arg)); arg[i++] = XCAR (p); } - if (CONSP (args)) - arg0 = XCAR (args); - if (EQ (op, Qjump)) { /* Unconditional branch. */ - gcc_jit_block *target = retrive_block (arg0); + gcc_jit_block *target = retrive_block (arg[0]); gcc_jit_block_end_with_jump (comp.block, NULL, target); } else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *a = emit_mvar_val (arg0); - gcc_jit_rvalue *b = emit_mvar_val (SECOND (args)); - gcc_jit_block *target1 = retrive_block (THIRD (args)); - gcc_jit_block *target2 = retrive_block (FORTH (args)); + gcc_jit_rvalue *a = emit_mvar_val (arg[0]); + gcc_jit_rvalue *b = emit_mvar_val (arg[1]); + gcc_jit_block *target1 = retrive_block (arg[2]); + gcc_jit_block *target2 = retrive_block (arg[3]); emit_cond_jump (emit_EQ (a, b), target2, target1); } @@ -1229,9 +1224,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, - XFIXNUM (arg0)); - gcc_jit_block *target1 = retrive_block (SECOND (args)); - gcc_jit_block *target2 = retrive_block (THIRD (args)); + XFIXNUM (arg[0])); + gcc_jit_block *target1 = retrive_block (arg[1]); + gcc_jit_block *target2 = retrive_block (arg[2]); gcc_jit_rvalue *test = gcc_jit_context_new_comparison ( comp.ctxt, NULL, @@ -1264,7 +1259,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *handler_bb = retrive_block (arg[3]); gcc_jit_block *guarded_bb = retrive_block (arg[4]); emit_limple_push_handler (handler, handler_type, handler_buff_n, - handler_bb, guarded_bb, arg0); + handler_bb, guarded_bb, arg[0]); } else if (EQ (op, Qpop_handler)) { @@ -1290,7 +1285,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qfetch_handler)) { - EMACS_UINT handler_buff_n = XFIXNUM (SECOND (args)); + EMACS_UINT handler_buff_n = XFIXNUM (arg[1]); gcc_jit_lvalue *c = xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_lvalue *m_handlerlist = @@ -1306,7 +1301,7 @@ emit_limple_insn (Lisp_Object insn) NULL, comp.handler_next_field))); emit_frame_assignment ( - arg0, + arg[0], gcc_jit_lvalue_as_rvalue( gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, @@ -1335,7 +1330,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qset)) { - Lisp_Object arg1 = SECOND (args); + Lisp_Object arg1 = arg[1]; if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); @@ -1352,16 +1347,16 @@ emit_limple_insn (Lisp_Object insn) ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); - emit_frame_assignment (arg0, res); + emit_frame_assignment (arg[0], res); } else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ - EMACS_UINT param_n = XFIXNUM (SECOND (args)); + EMACS_UINT param_n = XFIXNUM (arg[1]); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); - emit_frame_assignment (arg0, param); + emit_frame_assignment (arg[0], param); } else if (EQ (op, Qset_args_to_local)) { @@ -1376,7 +1371,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *res = gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); - emit_frame_assignment (arg0, res); + emit_frame_assignment (arg[0], res); } else if (EQ (op, Qset_rest_args_to_local)) { @@ -1385,7 +1380,7 @@ emit_limple_insn (Lisp_Object insn) C: local[2] = list (nargs - 2, args); */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1407,7 +1402,7 @@ emit_limple_insn (Lisp_Object insn) res = emit_call (Qlist, comp.lisp_obj_type, 2, list_args, false); - emit_frame_assignment (arg0, res); + emit_frame_assignment (arg[0], res); } else if (EQ (op, Qinc_args)) { @@ -1433,10 +1428,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, - XFIXNUM (SECOND (args))); - emit_comment (SSDATA (Fprin1_to_string (THIRD (args), Qnil))); + XFIXNUM (arg[1])); + emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); emit_frame_assignment ( - arg0, + arg[0], gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, @@ -1446,13 +1441,13 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcomment)) { /* Ex: (comment "Function: foo"). */ - emit_comment((char *) SDATA (arg0)); + emit_comment (SSDATA (arg[0])); } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, NULL, - emit_mvar_val (arg0)); + emit_mvar_val (arg[0])); } else { From 4847522fd4030af7ddb92b789545bc4e253524ee Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Oct 2019 11:04:18 +0200 Subject: [PATCH 0483/1452] some clean-up --- src/comp.c | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/comp.c b/src/comp.c index f71df794185..a7a5ce0dcbe 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,13 +37,6 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 -/* - If 1 always favorite the emission of direct constants when these are know - instead of the corresponding frame slot access. - This has to prove to have some perf advantage but certainly makes the - generated code C-like code more bloated. -*/ - /* C symbols emited for the load relocation mechanism. */ #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" @@ -60,10 +53,6 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (x)) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#define FORTH(x) \ - XCAR (XCDR (XCDR (XCDR (x)))) -#define FIFTH(x) \ - XCAR (XCDR (XCDR (XCDR (XCDR (x))))) #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) From adac6fa11a95b5c3dd5ae5766b1539687d5931f5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Oct 2019 11:30:39 +0200 Subject: [PATCH 0484/1452] make non local handler bb generation robust for all order of creation --- lisp/emacs-lisp/comp.el | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9ce1e96b3c8..d9b0c184625 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -511,12 +511,14 @@ Restore the original value afterwards." The basic block is returned." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) ;; If was already declared sanity check sp. - (cl-assert (or (null sp) (= sp (comp-block-sp bb))) - (sp (comp-block-sp bb)) "sp %d %d differs") - ;; Mark it pending in case is not already. - (unless (cl-find-if (lambda (bb) - (eq (comp-block-name bb) name)) - (comp-limplify-pending-blocks comp-pass)) + (progn + (cl-assert (or (null sp) (= sp (comp-block-sp bb))) + (sp (comp-block-sp bb)) "sp %d %d differs") + bb) + ;; Look into the pendings and add the a new one there if necessary. + (or (cl-find-if (lambda (bb) + (eq (comp-block-name bb) name)) + (comp-limplify-pending-blocks comp-pass)) (car (push (apply #'make--comp-block args) (comp-limplify-pending-blocks comp-pass)))))) @@ -548,12 +550,17 @@ The basic block is returned." do (aset v i mvar) finally (return v))) -(defsubst comp-emit (insn &optional bb) - "Emit INSN in BB is specified or the current basic block otherwise." - (let ((bb (or bb (comp-limplify-curr-block comp-pass)))) +(defsubst comp-emit (insn) + "Emit INSN into basic block BB." + (let ((bb (comp-limplify-curr-block comp-pass))) (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) +(defsubst comp-emit-as-head (insn bb) + "Emit INSN at the head of basic block BB. +NOTE: this is used for late fixup therefore ignore if the basic block is closed." + (setf (comp-block-insns bb) (nconc (comp-block-insns bb) (list insn)))) + (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." @@ -656,7 +663,7 @@ Return value is the fall through block name." handler-name guarded-name)) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) - (comp-emit `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) + (comp-emit-as-head `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) (cl-incf (comp-func-handler-cnt comp-func))))) (defun comp-limplify-listn (n) From 1d3c0d1716eb2025c1dd2e07195b55bb5781fdd3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Oct 2019 14:36:28 +0200 Subject: [PATCH 0485/1452] fix compilation when modules are enabled --- configure.ac | 39 ++++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/configure.ac b/configure.ac index 0cfd80bb2e8..c86dac6a65b 100644 --- a/configure.ac +++ b/configure.ac @@ -3671,23 +3671,6 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) -### Emacs Lisp native compiler support -HAVE_NATIVE_COMP=no -LIBGCCJIT_LIB= -COMP_OBJ= -if test "${with_nativecomp}" != "no"; then - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) - if test "${HAVE_NATIVE_COMP}" = "yes"; then - LIBGCCJIT_LIB="-lgccjit -ldl" - COMP_OBJ="dynlib.o comp.o" - AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) - AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", - [System extension for native compiled elisp]) - fi -fi -AC_SUBST(LIBGCCJIT_LIB) -AC_SUBST(COMP_OBJ) - ### Dynamic modules support LIBMODULES= HAVE_MODULES=no @@ -3754,6 +3737,28 @@ 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 +HAVE_NATIVE_COMP=no +LIBGCCJIT_LIB= +COMP_OBJ= +if test "${with_nativecomp}" != "no"; then + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) + if test "${HAVE_NATIVE_COMP}" = "yes"; then + LIBGCCJIT_LIB="-lgccjit -ldl" + if test "${HAVE_MODULES}" = yes; then + COMP_OBJ="comp.o" + else + COMP_OBJ="dynlib.o comp.o" + fi + AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) + fi +fi +AC_SUBST(LIBGCCJIT_LIB) +AC_SUBST(COMP_OBJ) + + ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no LIBPNG= From 59f7b155119b5718b83f0bac7409dd597002c89b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Oct 2019 15:03:03 +0200 Subject: [PATCH 0486/1452] fix comp-limplify-block for wrong cl func usage --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d9b0c184625..cf779179d70 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1092,7 +1092,7 @@ The block name is returned." (when (and fall-through (not (comp-block-closed bb))) (comp-emit `(jump ,next-bb)))) - (return))) + (cl-return))) until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) From face460c41f59b5097748159ce64a5a09b277dc7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Oct 2019 22:13:29 +0200 Subject: [PATCH 0487/1452] make more robust comp-emit-uncond-jump --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cf779179d70..f41731951ea 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -610,7 +610,8 @@ The block is returned." (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= (1- stack-depth) (comp-sp))) + (when stack-depth + (cl-assert (= (1- stack-depth) (comp-sp)))) (let ((target (comp-lap-to-limple-bb label-num))) (comp-block-maybe-mark-pending :name target :sp (comp-sp) From cf72d9de0f46960d260e3f5eba843ff01f30eff0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Oct 2019 22:19:14 +0200 Subject: [PATCH 0488/1452] emit TAG number as comment --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f41731951ea..cda6cdf3583 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -796,10 +796,11 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - (cl-destructuring-bind (_TAG _label-num . label-sp) insn + (cl-destructuring-bind (_TAG label-num . label-sp) insn ;; Paranoid? (when label-sp - (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))))) + (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) + (comp-emit-annotation (format "LAP TAG %d" label-num)))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref From 45158ed98b345145eb3e9f8c27b0591433465ff1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Oct 2019 22:20:38 +0200 Subject: [PATCH 0489/1452] promote a couple of small functions tu subst --- lisp/emacs-lisp/comp.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cda6cdf3583..b02f846eb9b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -545,8 +545,9 @@ The basic block is returned." "Return a clean frame of meta variables of size SIZE." (cl-loop with v = (make-vector size nil) for i below size - for mvar = (if ssa (make-comp-ssa-mvar :slot i) - (make-comp-mvar :slot i)) + for mvar = (if ssa + (make-comp-ssa-mvar :slot i) + (make-comp-mvar :slot i)) do (aset v i mvar) finally (return v))) @@ -561,7 +562,7 @@ The basic block is returned." NOTE: this is used for late fixup therefore ignore if the basic block is closed." (setf (comp-block-insns bb) (nconc (comp-block-insns bb) (list insn)))) -(defun comp-emit-set-call (call) +(defsubst comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." (cl-assert call) @@ -575,7 +576,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (cl-assert src-slot) (comp-emit `(set ,(comp-slot) ,src-slot))))) -(defun comp-emit-annotation (str) +(defsubst comp-emit-annotation (str) "Emit annotation STR." (comp-emit `(comment ,str))) From 67ac8603eaa5618622d746f4097a0ba6ca2f76b3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 10:24:03 +0100 Subject: [PATCH 0490/1452] better comp-limplify-block do not non fall through blocks --- lisp/emacs-lisp/comp.el | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b02f846eb9b..858a49b2809 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1079,21 +1079,18 @@ The block name is returned." (comp-func-lap comp-func)) for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) - for fall-through = (comp-lap-fall-through-p inst) do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) - (pcase next-inst + when (comp-lap-fall-through-p inst) + do (pcase next-inst (`(TAG ,_label . ,label-sp) - (when (and label-sp fall-through) + (when label-sp (cl-assert (= (1- label-sp) (comp-sp)))) (let* ((stack-depth (if label-sp (1- label-sp) - (if fall-through - (comp-sp) - (error "Unknown stack depth.")))) - (next-bb (comp-add-pending-block stack-depth))) - (when (and fall-through - (not (comp-block-closed bb))) + (comp-sp))) + (next-bb (comp-add-pending-block stack-depth))) + (unless (comp-block-closed bb) (comp-emit `(jump ,next-bb)))) (cl-return))) until (comp-lap-eob-p inst))) From 475b4768c856c0a25ee236faf0c30b39d5cd804a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 15:16:59 +0100 Subject: [PATCH 0491/1452] simplify comp-limplify-block --- lisp/emacs-lisp/comp.el | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 858a49b2809..d7abb8bfa1a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1075,24 +1075,10 @@ The block name is returned." (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop - for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + for inst in (nthcdr (comp-limplify-pc comp-pass) (comp-func-lap comp-func)) - for inst = (car inst-cell) - for next-inst = (car-safe (cdr inst-cell)) do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) - when (comp-lap-fall-through-p inst) - do (pcase next-inst - (`(TAG ,_label . ,label-sp) - (when label-sp - (cl-assert (= (1- label-sp) (comp-sp)))) - (let* ((stack-depth (if label-sp - (1- label-sp) - (comp-sp))) - (next-bb (comp-add-pending-block stack-depth))) - (unless (comp-block-closed bb) - (comp-emit `(jump ,next-bb)))) - (cl-return))) until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) From 96bca89e5b03b6d5ab7ac8bda8216adfc1911205 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 15:55:08 +0100 Subject: [PATCH 0492/1452] fix subr name within comp-limplify-lap-inst --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7abb8bfa1a..7b77b4d87c9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -885,7 +885,7 @@ the annotation emission." (byte-preceding-char preceding-char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call (comp-call 'indent_to + (comp-emit-set-call (comp-call 'indent-to (comp-slot) (make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) @@ -908,7 +908,7 @@ the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call (comp-call 'narrow_to_region + (comp-emit-set-call (comp-call 'narrow-to-region (comp-slot) (comp-slot+1)))) (byte-widen From 10c6303d242ce8f01f38e78da71d01c7a379e651 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 16:11:56 +0100 Subject: [PATCH 0493/1452] fix invalid write into emit_limple_insn --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index a7a5ce0dcbe..3b124bef23a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1182,7 +1182,8 @@ emit_limple_insn (Lisp_Object insn) unsigned i = 0; FOR_EACH_TAIL (p) { - eassert (i < sizeof (arg)); + if (i == sizeof (arg) / sizeof (Lisp_Object)) + break; arg[i++] = XCAR (p); } From 283b0db31c87a8bed736a8459ab16ae066ceb024 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 16:57:29 +0100 Subject: [PATCH 0494/1452] Revert "simplify comp-limplify-block" This reverts commit 31861f63a4b57e69cdcd247e48567242a05bd58e. --- lisp/emacs-lisp/comp.el | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7b77b4d87c9..1891398c149 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1075,10 +1075,24 @@ The block name is returned." (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop - for inst in (nthcdr (comp-limplify-pc comp-pass) + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) + when (comp-lap-fall-through-p inst) + do (pcase next-inst + (`(TAG ,_label . ,label-sp) + (when label-sp + (cl-assert (= (1- label-sp) (comp-sp)))) + (let* ((stack-depth (if label-sp + (1- label-sp) + (comp-sp))) + (next-bb (comp-add-pending-block stack-depth))) + (unless (comp-block-closed bb) + (comp-emit `(jump ,next-bb)))) + (cl-return))) until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) From 0b9bec6863e138efee77c2948c355b53951e6d18 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 17:13:03 +0100 Subject: [PATCH 0495/1452] fix comp-emit-narg-prologue --- lisp/emacs-lisp/comp.el | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1891398c149..abcddda3808 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1008,14 +1008,17 @@ the annotation emission." (comp-make-curr-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) - finally (comp-emit '(jump entry_rest_args))) + finally (comp-emit '(jump entry_rest_args))) (when (not (= minarg nonrest)) (cl-loop for i from minarg below nonrest + for bb = (intern (format "entry_fallback_%s" i)) + for next-bb = (if (= (1+ i) nonrest) + 'entry_rest_args + (intern (format "entry_fallback_%s" (1+ i)))) do (comp-with-sp i - (comp-make-curr-block (intern (format "entry_fallback_%s" i)) - (comp-sp)) - (comp-emit-set-const nil)) - finally (comp-emit '(jump entry_rest_args)))) + (comp-make-curr-block bb (comp-sp)) + (comp-emit-set-const nil) + (comp-emit `(jump ,next-bb))))) (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) From 515644edc0ed2e73198f4c4eeb822715b2589dc9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Oct 2019 18:14:33 +0100 Subject: [PATCH 0496/1452] sanity check against block duplication. --- lisp/emacs-lisp/comp.el | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index abcddda3808..e5db273a8ed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -507,7 +507,7 @@ Restore the original value afterwards." (error "Can't find label %d" label))) (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) - "Create a basic block and mark it as pending. + "If necessary create a pending basic block. The basic block is returned." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) ;; If was already declared sanity check sp. @@ -1062,7 +1062,7 @@ This will be called at load-time." do (return (comp-block-name bb)))))) (defun comp-add-pending-block (sp) - "Add next basic block to the pending queue. + "Create basic block and add it to the pending queue if necessary. The block name is returned." (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) (comp-new-block-sym)))) @@ -1126,6 +1126,12 @@ The block name is returned." (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) while next-bb do (comp-limplify-block next-bb)) + ;; Sanity check against block duplication. + (cl-loop with addr-h = (make-hash-table) + for bb being the hash-value in (comp-func-blocks func) + for addr = (comp-block-addr bb) + do (cl-assert (null (gethash addr addr-h))) + (puthash addr t addr-h)) (comp-limplify-finalize-function func))) (defun comp-add-func-to-ctxt (func) From e0e0b92c1d3fe39085731db04bacd9def31f3940 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 Nov 2019 15:28:17 +0100 Subject: [PATCH 0497/1452] rework limplify to prevent block duplication --- lisp/emacs-lisp/comp.el | 151 +++++++++++++++++----------------------- 1 file changed, 63 insertions(+), 88 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e5db273a8ed..49212815c88 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -147,7 +147,9 @@ To be used when ncall-conv is nil.")) (nonrest nil :type number :documentation "Number of non rest arguments.")) -(cl-defstruct (comp-block (:copier nil) (:constructor make--comp-block)) +(cl-defstruct (comp-block (:copier nil) + (:constructor make--comp-block + (addr sp name))) ; Positional "A basic block." (name nil :type symbol) ;; These two slots are used during limplification. @@ -506,20 +508,22 @@ Restore the original value afterwards." (or (gethash label (comp-limplify-label-to-addr comp-pass)) (error "Can't find label %d" label))) -(cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) - "If necessary create a pending basic block. -The basic block is returned." - (if-let ((bb (gethash name (comp-func-blocks comp-func)))) - ;; If was already declared sanity check sp. - (progn - (cl-assert (or (null sp) (= sp (comp-block-sp bb))) - (sp (comp-block-sp bb)) "sp %d %d differs") - bb) - ;; Look into the pendings and add the a new one there if necessary. - (or (cl-find-if (lambda (bb) - (eq (comp-block-name bb) name)) - (comp-limplify-pending-blocks comp-pass)) - (car (push (apply #'make--comp-block args) +(defun comp-bb-maybe-add (lap-addr &optional sp) + "If necessary create a pending basic block for LAP-ADDR with stack depth SP. +The basic block is returned regardless it was already declared or not." + (let ((bb (or (cl-loop ; See if the block was already liplified. + for bb being the hash-value in (comp-func-blocks comp-func) + when (equal (comp-block-addr bb) lap-addr) + return bb) + (cl-find-if (lambda (bb) ; Look within the pendings blocks. + (= (comp-block-addr bb) lap-addr)) + (comp-limplify-pending-blocks comp-pass))))) + (if bb + (progn + (cl-assert (or (null sp) (= sp (comp-block-sp bb))) + (sp (comp-block-sp bb)) "sp %d %d differs") + bb) + (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) (defun comp-call (func &rest args) @@ -591,33 +595,21 @@ If DST-N is specified use it otherwise assume it to be the current slot." ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block :name block-name :sp entry-sp :addr addr))) + (let ((bb (make--comp-block addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb) (setf (comp-limplify-pc comp-pass) addr) (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) -(defun comp-lap-to-limple-bb (n) - "Given the LAP label N return the limple basic block name." - (let ((hash (comp-func-lap-block comp-func))) - (if-let ((bb (gethash n hash))) - ;; If was already created return it. - bb - (let ((name (comp-new-block-sym))) - (puthash n name hash) - name)))) - (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth (cl-assert (= (1- stack-depth) (comp-sp)))) - (let ((target (comp-lap-to-limple-bb label-num))) - (comp-block-maybe-mark-pending :name target - :sp (comp-sp) - :addr (comp-label-to-addr label-num)) - (comp-emit `(jump ,target)) + (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) + (comp-sp)))) + (comp-emit `(jump ,(comp-block-name target))) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -627,17 +619,13 @@ block. If NEGATED non null negate the tested condition. Return value is the fall through block name." (cl-destructuring-bind (label-num . label-sp) lap-label - (let ((bb (comp-new-block-sym)) ; Fall through block. - (target (comp-lap-to-limple-bb label-num)) - (target-sp (+ target-offset (comp-sp)))) + (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)))) ; Fall through block. + (target-sp (+ target-offset (comp-sp))) + (target (comp-block-name (comp-bb-maybe-add (comp-label-to-addr label-num) + target-sp)))) (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) - (comp-block-maybe-mark-pending :name bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name target - :sp target-sp - :addr (comp-label-to-addr label-num)) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) @@ -648,22 +636,18 @@ Return value is the fall through block name." "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label (cl-assert (= (- label-sp 2) (comp-sp))) - (let* ((guarded-name (comp-new-block-sym)) - (handler-name (comp-lap-to-limple-bb label-num)) - (handler-buff-n (comp-func-handler-cnt comp-func)) - (handler-bb (comp-block-maybe-mark-pending :name handler-name - :sp (1+ (comp-sp)) - :addr - (comp-label-to-addr label-num)))) - (comp-block-maybe-mark-pending :name guarded-name - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) + (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp))) + (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) + (1+ (comp-sp)))) + (handler-buff-n (comp-func-handler-cnt comp-func))) + (comp-emit (list 'push-handler handler-type (comp-slot+1) handler-buff-n - handler-name - guarded-name)) + (comp-block-name handler-bb) + (comp-block-name guarded-bb))) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) (comp-emit-as-head `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) (cl-incf (comp-func-handler-cnt comp-func))))) @@ -697,26 +681,28 @@ Return value is the fall through block name." "Emit a limple for a lap jump table given VAR and LAST-INSN." (pcase last-insn (`(setimm ,_ ,_ ,const) - (cl-loop for test being each hash-keys of const - using (hash-value target-label) - with len = (hash-table-count const) - for n from 1 - for last = (= n len) - for m-test = (make-comp-mvar :constant test) - for ff-bb = (comp-new-block-sym) ; Fall through block. - for target = (comp-lap-to-limple-bb target-label) - do - (comp-emit (list 'cond-jump var m-test ff-bb target)) - (comp-block-maybe-mark-pending :name target - :sp (comp-sp) - :addr (comp-label-to-addr target-label)) - (if last - (comp-block-maybe-mark-pending :name ff-bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-make-curr-block ff-bb + (cl-loop + for test being each hash-keys of const + using (hash-value target-label) + with len = (hash-table-count const) + for n from 1 + for last = (= n len) + for m-test = (make-comp-mvar :constant test) + for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) + (comp-sp))) + for ff-bb = (if last + (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)) + (make--comp-block nil (comp-sp) - (comp-limplify-pc comp-pass))))) + (comp-new-block-sym))) + for ff-bb-name = (comp-block-name ff-bb) + do + (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + (unless last + ;; All fall through are artificially created here except the last one. + (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) @@ -1040,7 +1026,7 @@ This will be called at load-time." :frame-size 0)) (comp-func func) (comp-pass (make-comp-limplify - :curr-block (make--comp-block) + :curr-block (make--comp-block -1 0 'top-level) :frame (comp-new-frame 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") @@ -1061,16 +1047,6 @@ This will be called at load-time." when (pred bb) do (return (comp-block-name bb)))))) -(defun comp-add-pending-block (sp) - "Create basic block and add it to the pending queue if necessary. -The block name is returned." - (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) - (comp-new-block-sym)))) - (comp-block-maybe-mark-pending :name next-bb - :sp sp - :addr (comp-limplify-pc comp-pass)) - next-bb)) - (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb) @@ -1092,7 +1068,7 @@ The block name is returned." (let* ((stack-depth (if label-sp (1- label-sp) (comp-sp))) - (next-bb (comp-add-pending-block stack-depth))) + (next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) (unless (comp-block-closed bb) (comp-emit `(jump ,next-bb)))) (cl-return))) @@ -1120,9 +1096,7 @@ The block name is returned." (cl-incf (comp-sp) (1+ nonrest)))) (comp-emit '(jump bb_0)) ;; Body - (comp-block-maybe-mark-pending :name (comp-new-block-sym) - :sp (comp-sp) - :addr 0) + (comp-bb-maybe-add 0 (comp-sp)) (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) while next-bb do (comp-limplify-block next-bb)) @@ -1130,8 +1104,9 @@ The block name is returned." (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) for addr = (comp-block-addr bb) - do (cl-assert (null (gethash addr addr-h))) - (puthash addr t addr-h)) + when addr + do (cl-assert (null (gethash addr addr-h))) + (puthash addr t addr-h)) (comp-limplify-finalize-function func))) (defun comp-add-func-to-ctxt (func) From a18e54f54bdcd5d9b2c11b0307b0a157f52e5926 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 12:16:41 +0100 Subject: [PATCH 0498/1452] add a test for functions with more than 8 arguments --- test/src/comp-test-funcs.el | 10 ++++++++++ test/src/comp-tests.el | 6 ++++++ 2 files changed, 16 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 540170ea966..66ce0e70e8d 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -81,6 +81,14 @@ (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)) @@ -342,6 +350,7 @@ (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 @@ -350,6 +359,7 @@ 3)))) (defun comp-test-silly-frame2 (token) + ;; Check robustness against dead code. (while c (cl-case c (?< 1) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 16726cb4bbe..06a1ae90542 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -124,6 +124,12 @@ (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (should (equal (comp-tests-ffuncall-callee-more8-f 1 2 3 4 5 6 7 8 9 10) + '(1 2 3 4 5 6 7 8 9 10))) + + (should (equal (comp-tests-ffuncall-callee-more8-rest-f 1 2 3 4 5 6 7 8 9 10 11) + '(1 2 3 4 5 6 7 8 9 (10 11)))) + (should (equal (comp-tests-ffuncall-native-f) [nil])) (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) From 0f68de830acb5eef41307efc119f3f16fdb35ab3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 12:17:26 +0100 Subject: [PATCH 0499/1452] fix limplification for functions with more than 8 args --- lisp/emacs-lisp/comp.el | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 49212815c88..2f6bcf71b1e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -145,7 +145,9 @@ To be used when ncall-conv is nil.")) "Describe args when the functin signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." (nonrest nil :type number - :documentation "Number of non rest arguments.")) + :documentation "Number of non rest arguments.") + (rest nil :type boolean + :documentation "t if rest argument is present.")) (cl-defstruct (comp-block (:copier nil) (:constructor make--comp-block @@ -371,7 +373,8 @@ Put PREFIX in front of it." (make-comp-args :min mandatory :max nonrest) (make-comp-nargs :min mandatory - :nonrest nonrest)))) + :nonrest nonrest + :rest rest)))) (defun comp-byte-frame-size (byte-compiled-func) "Given BYTE-COMPILED-FUNC return the frame size to be allocated." @@ -982,7 +985,7 @@ the annotation emission." (cl-incf (comp-sp) (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) -(defun comp-emit-narg-prologue (minarg nonrest) +(defun comp-emit-narg-prologue (minarg nonrest rest) "Emit the prologue for a narg function." (cl-loop for i below minarg do (comp-emit `(set-args-to-local ,(comp-slot-n i))) @@ -1006,7 +1009,10 @@ the annotation emission." (comp-emit-set-const nil) (comp-emit `(jump ,next-bb))))) (comp-make-curr-block 'entry_rest_args (comp-sp)) - (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) + (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) + (setf (comp-sp) nonrest) + (when (and (> nonrest 8) (null rest)) + (cl-decf (comp-sp)))) (defun comp-limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." @@ -1080,8 +1086,7 @@ This will be called at load-time." (comp-func func) (comp-pass (make-comp-limplify :frame (comp-new-frame frame-size))) - (args (comp-func-args func)) - (args-min (comp-args-base-min args))) + (args (comp-func-args func))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) @@ -1091,9 +1096,9 @@ This will be called at load-time." (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit-narg-prologue args-min nonrest) - (cl-incf (comp-sp) (1+ nonrest)))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))) (comp-emit '(jump bb_0)) ;; Body (comp-bb-maybe-add 0 (comp-sp)) From 0720354082858f59db9f70ada33efc424126d668 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 12:34:09 +0100 Subject: [PATCH 0500/1452] native compile return the filename of the compilation unit --- lisp/emacs-lisp/comp.el | 6 ++++-- src/comp.c | 7 +++---- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f6bcf71b1e..4fb9c129a88 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1702,7 +1702,8 @@ Prepare every function for final compilation and drive the C back-end." "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. If INPUT is a symbol, native-compile its function definition. -If INPUT is a string, use it as the file path to be native compiled." +If INPUT is a string, use it as the file path to be native compiled. +Return the compilation unit filename." (unless (or (symbolp input) (stringp input)) (error "Trying to native compile something not a symbol function or file")) @@ -1716,7 +1717,8 @@ If INPUT is a string, use it as the file path to be native compiled." (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) - comp-passes))) + comp-passes) + data)) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index 3b124bef23a..fed599dc511 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3061,16 +3061,15 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); - const char *filename = - (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); + Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - filename); + SSDATA (out_file)); pthread_sigmask (SIG_SETMASK, &oldset, 0); - return Qt; + return out_file; } From d6ae5369b0682ada2e7d801a3cc54f671ed03bf3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 14:34:31 +0100 Subject: [PATCH 0501/1452] some code massage --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4fb9c129a88..89744f6e0d2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -556,7 +556,7 @@ The basic block is returned regardless it was already declared or not." (make-comp-ssa-mvar :slot i) (make-comp-mvar :slot i)) do (aset v i mvar) - finally (return v))) + finally return v)) (defsubst comp-emit (insn) "Emit INSN into basic block BB." @@ -1051,7 +1051,7 @@ This will be called at load-time." (comp-block-name pending) (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) when (pred bb) - do (return (comp-block-name bb)))))) + return (comp-block-name bb))))) (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." @@ -1285,7 +1285,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - return t))) + return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i From 5eb8d3dba14d94386f42dbb8fcdd28a98d10ac64 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 16:48:40 +0100 Subject: [PATCH 0502/1452] rework bytecomp spill code --- lisp/emacs-lisp/bytecomp.el | 37 +++++++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 72e58350209..a4bdbacf76f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -564,14 +564,19 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") ;; These are use by comp.el to spill data out of here -(defvar byte-native-compiling nil) +(cl-defstruct byte-to-native-function + "Named or anonymous function defined a top level." + name data) +(cl-defstruct byte-to-native-top-level + "All other top level forms." + form) +(defvar byte-native-compiling nil + "t while native compiling.") (defvar byte-to-native-lap nil - "Alist to accumulate lap. -Each element is (NAME . LAP)") -(defvar byte-to-native-bytecode nil - "Alist to accumulate bytecode. -Each element is (NAME . BYTECODE)") -(defvar byte-to-native-top-level-forms nil) + "A-list to accumulate LAP. +Each pair is (NAME . LAP)") +(defvar byte-to-native-top-level-forms nil + "List of top level forms.") ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2245,6 +2250,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) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2276,10 +2285,6 @@ we output that argument and the following argument QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." - (when (and byte-native-compiling name) - ;; Spill bytecode output for the native compiler here - (push (cons name (apply #'vector form)) - byte-to-native-bytecode)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -2496,9 +2501,6 @@ list that represents a doc string reference. (setq form (copy-sequence form)) (setcar (cdr (cdr form)) (byte-compile-top-level (nth 2 form) nil 'file)))) - (when byte-native-compiling - ;; Spill output for the native compiler here - (push form byte-to-native-top-level-forms)) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -2706,6 +2708,13 @@ 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)) + (make-byte-to-native-function :name name :data 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 From fb309c14f0f5075cd649c083abf2a0713b949030 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 17:32:20 +0100 Subject: [PATCH 0503/1452] limplify top level at last --- lisp/emacs-lisp/comp.el | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 89744f6e0d2..e76e68c31bd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1123,9 +1123,8 @@ This will be called at load-time." (defun comp-limplify (lap-funcs) "Compute the LIMPLE ir for LAP-FUNCS. Top level forms for the current context are rendered too." - (mapc #'comp-add-func-to-ctxt - (cons (comp-limplify-top-level) - (mapcar #'comp-limplify-function lap-funcs)))) + (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) + (comp-add-func-to-ctxt (comp-limplify-top-level))) ;;; SSA pass specific code. From fb41165adf7c6a354876a26fd7a6cc686f3fe142 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 17:32:42 +0100 Subject: [PATCH 0504/1452] add top-level-forms slot into comp-ctxt (replace old specific defvar one) --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e76e68c31bd..c52cef6e94f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -116,8 +116,8 @@ Can be used by code that wants to expand differently in this case.") "Lisp side of the compiler context." (output nil :type string :documentation "Target output filename for the compilation.") - (top-level-defvars nil :type list - :documentation "List of top level form to be exp.") + (top-level-forms () :type list + :documentation "List of spilled top level forms.") (exp-funcs () :type list :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table From 03d2dda12f9e5d877edd15e31d6076361ccbd75a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 17:33:55 +0100 Subject: [PATCH 0505/1452] add doc slot into comp-func struct --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c52cef6e94f..8a9305a59b8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -205,6 +205,8 @@ Is in use to help the SSA rename pass.")) :documentation "The function name in the native world.") (byte-func nil :documentation "Byte compiled version.") + (doc nil :type string + :documentation "Doc string.") (lap () :type list :documentation "LAP assembly representation.") (args nil :type comp-args-base) From bf91dd23fb7dd37650dfdb218358c8bac659c5a6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Nov 2019 17:34:32 +0100 Subject: [PATCH 0506/1452] rework comp-spill-lap-functions-file --- lisp/emacs-lisp/comp.el | 88 +++++++++++++++++++++-------------------- 1 file changed, 46 insertions(+), 42 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8a9305a59b8..a56b22225a6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -384,53 +384,57 @@ Put PREFIX in front of it." ;; For the 1+ see bytecode.c:365 (finger crossed). (1+ (aref byte-compiled-func 3))) -(defun comp-spill-lap-function (function-name) +(defun comp-spill-lap-function (_function-name) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (let* ((f (symbol-function function-name)) - (func (make-comp-func :symbol-name function-name - :c-func-name (comp-c-func-name - function-name - "F")))) - (when (byte-code-function-p f) - (error "Can't native compile an already bytecompiled function")) - (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) - (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) - (cl-assert lap) - (comp-log lap) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list))) - (setf (comp-func-lap func) lap) - (setf (comp-func-frame-size func) - (comp-byte-frame-size (comp-func-byte-func func))) - func))) + (error "To be reimplemented") + ;; (let* ((f (symbol-function function-name)) + ;; (func (make-comp-func :symbol-name function-name + ;; :c-func-name (comp-c-func-name + ;; function-name + ;; "F")))) + ;; (when (byte-code-function-p f) + ;; (error "Can't native compile an already bytecompiled function")) + ;; (setf (comp-func-byte-func func) + ;; (byte-compile (comp-func-symbol-name func))) + ;; (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) + ;; (cl-assert lap) + ;; (comp-log lap) + ;; (let ((lambda-list (aref (comp-func-byte-func func) 0))) + ;; (setf (comp-func-args func) + ;; (comp-decrypt-lambda-list lambda-list))) + ;; (setf (comp-func-lap func) lap) + ;; (setf (comp-func-frame-size func) + ;; (comp-byte-frame-size (comp-func-byte-func func))) + ;; func)) + ) (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) - (setf (comp-ctxt-top-level-defvars comp-ctxt) - (reverse (mapcar (lambda (x) - (cl-ecase (car x) - ('defvar (cdr x)) - ('defconst (cdr x)))) - byte-to-native-top-level-forms))) - (cl-loop for (name . bytecode) in byte-to-native-bytecode - for lap = (alist-get name byte-to-native-lap) - for lambda-list = (aref bytecode 0) - for func = (make-comp-func :symbol-name name - :byte-func bytecode - :c-func-name (comp-c-func-name - name - "F") - :args (comp-decrypt-lambda-list lambda-list) - :lap lap - :frame-size (comp-byte-frame-size - bytecode)) - do (when (> comp-verbose 1) - (comp-log (format "Function %s:\n" name)) - (comp-log lap)) - collect func)) + (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (cl-loop + for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. + when (and (byte-to-native-function-p x) + (byte-to-native-function-name x)) + collect x) + for name = (byte-to-native-function-name f) + for data = (byte-to-native-function-data f) + for doc = (when (>= (length data) 5) (aref data 4)) + for lap = (alist-get name byte-to-native-lap) + for lambda-list = (aref data 0) + for func = (make-comp-func :symbol-name name + :byte-func data + :doc doc + :c-func-name (comp-c-func-name + name + "F") + :args (comp-decrypt-lambda-list lambda-list) + :lap lap + :frame-size (comp-byte-frame-size data)) + when (> comp-verbose 1) + do (comp-log (format "Function %s:\n" name)) + (comp-log lap) + collect func)) (defun comp-spill-lap (input) "Byte compile and spill the LAP rapresentation for INPUT. From 5c188552341204daf53f0ae2aa4e0c73ec4feb1e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 Nov 2019 15:27:57 +0100 Subject: [PATCH 0507/1452] rework top level environment modification mechanism --- lisp/emacs-lisp/comp.el | 49 +++++++++++++++--------- src/comp.c | 83 ++++++++++++++++++++--------------------- 2 files changed, 71 insertions(+), 61 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a56b22225a6..381d72e3dc3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -118,8 +118,6 @@ Can be used by code that wants to expand differently in this case.") :documentation "Target output filename for the compilation.") (top-level-forms () :type list :documentation "List of spilled top level forms.") - (exp-funcs () :type list - :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") @@ -1029,6 +1027,35 @@ the annotation emission." (comp-log-func func)) func) +(cl-defgeneric comp-emit-for-top-level (form) + "Emit the limple code for top level FORM.") + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) + (let* ((name (byte-to-native-function-name form)) + (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) + (args (comp-func-args f)) + (c-name (comp-func-c-func-name f)) + (doc (comp-func-doc f))) + (cl-assert (and name f)) + (comp-emit (comp-call 'comp--register-subr + (make-comp-mvar :constant name) + (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many)) + (make-comp-mvar :constant c-name) + (make-comp-mvar :constant doc))))) + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) + (let* ((form (byte-to-native-top-level-form form)) + (func-name (car form)) + (args (cdr form))) + (if (eq 'unevalled (cdr (subr-arity (symbol-function func-name)))) + (comp-emit (comp-call func-name (make-comp-mvar :constant args))) + (comp-emit (apply #'comp-call func-name + (mapcar (lambda (x) (make-comp-mvar :constant x)) + args)))))) + (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. This will be called at load-time." @@ -1042,9 +1069,8 @@ This will be called at load-time." :frame (comp-new-frame 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") - (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) - do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) - (comp-emit `(return ,(make-comp-mvar :constant nil))) + (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) + (comp-emit `(return ,(make-comp-mvar :constant t))) (comp-limplify-finalize-function func))) (defun comp-addr-to-bb-name (addr) @@ -1659,19 +1685,6 @@ These are substituted with normals 'set'." Prepare every function for final compilation and drive the C back-end." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-exp-funcs comp-ctxt) - (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) - for f being each hash-value of h - for args = (comp-func-args f) - for doc = (when (> (length (comp-func-byte-func f)) 4) - (aref (comp-func-byte-func f) 4)) - collect (vector (comp-func-symbol-name f) - (comp-func-c-func-name f) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many)) - doc))) (comp--compile-ctxt-to-file name)) (defun comp-final (_) diff --git a/src/comp.c b/src/comp.c index fed599dc511..ba56cc1ab19 100644 --- a/src/comp.c +++ b/src/comp.c @@ -41,7 +41,6 @@ along with GNU Emacs. If not, see . */ #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" #define TEXT_DATA_RELOC_SYM "text_data_reloc" -#define TEXT_EXPORTED_FUNC_RELOC_SYM "text_exported_funcs" #define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" #define STR_VALUE(s) #s @@ -1802,9 +1801,6 @@ emit_ctxt_code (void) gcc_jit_struct_as_type (f_reloc_struct), IMPORTED_FUNC_RELOC_SYM); - /* Exported functions info. */ - Lisp_Object func_list = FUNCALL1 (comp-ctxt-exp-funcs, Vcomp_ctxt); - emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); SAFE_FREE (); } @@ -3127,6 +3123,7 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; +dynlib_handle_ptr load_handle; static void prevent_gc (Lisp_Object obj) @@ -3150,9 +3147,9 @@ static int load_comp_unit (dynlib_handle_ptr handle) { /* Imported data. */ - Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (load_handle, DATA_RELOC_SYM); - Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = load_static_obj (load_handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3163,11 +3160,11 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported functions. */ Lisp_Object (**f_relocs)(void) = - dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + dynlib_sym (load_handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + load_static_obj (load_handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); - for (EMACS_UINT i = 0; i < f_vec_len; i++) + for (EMACS_UINT i = 0; i < f_vec_len; i++) { Lisp_Object f_sym = AREF (f_vec, i); char *f_str = SSDATA (SYMBOL_NAME (f_sym)); @@ -3215,53 +3212,52 @@ load_comp_unit (dynlib_handle_ptr handle) } } - /* Exported functions. */ - Lisp_Object func_list = load_static_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); - - while (func_list) - { - Lisp_Object el = XCAR (func_list); - Lisp_Object Qsym = AREF (el, 0); - char *c_func_name = SSDATA (AREF (el, 1)); - Lisp_Object args = AREF (el, 2); - ptrdiff_t minargs = XFIXNUM (XCAR (args)); - ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; - /* char *doc = SSDATA (AREF (el, 3)); */ - void *func = dynlib_sym (handle, c_func_name); - eassert (func); - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = func; - x->s.min_args = minargs; - x->s.max_args = maxargs; - x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); - x->s.native_elisp = true; - defsubr(x); - - func_list = XCDR (func_list); - } - - /* Finally execute top level forms. */ - void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + /* Executing this will perform all the expected environment modification. */ + void (*top_level_run)(void) = dynlib_sym (load_handle, "top_level_run"); top_level_run (); return 0; } +DEFUN ("comp--register-subr", Fcomp__register_subr, + Scomp__register_subr, + 5, 5, 0, + doc: /* This gets called by top_level_run during load phase to register + each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc) +{ + if (!load_handle) + error ("comp--register-subr can only be called during native code load phase."); + + void *func = dynlib_sym (load_handle, SSDATA (c_name)); + eassert (func); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = XFIXNUM (minarg); + x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; + x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.native_elisp = true; + defsubr(x); + + return Qnil; +} + /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, doc: /* Load native elisp code FILE. */) (Lisp_Object file) { - dynlib_handle_ptr handle; - CHECK_STRING (file); - handle = dynlib_open (SSDATA (file)); - if (!handle) + load_handle = dynlib_open (SSDATA (file)); + if (!load_handle) xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); - int r = load_comp_unit (handle); + int r = load_comp_unit (load_handle); + + load_handle = NULL; if (r != 0) xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); @@ -3332,6 +3328,7 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp__register_subr); defsubr (&Snative_elisp_load); staticpro (&comp.exported_funcs_h); From a2ed435e3aa18c0e6d4997cbb9a81426c952a622 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Nov 2019 22:13:20 +0100 Subject: [PATCH 0508/1452] fix function top_level_run generation --- lisp/emacs-lisp/comp.el | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 381d72e3dc3..b5e9dfb3841 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1047,14 +1047,10 @@ the annotation emission." (make-comp-mvar :constant doc))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) - (let* ((form (byte-to-native-top-level-form form)) - (func-name (car form)) - (args (cdr form))) - (if (eq 'unevalled (cdr (subr-arity (symbol-function func-name)))) - (comp-emit (comp-call func-name (make-comp-mvar :constant args))) - (comp-emit (apply #'comp-call func-name - (mapcar (lambda (x) (make-comp-mvar :constant x)) - args)))))) + (let ((form (byte-to-native-top-level-form form))) + (comp-emit (comp-call 'eval + (make-comp-mvar :constant form) + (make-comp-mvar :constant t))))) (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. From 809bd5aa34727151bdf40230e2fbc3151760466b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Nov 2019 23:06:54 +0100 Subject: [PATCH 0509/1452] test provide --- test/src/comp-test-funcs.el | 2 ++ test/src/comp-tests.el | 7 +++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 66ce0e70e8d..79a25511fad 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -365,4 +365,6 @@ (?< 1) (?> 2)))) +(provide 'comp-test-funcs) + ;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 06a1ae90542..6eada52541f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -36,8 +36,11 @@ "comp-test-funcs.el")) (message "Compiling %s" comp-test-src) -(native-compile comp-test-src) -(load (concat comp-test-src "n")) +(load (native-compile comp-test-src)) + +(ert-deftest comp-tests-provide () + "Testing top level provide." + (should (featurep 'comp-test-funcs))) (ert-deftest comp-tests-varref () "Testing varref." From 9ee6b685a338cd06d4b053e39f3e2da505d20612 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Nov 2019 23:13:23 +0100 Subject: [PATCH 0510/1452] add test for macro definition --- test/src/comp-test-funcs.el | 3 +++ test/src/comp-tests.el | 4 ++++ 2 files changed, 7 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 79a25511fad..e3fc0f26b58 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -235,6 +235,9 @@ (t (+ (comp-tests-fib-f (- n 1)) (comp-tests-fib-f (- n 2)))))) +(defmacro comp-tests-macro-m (x) + x) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6eada52541f..9e0ca196871 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -274,6 +274,10 @@ (ert-deftest comp-tests-recursive () (should (= (comp-tests-fib-f 10) 55))) +(ert-deftest comp-tests-macro () + "Just check we can define macros" + (should (macrop (symbol-function 'comp-tests-macro-m)))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 9f15b4c3ca98e6af3dfe61f70d0043ae896167ac Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Nov 2019 23:38:37 +0100 Subject: [PATCH 0511/1452] fix top level macro generation --- lisp/emacs-lisp/bytecomp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a4bdbacf76f..836377b4df3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2712,7 +2712,7 @@ not to take responsibility for the actual compilation of the code." ;; Spill output for the native compiler here. (push (if macro (make-byte-to-native-top-level - :form `(defalias ,name (macro . ,code) nil)) + :form `(defalias ',name '(macro . ,code) nil)) (make-byte-to-native-function :name name :data code)) byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having From d392276b63cd0d9eb16f0e624bd8da9737cc66cb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 5 Nov 2019 20:47:34 +0100 Subject: [PATCH 0512/1452] allow nested loadings --- src/comp.c | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index ba56cc1ab19..1aa0636c5b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3123,7 +3123,7 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; -dynlib_handle_ptr load_handle; +static Lisp_Object load_handle_stack; static void prevent_gc (Lisp_Object obj) @@ -3147,9 +3147,9 @@ static int load_comp_unit (dynlib_handle_ptr handle) { /* Imported data. */ - Lisp_Object *data_relocs = dynlib_sym (load_handle, DATA_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = load_static_obj (load_handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3160,9 +3160,9 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported functions. */ Lisp_Object (**f_relocs)(void) = - dynlib_sym (load_handle, IMPORTED_FUNC_RELOC_SYM); + dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - load_static_obj (load_handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); for (EMACS_UINT i = 0; i < f_vec_len; i++) { @@ -3213,7 +3213,7 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Executing this will perform all the expected environment modification. */ - void (*top_level_run)(void) = dynlib_sym (load_handle, "top_level_run"); + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); top_level_run (); return 0; @@ -3227,10 +3227,11 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc) { - if (!load_handle) + dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); + if (!handle) error ("comp--register-subr can only be called during native code load phase."); - void *func = dynlib_sym (load_handle, SSDATA (c_name)); + void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); @@ -3251,17 +3252,17 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, (Lisp_Object file) { CHECK_STRING (file); - load_handle = dynlib_open (SSDATA (file)); - if (!load_handle) + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); + if (!handle) xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); - int r = load_comp_unit (load_handle); - - load_handle = NULL; - + int r = load_comp_unit (handle); if (r != 0) xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); + load_handle_stack = XCDR (load_handle_stack); + return Qt; } @@ -3269,12 +3270,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { - staticpro (&Vnative_elisp_refs_hash); - Vnative_elisp_refs_hash - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, - DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, - Qnil, false); - /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); @@ -3345,8 +3340,16 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - comp_speed = DEFAULT_SPEED; + + /* Load mechanism. */ + staticpro (&Vnative_elisp_refs_hash); + Vnative_elisp_refs_hash + = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, + DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, + Qnil, false); + staticpro (&load_handle_stack); + load_handle_stack = Qnil; } #endif /* HAVE_NATIVE_COMP */ From 33d8b736b0330f51050ca1fc389527d708b1eb23 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 5 Nov 2019 20:34:12 +0100 Subject: [PATCH 0513/1452] do not native compile interactive functions --- lisp/emacs-lisp/bytecomp.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 836377b4df3..04c80c17577 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2713,7 +2713,10 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (make-byte-to-native-function :name name :data code)) + (if (commandp code) + (make-byte-to-native-top-level ;FIXME compile interactive functions. + :form `(defalias ',name ,code)) + (make-byte-to-native-function :name name :data 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. From f97c03ebca440229ff953baee9e458a3ddcdaa70 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 7 Nov 2019 21:27:05 +0100 Subject: [PATCH 0514/1452] add comp-tests-string-trim --- test/src/comp-test-funcs.el | 3 +++ test/src/comp-tests.el | 3 +++ 2 files changed, 6 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index e3fc0f26b58..6127d24e656 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -238,6 +238,9 @@ (defmacro comp-tests-macro-m (x) x) +(defun comp-tests-string-trim-f (url) + (string-trim url)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9e0ca196871..6d714656ade 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -278,6 +278,9 @@ "Just check we can define macros" (should (macrop (symbol-function 'comp-tests-macro-m)))) +(ert-deftest comp-tests-string-trim () + (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 93aeb781e1da3cab6ae90c90cd3668862155ab85 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 7 Nov 2019 21:40:51 +0100 Subject: [PATCH 0515/1452] fix ref ssa propagation --- lisp/emacs-lisp/comp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5e9dfb3841..2afbae56261 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1489,7 +1489,9 @@ This can run just once." (when (cl-reduce #'eq (mapcar #'comp-mvar-type rest)) (setf (comp-mvar-type lval) (comp-mvar-type (car rest)))) ;; Reference propagation. - (setf (comp-mvar-ref lval) (cl-every #'comp-mvar-ref rest))))) + (let ((operands (cons lval rest))) + (when (cl-some #'comp-mvar-ref operands) + (mapc (lambda (x) (setf (comp-mvar-ref x) t)) rest)))))) (defun comp-propagate* () "Propagate for set and phi operands." From 6761e69a2bce255bbd78e08b5c592f4de19253f5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Nov 2019 11:43:16 +0100 Subject: [PATCH 0516/1452] fix missing byte-save-restriction op --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2afbae56261..813c826501f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -932,7 +932,7 @@ the annotation emission." (comp-emit (comp-call 'record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction - (comp-call 'helper-save-restriction)) + (comp-emit (comp-call 'helper_save_restriction))) (byte-catch) ;; Obsolete (byte-unwind-protect (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) diff --git a/src/comp.c b/src/comp.c index 1aa0636c5b7..4afba1183f3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -183,6 +183,7 @@ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); +void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); @@ -1695,6 +1696,8 @@ declare_runtime_imported_funcs (void) args[0] = comp.lisp_obj_type; ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + ADD_IMPORTED ("helper_save_restriction", comp.void_type, 0, NULL); + ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -3109,6 +3112,13 @@ helper_unbind_n (Lisp_Object n) return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil); } +void +helper_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) { @@ -3194,6 +3204,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "helper_unbind_n")) { f_relocs[i] = (void *) helper_unbind_n; + } else if (!strcmp (f_str, "helper_save_restriction")) + { + f_relocs[i] = (void *) helper_save_restriction; } else if (!strcmp (f_str, "record_unwind_current_buffer")) { f_relocs[i] = (void *) record_unwind_current_buffer; From eca71dd5c7a8b7013eb20e1457eddf62776e6c29 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Nov 2019 15:46:44 +0100 Subject: [PATCH 0517/1452] fix ref propagation --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 813c826501f..3d452543452 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1491,7 +1491,7 @@ This can run just once." ;; Reference propagation. (let ((operands (cons lval rest))) (when (cl-some #'comp-mvar-ref operands) - (mapc (lambda (x) (setf (comp-mvar-ref x) t)) rest)))))) + (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) (defun comp-propagate* () "Propagate for set and phi operands." From ec00ef8d48afaef65527c02ea013ba4489ed279d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Nov 2019 16:22:07 +0100 Subject: [PATCH 0518/1452] have propagate run the correct number of times --- lisp/emacs-lisp/comp.el | 35 ++++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3d452543452..08ccfbb97d0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,7 +230,7 @@ structure.") (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) -(cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) +(cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum :documentation "Slot number.") @@ -1445,6 +1445,14 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." 'fixnum (type-of obj))) +(defun comp-copy-insn (insn) + "Deep copy INSN." + (cl-loop for op in insn + collect (cl-typecase op + (cons (comp-copy-insn op)) + (comp-mvar (copy-comp-mvar op)) + (t op)))) + (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. This can run just once." @@ -1465,6 +1473,7 @@ This can run just once." (setf (comp-mvar-type lval) (comp-mvar-type rval))) (defun comp-propagate-insn (insn) + "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval @@ -1494,20 +1503,28 @@ This can run just once." (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) (defun comp-propagate* () - "Propagate for set and phi operands." - (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + "Propagate for set* and phi operands. +Return t if something was changed." + (cl-loop with modified = nil + for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) - do (comp-propagate-insn insn)))) + for orig-insn = (unless modified ; Save consing after 1th change. + (comp-copy-insn insn)) + do (comp-propagate-insn insn) + when (and (null modified) (not (equal insn orig-insn))) + do (setf modified t)) + finally (cl-return modified))) (defun comp-propagate (_) (maphash (lambda (_ f) (let ((comp-func f)) (comp-basic-const-propagate) - ;; FIXME: unbelievably dumb... - (cl-loop repeat 10 - do (comp-propagate*)) - (when (> comp-verbose 2) - (comp-log-func comp-func)))) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i))) + (when (> comp-verbose 2) + (comp-log-func comp-func)))) (comp-ctxt-funcs-h comp-ctxt))) From 6a34ff5d9c13688a7264b2654f04982c5a3cfc6b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Nov 2019 16:56:55 +0100 Subject: [PATCH 0519/1452] rework log mechanism and trim down verbosity --- lisp/emacs-lisp/comp.el | 104 ++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 53 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 08ccfbb97d0..dabf6cf99ab 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,8 +42,8 @@ "Compiler verbosity. From 0 to 3. - 0 no logging - 1 final limple is logged -- 2 LAP and final limple are logged -- 3 all passes are dumping" +- 2 LAP and final limple and some pass info are logged +- 3 max verbosity" :type 'number :group 'comp) @@ -300,43 +300,46 @@ BODY is evaluate only if `comp-verbose' is > 0." (goto-char (point-max)) ,@body)))) -(defun comp-log (data) +(defun comp-log (data verbosity) "Log DATA." - (if (and noninteractive - (> comp-verbose 0)) - (if (atom data) - (message "%s" data) - (mapc (lambda (x) - (message "%s"(prin1-to-string x))) - data)) - (comp-within-log-buff - (if (and data (atom data)) - (insert data) - (mapc (lambda (x) - (insert (prin1-to-string x) "\n")) - data) - (insert "\n"))))) + (when (>= comp-verbose verbosity) + (if noninteractive + (if (atom data) + (message "%s" data) + (mapc (lambda (x) + (message "%s"(prin1-to-string x))) + data)) + (comp-within-log-buff + (if (and data (atom data)) + (insert data) + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data) + (insert "\n")))))) -(defun comp-log-func (func) +(defun comp-log-func (func verbosity) "Log function FUNC." - (comp-log (format "\nFunction: %s" (comp-func-symbol-name func))) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (comp-log (concat "<" (symbol-name block-name) ">\n")) - (comp-log (comp-block-insns bb)))) + (when (>= comp-verbose verbosity) + (comp-log (format "\nFunction: %s\n" (comp-func-symbol-name func)) verbosity) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (comp-log (concat "<" (symbol-name block-name) ">\n") verbosity) + (comp-log (comp-block-insns bb) verbosity)))) (defun comp-log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges func))) (when (> comp-verbose 2) (comp-log (format "\nEdges in function: %s\n" - (comp-func-symbol-name func)))) + (comp-func-symbol-name func)) + 0)) (mapc (lambda (e) (when (> comp-verbose 2) (comp-log (format "n: %d src: %s dst: %s\n" (comp-edge-number e) (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e)))))) + (comp-block-name (comp-edge-dst e))) + 0))) edges))) @@ -429,9 +432,8 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (comp-byte-frame-size data)) - when (> comp-verbose 1) - do (comp-log (format "Function %s:\n" name)) - (comp-log lap) + do (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1) collect func)) (defun comp-spill-lap (input) @@ -1023,8 +1025,7 @@ the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (nreverse (comp-block-insns bb)))) - (when (> comp-verbose 2) - (comp-log-func func)) + (comp-log-func func 2) func) (cl-defgeneric comp-emit-for-top-level (form) @@ -1252,8 +1253,7 @@ Top level forms for the current context are rendered too." with changed = t while changed initially (progn - (when (> comp-verbose 2) - (comp-log "Computing dominator tree...\n")) + (comp-log "Computing dominator tree...\n" 2) (setf (comp-block-dom entry) entry) ;; Set the post order number. (cl-loop for name in (reverse rev-bb-list) @@ -1292,12 +1292,12 @@ Top level forms for the current context are rendered too." (maphash (lambda (name bb) (let ((dom (comp-block-dom bb)) (df (comp-block-df bb))) - (when (> comp-verbose 2) - (comp-log (format "block: %s idom: %s DF %s\n" - name - (when dom (comp-block-name dom)) - (cl-loop for b being each hash-keys of df - collect b)))))) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of df + collect b)) + 3))) (comp-func-blocks comp-func))) (defun comp-place-phis () @@ -1380,8 +1380,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename () "Entry point to rename SSA within the current function." - (when (> comp-verbose 2) - (comp-log "Renaming\n")) + (comp-log "Renaming\n" 2) (let ((frame-size (comp-func-frame-size comp-func)) (visited (make-hash-table))) (cl-labels ((ssa-rename-rec (bb in-frame) @@ -1430,8 +1429,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (when (> comp-verbose 2) - (comp-log-func comp-func)))) + (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1522,9 +1520,8 @@ Return t if something was changed." (cl-loop for i from 1 while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i))) - (when (> comp-verbose 2) - (comp-log-func comp-func)))) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1651,11 +1648,12 @@ Return t if something was changed." ;; Every l-value appearing that does not appear as r-value has no right to ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) - (when (> comp-verbose 2) - (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) - (comp-log (format "l-vals %s\n" l-vals)) - (comp-log (format "r-vals %s\n" r-vals)) - (comp-log (format "Nuking ids: %s\n" nuke-list))) + (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n" + (comp-func-symbol-name comp-func) + l-vals + r-vals + nuke-list) + 3) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1689,7 +1687,7 @@ These are substituted with normals 'set'." (let ((comp-func f)) (comp-dead-assignments-func) (comp-remove-type-hints-func) - (comp-log-func comp-func))) + (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -1746,9 +1744,9 @@ Return the compilation unit filename." :output (if (symbolp input) (symbol-name input) (file-name-sans-extension (expand-file-name input)))))) - (comp-log "\n \n") + (comp-log "\n \n" 1) (mapc (lambda (pass) - (comp-log (format "Running pass %s:\n" pass)) + (comp-log (format "Running pass %s:\n" pass) 2) (setq data (funcall pass data))) comp-passes) data)) From ce4375f57f9b89d68fb639590f3e4a0a28e3a627 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Nov 2019 17:12:56 +0100 Subject: [PATCH 0520/1452] two doc nits --- lisp/emacs-lisp/comp.el | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dabf6cf99ab..cb001bc884c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -39,7 +39,7 @@ :group 'lisp) (defcustom comp-verbose 0 - "Compiler verbosity. From 0 to 3. + "Compiler verbosity. From 0 to 3. - 0 no logging - 1 final limple is logged - 2 LAP and final limple and some pass info are logged @@ -48,7 +48,7 @@ :group 'comp) (defconst native-compile-log-buffer "*Native-compile-Log*" - "Name of the native-compiler's log buffer.") + "Name of the native-compiler log buffer.") (defvar comp-native-compiling nil "This gets bound to t while native compilation. @@ -301,7 +301,7 @@ BODY is evaluate only if `comp-verbose' is > 0." ,@body)))) (defun comp-log (data verbosity) - "Log DATA." + "Log DATA given VERBOSITY." (when (>= comp-verbose verbosity) (if noninteractive (if (atom data) @@ -650,7 +650,6 @@ Return value is the fall through block name." (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) (1+ (comp-sp)))) (handler-buff-n (comp-func-handler-cnt comp-func))) - (comp-emit (list 'push-handler handler-type (comp-slot+1) From 6d230fc2c04532b4abf2474411b2995c237d5cc8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Nov 2019 18:01:16 +0100 Subject: [PATCH 0521/1452] comment unused functions --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4afba1183f3..273d8aeac33 100644 --- a/src/comp.c +++ b/src/comp.c @@ -515,6 +515,7 @@ emit_lval_XLI (gcc_jit_lvalue *obj) comp.lisp_obj_as_num); } +/* static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { @@ -533,8 +534,7 @@ emit_lval_XLP (gcc_jit_lvalue *obj) return gcc_jit_lvalue_access_field (obj, NULL, comp.lisp_obj_as_ptr); -} - +} */ static gcc_jit_rvalue * emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) { From c47892201b2b9f1ef903ff2a12bb9ed9e64d19de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 08:58:48 +0100 Subject: [PATCH 0522/1452] add current thread missing reloc mechanism --- src/comp.c | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 273d8aeac33..04a63c1aec5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -38,6 +38,7 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 /* C symbols emited for the load relocation mechanism. */ +#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" #define TEXT_DATA_RELOC_SYM "text_data_reloc" @@ -116,7 +117,7 @@ typedef struct { gcc_jit_struct *thread_state_s; gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; - gcc_jit_rvalue *current_thread; + gcc_jit_rvalue *current_thread_ref; /* other globals */ gcc_jit_rvalue *pure; /* libgccjit has really limited support for casting therefore this union will @@ -1258,9 +1259,11 @@ emit_limple_insn (Lisp_Object insn) current_thread->m_handlerlist->next; */ gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), + NULL, + comp.m_handlerlist); gcc_jit_block_add_assignment( comp.block, @@ -1279,7 +1282,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue *c = xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), NULL, comp.m_handlerlist); gcc_jit_block_add_assignment ( @@ -1723,6 +1728,15 @@ emit_ctxt_code (void) { USE_SAFE_ALLOCA; + comp.current_thread_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.thread_state_ptr_type), + CURRENT_THREAD_RELOC_SYM)); + declare_runtime_imported_data (); /* Imported objects. */ EMACS_UINT d_reloc_len = @@ -2984,15 +2998,11 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_thread_state_struct (); define_cast_union (); - comp.current_thread = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.thread_state_ptr_type, - current_thread); + /* FIXME!! */ comp.pure = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, pure); - return Qt; } @@ -3156,6 +3166,10 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) static int load_comp_unit (dynlib_handle_ptr handle) { + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + *current_thread_reloc = ¤t_thread; + /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); From 3ed524c908d4aefd174ae6a8adc2bdaabb4bc4da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 09:26:17 +0100 Subject: [PATCH 0523/1452] add pure addr relocation mechanism --- src/comp.c | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 04a63c1aec5..80a59faa859 100644 --- a/src/comp.c +++ b/src/comp.c @@ -39,6 +39,7 @@ along with GNU Emacs. If not, see . */ /* C symbols emited for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" +#define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" #define TEXT_DATA_RELOC_SYM "text_data_reloc" @@ -119,7 +120,7 @@ typedef struct { gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread_ref; /* other globals */ - gcc_jit_rvalue *pure; + gcc_jit_rvalue *pure_ref; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -1000,7 +1001,9 @@ emit_PURE_P (gcc_jit_rvalue *ptr) GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, emit_cast (comp.uintptr_type, ptr), - emit_cast (comp.uintptr_type, comp.pure)), + emit_cast (comp.uintptr_type, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -1737,6 +1740,15 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); + comp.pure_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.void_ptr_type), + PURE_RELOC_SYM)); + declare_runtime_imported_data (); /* Imported objects. */ EMACS_UINT d_reloc_len = @@ -2998,11 +3010,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_thread_state_struct (); define_cast_union (); - /* FIXME!! */ - comp.pure = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - pure); return Qt; } @@ -3170,6 +3177,10 @@ load_comp_unit (dynlib_handle_ptr handle) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); *current_thread_reloc = ¤t_thread; + EMACS_INT ***pure_reloc = + dynlib_sym (handle, PURE_RELOC_SYM); + *pure_reloc = (EMACS_INT **)&pure; + /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); From 105e7180230dc22db91af2c8cbfa6fc3d2fee7e6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 09:32:56 +0100 Subject: [PATCH 0524/1452] sanity check during eln load --- src/comp.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 80a59faa859..07c35413dde 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3175,15 +3175,22 @@ load_comp_unit (dynlib_handle_ptr handle) { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - *current_thread_reloc = ¤t_thread; + EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); - EMACS_INT ***pure_reloc = - dynlib_sym (handle, PURE_RELOC_SYM); + if (!(current_thread_reloc + && pure_reloc + && data_relocs + && f_relocs + && top_level_run)) + return -1; + + *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; /* Imported data. */ - Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); @@ -3194,8 +3201,6 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Imported functions. */ - Lisp_Object (**f_relocs)(void) = - dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); @@ -3251,7 +3256,6 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Executing this will perform all the expected environment modification. */ - void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); top_level_run (); return 0; From 2ee2c67736cd76a52a2eb1002d0ec15e883082e0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 10:17:24 +0100 Subject: [PATCH 0525/1452] simplify non local exit handler mechanism --- lisp/emacs-lisp/comp.el | 17 ++++------- src/comp.c | 63 ++++++++++++++++++++--------------------- 2 files changed, 36 insertions(+), 44 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cb001bc884c..377886996ea 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -221,9 +221,7 @@ structure.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.") - (handler-cnt 0 :type number - :documentation "Number of non local handler buffers.")) + :documentation "Counter to create ssa limple vars.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -648,17 +646,14 @@ Return value is the fall through block name." (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) - (1+ (comp-sp)))) - (handler-buff-n (comp-func-handler-cnt comp-func))) + (1+ (comp-sp))))) (comp-emit (list 'push-handler handler-type (comp-slot+1) - handler-buff-n (comp-block-name handler-bb) (comp-block-name guarded-bb))) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) - (comp-emit-as-head `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) - (cl-incf (comp-func-handler-cnt comp-func))))) + (comp-emit-as-head `(fetch-handler ,(comp-slot+1)) handler-bb)))) (defun comp-limplify-listn (n) "Limplify list N." @@ -1181,7 +1176,7 @@ Top level forms for the current context are rendered too." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) - for (op first second third forth fifth) = last-insn + for (op first second third forth) = last-insn do (cl-case op (jump (edge-add :src bb :dst (gethash first blocks))) @@ -1192,8 +1187,8 @@ Top level forms for the current context are rendered too." (edge-add :src bb :dst (gethash second blocks)) (edge-add :src bb :dst (gethash third blocks))) (push-handler - (edge-add :src bb :dst (gethash forth blocks)) - (edge-add :src bb :dst (gethash fifth blocks))) + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) (return) (otherwise (error "Block %s does not end with a branch in func %s" diff --git a/src/comp.c b/src/comp.c index 07c35413dde..cce4f1d6e52 100644 --- a/src/comp.c +++ b/src/comp.c @@ -55,6 +55,7 @@ along with GNU Emacs. If not, see . */ #define THIRD(x) \ XCAR (XCDR (XCDR (x))) +/* FIXME with call1 */ #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) @@ -114,6 +115,7 @@ typedef struct { gcc_jit_field *handler_val_field; gcc_jit_field *handler_next_field; gcc_jit_type *handler_ptr_type; + gcc_jit_lvalue *loc_handler; /* struct thread_state. */ gcc_jit_struct *thread_state_s; gcc_jit_field *m_handlerlist; @@ -161,7 +163,6 @@ typedef struct { Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ - Lisp_Object buffer_handler_vec; /* All locals used to store non local exit values. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -1145,25 +1146,23 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) static void emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, - EMACS_UINT handler_buff_n, gcc_jit_block *handler_bb, - gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + Lisp_Object clobbered_mvar) { /* struct handler *c = push_handler (POP, type); */ - gcc_jit_lvalue *c = - xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( comp.block, NULL, - c, + comp.loc_handler, emit_call (intern_c_string ("push_handler"), comp.handler_ptr_type, 2, args, false)); args[0] = gcc_jit_lvalue_get_address ( gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), + gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_jmp_field), NULL); @@ -1236,10 +1235,9 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qpush_handler)) { /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ - gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); int h_num UNINIT; Lisp_Object handler_spec = arg[0]; - EMACS_UINT handler_buff_n = XFIXNUM (arg[2]); + gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; else if (EQ (handler_spec, Qcondition_case)) @@ -1250,10 +1248,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, h_num); - gcc_jit_block *handler_bb = retrive_block (arg[3]); - gcc_jit_block *guarded_bb = retrive_block (arg[4]); - emit_limple_push_handler (handler, handler_type, handler_buff_n, - handler_bb, guarded_bb, arg[0]); + gcc_jit_block *handler_bb = retrive_block (arg[2]); + gcc_jit_block *guarded_bb = retrive_block (arg[3]); + emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, + arg[0]); } else if (EQ (op, Qpop_handler)) { @@ -1281,29 +1279,33 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qfetch_handler)) { - EMACS_UINT handler_buff_n = XFIXNUM (arg[1]); - gcc_jit_lvalue *c = - xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), - NULL, - comp.m_handlerlist); + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.loc_handler, + gcc_jit_lvalue_as_rvalue (m_handlerlist)); + gcc_jit_block_add_assignment ( comp.block, NULL, m_handlerlist, gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_next_field))); emit_frame_assignment ( arg[0], gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field))); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_val_field))); } else if (EQ (op, Qcall)) { @@ -2802,15 +2804,10 @@ compile_function (Lisp_Object func) format_string ("local%u", i)); } - EMACS_UINT non_local_handlers = XFIXNUM (FUNCALL1 (comp-func-handler-cnt, func)); - comp.buffer_handler_vec = make_vector (non_local_handlers, Qnil); - for (unsigned i = 0; i < non_local_handlers; ++i) - ASET (comp.buffer_handler_vec, i, - make_mint_ptr ( - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("handler_%u", i)))); + comp.loc_handler = gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + "handler"); comp.func_blocks_h = CALLN (Fmake_hash_table); From 26aeca29801a8e8950141d9d54aeb9a22ee6c5ad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 11:35:49 +0100 Subject: [PATCH 0526/1452] fix comp-copy-insn for dotted pairs --- lisp/emacs-lisp/comp.el | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 377886996ea..b450f4d6f68 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1439,11 +1439,13 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-copy-insn (insn) "Deep copy INSN." - (cl-loop for op in insn - collect (cl-typecase op - (cons (comp-copy-insn op)) - (comp-mvar (copy-comp-mvar op)) - (t op)))) + (cond + ((and (listp insn) (listp (cdr insn))) + (mapcar #'comp-copy-insn insn)) + ((consp insn) ; Pair + (cons (car insn) (cdr insn))) + ((comp-mvar-p insn) (copy-comp-mvar insn)) + (t insn))) (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. From e176d04d45adbb51f6bfa0b5a0352927056f3519 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 13:10:31 +0100 Subject: [PATCH 0527/1452] fix SIGIO hang after compilation --- src/comp.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/comp.c b/src/comp.c index cce4f1d6e52..8793f7b856c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see . */ #include "window.h" #include "dynlib.h" #include "buffer.h" +#include "blockinput.h" #define DEFAULT_SPEED 2 /* See comp-speed var. */ @@ -3037,6 +3038,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp_speed); /* Gcc doesn't like being interrupted at all. */ + block_input (); sigset_t oldset; sigset_t blocked; sigemptyset (&blocked); @@ -3081,6 +3083,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, SSDATA (out_file)); pthread_sigmask (SIG_SETMASK, &oldset, 0); + unblock_input (); return out_file; } From 76dd30a98590f2266290a70f2e3d4d272c092310 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 14:25:17 +0100 Subject: [PATCH 0528/1452] fix again comp-copy-insn --- lisp/emacs-lisp/comp.el | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b450f4d6f68..5283e57669f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1439,13 +1439,20 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-copy-insn (insn) "Deep copy INSN." - (cond - ((and (listp insn) (listp (cdr insn))) - (mapcar #'comp-copy-insn insn)) - ((consp insn) ; Pair - (cons (car insn) (cdr insn))) - ((comp-mvar-p insn) (copy-comp-mvar insn)) - (t insn))) + ;; Adapted from `copy-tree'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setq newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setq 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-basic-const-propagate () "Propagate simple constants for setimm operands. From aee75b87719abfaed605e33ed0c9e3a9a81417d8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 14:30:33 +0100 Subject: [PATCH 0529/1452] fix two nits --- lisp/emacs-lisp/comp.el | 2 -- test/src/comp-test-funcs.el | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5283e57669f..4b15bb1f8af 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -244,8 +244,6 @@ structure.") (ref nil :type boolean :documentation "When t this is used by reference.")) -(defvar comp-ctxt) ;; FIXME (to be removed) - ;; Special vars used by some passes (defvar comp-func) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 6127d24e656..5f33eacdb2f 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -26,7 +26,7 @@ (defvar comp-tests-var1 3) (defun comp-tests-varref-f () - comp-tests-var1) + comp-tests-var1) (defun comp-tests-list-f () (list 1 2 3)) From f9ea53442e6f492f1543a5e21479e72be8eff4c3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 14:43:47 +0100 Subject: [PATCH 0530/1452] move speed definition into lisp code --- lisp/emacs-lisp/comp.el | 4 ++++ src/comp.c | 13 +++++-------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4b15bb1f8af..f87d4bc401a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,6 +38,10 @@ "Emacs Lisp native compiler." :group 'lisp) +(defcustom comp-speed 2 + "Compiler optimization level. From 0 to 3." + :type 'number + :group 'comp) (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. - 0 no logging diff --git a/src/comp.c b/src/comp.c index 8793f7b856c..7fa55b12477 100644 --- a/src/comp.c +++ b/src/comp.c @@ -34,8 +34,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" -#define DEFAULT_SPEED 2 /* See comp-speed var. */ - #define COMP_DEBUG 1 /* C symbols emited for the load relocation mechanism. */ @@ -287,7 +285,7 @@ get_slot (Lisp_Object mvar) { EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar)); gcc_jit_lvalue **frame = - (FUNCALL1 (comp-mvar-ref, mvar) || comp_speed < 2) + (FUNCALL1 (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; return frame[slot_n]; } @@ -2794,7 +2792,7 @@ compile_function (Lisp_Object func) - Allow gcc to trigger other optimizations that are prevented by memory referencing. */ - if (comp_speed >= 2) + if (SPEED >= 2) { comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); for (unsigned i = 0; i < frame_size; ++i) @@ -3036,7 +3034,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - comp_speed); + SPEED); /* Gcc doesn't like being interrupted at all. */ block_input (); sigset_t oldset; @@ -3312,6 +3310,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { + /* Compiler control customize. */ + DEFSYM (Qcomp_speed, "comp-speed"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); @@ -3376,13 +3376,10 @@ syms_of_comp (void) staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; - DEFVAR_INT ("comp-speed", comp_speed, - doc: /* From 0 to 3. */); DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - comp_speed = DEFAULT_SPEED; /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); From d5ffb4949044ae58fb418b1b214cc7c6eb16a29c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 14:51:38 +0100 Subject: [PATCH 0531/1452] better comp-debug customize --- lisp/emacs-lisp/comp.el | 10 ++++++++++ src/comp.c | 8 +++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f87d4bc401a..cc7a1ba06a0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,6 +42,16 @@ "Compiler optimization level. From 0 to 3." :type 'number :group 'comp) + +(defcustom comp-debug 0 + "Compiler debug level. From 0 to 3. +- 0 no debug facility +- 1 emit debug symbols and dump pseudo C code +- 2 dump gcc passes and libgccjit log file +- 3 dump libgccjit reproducer" + :type 'number + :group 'comp) + (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. - 0 no logging diff --git a/src/comp.c b/src/comp.c index 7fa55b12477..969495eb938 100644 --- a/src/comp.c +++ b/src/comp.c @@ -34,8 +34,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" -#define COMP_DEBUG 1 - /* C symbols emited for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -44,6 +42,9 @@ along with GNU Emacs. If not, see . */ #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" +#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) +#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) + #define STR_VALUE(s) #s #define STR(s) STR_VALUE (s) @@ -3070,7 +3071,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (ctxtname)), 1); - if (COMP_DEBUG > 1) + if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); @@ -3312,6 +3313,7 @@ syms_of_comp (void) { /* Compiler control customize. */ DEFSYM (Qcomp_speed, "comp-speed"); + DEFSYM (Qcomp_debug, "comp-debug"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); From c33c2ef5119a3e1ba9c97ca03e001916f83d09f9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 17:02:55 +0100 Subject: [PATCH 0532/1452] fix non local mechanism --- lisp/emacs-lisp/comp.el | 27 ++++++++++++++++----------- src/comp.c | 2 +- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cc7a1ba06a0..f82aefb4ef1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -527,6 +527,10 @@ Restore the original value afterwards." (or (gethash label (comp-limplify-label-to-addr comp-pass)) (error "Can't find label %d" label))) +(defsubst comp-mark-curr-bb-closed () + "Mark the current basic block as closed." + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) + (defun comp-bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." @@ -580,11 +584,6 @@ The basic block is returned regardless it was already declared or not." (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) -(defsubst comp-emit-as-head (insn bb) - "Emit INSN at the head of basic block BB. -NOTE: this is used for late fixup therefore ignore if the basic block is closed." - (setf (comp-block-insns bb) (nconc (comp-block-insns bb) (list insn)))) - (defsubst comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." @@ -629,7 +628,7 @@ The block is returned." (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) (comp-sp)))) (comp-emit `(jump ,(comp-block-name target))) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) + (comp-mark-curr-bb-closed)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. @@ -648,7 +647,7 @@ Return value is the fall through block name." (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) + (comp-mark-curr-bb-closed) bb))) (defun comp-emit-handler (lap-label handler-type) @@ -658,14 +657,20 @@ Return value is the fall through block name." (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) - (1+ (comp-sp))))) + (1+ (comp-sp)))) + (pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym)))) (comp-emit (list 'push-handler handler-type (comp-slot+1) - (comp-block-name handler-bb) + (comp-block-name pop-bb) (comp-block-name guarded-bb))) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) - (comp-emit-as-head `(fetch-handler ,(comp-slot+1)) handler-bb)))) + (comp-mark-curr-bb-closed) + ;; Emit the basic block to pop the handler if we got the non local. + (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) pop-bb) + (comp-emit `(fetch-handler ,(comp-slot+1))) + (comp-emit `(jump ,(comp-block-name handler-bb))) + (comp-mark-curr-bb-closed)))) (defun comp-limplify-listn (n) "Limplify list N." diff --git a/src/comp.c b/src/comp.c index 969495eb938..0e190e88874 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2807,7 +2807,7 @@ compile_function (Lisp_Object func) comp.loc_handler = gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, - "handler"); + "c"); comp.func_blocks_h = CALLN (Fmake_hash_table); From c9f367950652a3728cc94c7a7faf0aa55c2aae9f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 17:07:45 +0100 Subject: [PATCH 0533/1452] compile tests with debug 1 --- test/src/comp-tests.el | 1 + 1 file changed, 1 insertion(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6d714656ade..2e388b9f148 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -30,6 +30,7 @@ (require 'comp) (setq comp-speed 3) +(setq comp-debug 1) (defconst comp-test-src (concat (file-name-directory (or load-file-name buffer-file-name)) From 00c493f01703f619a62e08bea17a49ce12f2367b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 18:50:34 +0100 Subject: [PATCH 0534/1452] better doc --- lisp/emacs-lisp/comp.el | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f82aefb4ef1..c4529bee7c7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,26 +38,31 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-speed 2 - "Compiler optimization level. From 0 to 3." +(defcustom comp-speed 0 + "Compiler optimization level. From 0 to 3. +- 0 no otimizations are performed, compile time is favored. +- 1 lite optimizations. +- 2 heavy optimizations. +- 3 max optimization level, to be used only when necessary. + The compiler can inline within the compilation unit..." :type 'number :group 'comp) (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. -- 0 no debug facility -- 1 emit debug symbols and dump pseudo C code -- 2 dump gcc passes and libgccjit log file -- 3 dump libgccjit reproducer" +- 0 no debug facility. +- 1 emit debug symbols and dump pseudo C code. +- 2 dump gcc passes and libgccjit log file. +- 3 dump libgccjit reproducer." :type 'number :group 'comp) (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. -- 0 no logging -- 1 final limple is logged -- 2 LAP and final limple and some pass info are logged -- 3 max verbosity" +- 0 no logging. +- 1 final limple is logged. +- 2 LAP and final limple and some pass info are logged. +- 3 max verbosity." :type 'number :group 'comp) @@ -1752,7 +1757,7 @@ Prepare every function for final compilation and drive the C back-end." (defun native-compile (input) "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. -If INPUT is a symbol, native-compile its function definition. +If INPUT is a symbol, native compile its function definition. If INPUT is a string, use it as the file path to be native compiled. Return the compilation unit filename." (unless (or (symbolp input) From 942702f506de1c7c3eff4e13470248be1a26e778 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 18:50:45 +0100 Subject: [PATCH 0535/1452] remove unused variable --- lisp/emacs-lisp/comp.el | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c4529bee7c7..b700a40f755 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -457,7 +457,6 @@ If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lap ()) - (byte-to-native-bytecode ()) (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) From e1128305102bab268272770b4a77361dcd9efb5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Nov 2019 20:01:48 +0100 Subject: [PATCH 0536/1452] add native-compile-async --- lisp/emacs-lisp/comp.el | 57 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 56 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b700a40f755..a31a82dd4f1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -53,7 +53,7 @@ - 0 no debug facility. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. -- 3 dump libgccjit reproducer." +- 3 dump libgccjit reproducers." :type 'number :group 'comp) @@ -66,6 +66,11 @@ :type 'number :group 'comp) +(defcustom comp-always-compile nil + "Unconditionally (re-)compile all files." + :type 'boolean + :group 'comp) + (defconst native-compile-log-buffer "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -1750,6 +1755,37 @@ Prepare every function for final compilation and drive the C back-end." (cl-assert (consp x))) +;; Some entry point support code. + +(defvar comp-src-pool () + "List containing the files to be compiled.") + +(defvar comp-src-pool-mutex (make-mutex) + "Mutex for `comp-src-pool'.") + +(defun comp-to-file-p (file) + "Return t if FILE has to be compiled." + (let ((compiled-f (concat file "n"))) + (or comp-always-compile + (not (and (file-exists-p compiled-f) + (file-newer-than-file-p compiled-f file)))))) + +(defun comp-start-async-worker () + "Start an async compiler worker." + (make-thread + (lambda () + (let (f) + (while (setf f (with-mutex comp-src-pool-mutex + (pop comp-src-pool))) + (when (comp-to-file-p f) + (let* ((cmd (concat "emacs --batch --eval=" + "'(native-compile \"" f "\")'")) + (prc (start-process-shell-command (concat "async compilation: " f) + "async-compile-buffer" + cmd))) + (while (accept-process-output prc) + (thread-yield))))))))) + ;;; Compiler entry points. ;;;###autoload @@ -1775,6 +1811,25 @@ Return the compilation unit filename." comp-passes) data)) +;;;###autoload +(defun native-compile-async (input &optional jobs recursively) + "Compile INPUT asyncronosly. +INPUT can be either a folder or a file. +JOBS specifies the number of jobs (commands) to run simultaneously (1 default). +Follow folders RECURSIVELY if non nil." + (let ((jobs (or jobs 1)) + (files (if (file-directory-p input) + (if recursively + (directory-files-recursively input "\\.el$") + (directory-files input t "\\.el$")) + (if (file-exists-p input) + (list input) + (error "Input not a file nor directory"))))) + (with-mutex comp-src-pool-mutex + (setf comp-src-pool (nconc files comp-src-pool))) + (cl-loop repeat jobs + do (comp-start-async-worker)))) + (provide 'comp) ;;; comp.el ends here From 13816f14b2f459a97d309f202f218282888e9bc9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 07:42:01 +0100 Subject: [PATCH 0537/1452] propagate compiler settings to the async workers --- lisp/emacs-lisp/comp.el | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a31a82dd4f1..99243fda2c7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -44,7 +44,7 @@ - 1 lite optimizations. - 2 heavy optimizations. - 3 max optimization level, to be used only when necessary. - The compiler can inline within the compilation unit..." + Warning: the compiler is free to perform dangerous optimizations." :type 'number :group 'comp) @@ -1778,8 +1778,12 @@ Prepare every function for final compilation and drive the C back-end." (while (setf f (with-mutex comp-src-pool-mutex (pop comp-src-pool))) (when (comp-to-file-p f) - (let* ((cmd (concat "emacs --batch --eval=" - "'(native-compile \"" f "\")'")) + (let* ((code `(let ((comp-speed ,comp-speed) + (comp-debug ,comp-debug) + (comp-verbose ,comp-verbose)) + (native-compile ,f))) + (cmd (concat "emacs --batch --eval='" + (prin1-to-string code) "'")) (prc (start-process-shell-command (concat "async compilation: " f) "async-compile-buffer" cmd))) From 3bc77cca86fbed8c12fb6c10c51e1237d65c9143 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 13:19:23 +0100 Subject: [PATCH 0538/1452] minimal error handling in load_comp_unit --- src/comp.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 0e190e88874..f72d25a6ba9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3210,7 +3210,9 @@ load_comp_unit (dynlib_handle_ptr handle) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - eassert (SUBRP (subr)); + /* FIXME: This is really not robust in case of subr redefinition. */ + if (!SUBRP (subr)) + error ("Native code load error, subr redefined or wrong relocation."); f_relocs[i] = XSUBR (subr)->function.a0; } else if (!strcmp (f_str, "wrong_type_argument")) { From 37a04737218281fecf7b4e8b9a58839e25f02815 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 17:12:58 +0100 Subject: [PATCH 0539/1452] XFIXNUM return EMACS_INT --- src/comp.c | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index f72d25a6ba9..278bf82e6b4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -55,7 +55,6 @@ along with GNU Emacs. If not, see . */ #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -/* FIXME with call1 */ #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) @@ -1137,8 +1136,8 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) #s(comp-mvar 2 11 t 10 integer t)). */ Lisp_Object callee = FIRST (insn); - EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); + EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + EMACS_INT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } @@ -1352,7 +1351,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ - EMACS_UINT param_n = XFIXNUM (arg[1]); + EMACS_INT param_n = XFIXNUM (arg[1]); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); @@ -1380,7 +1379,7 @@ emit_limple_insn (Lisp_Object insn) C: local[2] = list (nargs - 2, args); */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); + EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1753,7 +1752,7 @@ emit_ctxt_code (void) declare_runtime_imported_data (); /* Imported objects. */ - EMACS_UINT d_reloc_len = + EMACS_INT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); Lisp_Object d_reloc = Fnreverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); @@ -1775,7 +1774,7 @@ emit_ctxt_code (void) /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported_funcs (); - EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_runtime)); + EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); /* Imported subrs. */ Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); @@ -2595,7 +2594,7 @@ define_PSEUDOVECTORP (void) comp.block = ret_false_b; gcc_jit_block_end_with_return (ret_false_b, NULL, - gcc_jit_context_new_rvalue_from_int( + gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.bool_type, false)); @@ -3191,9 +3190,9 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported data. */ Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); - EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); + EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); - for (EMACS_UINT i = 0; i < d_vec_len; i++) + for (EMACS_INT i = 0; i < d_vec_len; i++) { data_relocs[i] = AREF (d_vec, i); prevent_gc (data_relocs[i]); @@ -3202,8 +3201,8 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported functions. */ Lisp_Object f_vec = load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); - EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); - for (EMACS_UINT i = 0; i < f_vec_len; i++) + EMACS_INT f_vec_len = XFIXNUM (Flength (f_vec)); + for (EMACS_INT i = 0; i < f_vec_len; i++) { Lisp_Object f_sym = AREF (f_vec, i); char *f_str = SSDATA (SYMBOL_NAME (f_sym)); From 7c9a3556e3d66c1ebe75f675341117bb28041da8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 17:32:27 +0100 Subject: [PATCH 0540/1452] better FUNCALL1 name --- src/comp.c | 69 +++++++++++++++++++++++++++--------------------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/src/comp.c b/src/comp.c index 278bf82e6b4..6b00e1a429f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -55,7 +55,8 @@ along with GNU Emacs. If not, see . */ #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#define FUNCALL1(fun, arg) \ +/* Like call1 but stringify and intern. */ +#define CALL1I(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) #define DECL_BLOCK(name, func) \ @@ -283,9 +284,9 @@ declare_block (Lisp_Object block_name) static gcc_jit_lvalue * get_slot (Lisp_Object mvar) { - EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar)); + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); gcc_jit_lvalue **frame = - (FUNCALL1 (comp-mvar-ref, mvar) || SPEED < 2) + (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; return frame[slot_n]; } @@ -806,7 +807,7 @@ emit_const_lisp_obj (Lisp_Object obj) comp.void_ptr_type, NULL)); - Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); + Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -1021,8 +1022,8 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { - Lisp_Object const_vld = FUNCALL1 (comp-mvar-const-vld, mvar); - Lisp_Object constant = FUNCALL1 (comp-mvar-constant, mvar); + Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); + Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); if (!NILP (const_vld)) { @@ -1137,7 +1138,7 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_INT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); + EMACS_INT base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } @@ -1379,7 +1380,7 @@ emit_limple_insn (Lisp_Object insn) C: local[2] = list (nargs - 2, args); */ - EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0])); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1463,7 +1464,7 @@ static gcc_jit_rvalue * emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = { emit_mvar_val (SECOND (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -1478,7 +1479,7 @@ static gcc_jit_rvalue * emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = { emit_mvar_val (SECOND (insn)), emit_mvar_val (THIRD (insn)), @@ -1652,10 +1653,10 @@ static void declare_runtime_imported_data (void) { /* Imported symbols by inliner functions. */ - FUNCALL1 (comp-add-const-to-relocs, Qnil); - FUNCALL1 (comp-add-const-to-relocs, Qt); - FUNCALL1 (comp-add-const-to-relocs, Qconsp); - FUNCALL1 (comp-add-const-to-relocs, Qlistp); + CALL1I (comp-add-const-to-relocs, Qnil); + CALL1I (comp-add-const-to-relocs, Qt); + CALL1I (comp-add-const-to-relocs, Qconsp); + CALL1I (comp-add-const-to-relocs, Qlistp); } /* @@ -1667,11 +1668,11 @@ declare_runtime_imported_funcs (void) { /* For subr imported by the runtime we rely on the standard mechanism in place for functions imported by lisp code. */ - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1+")); - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); - FUNCALL1 (comp-add-subr-to-relocs, Qplus); - FUNCALL1 (comp-add-subr-to-relocs, Qminus); - FUNCALL1 (comp-add-subr-to-relocs, Qlist); + CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); + CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); + CALL1I (comp-add-subr-to-relocs, Qplus); + CALL1I (comp-add-subr-to-relocs, Qminus); + CALL1I (comp-add-subr-to-relocs, Qlist); Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ @@ -1753,9 +1754,9 @@ emit_ctxt_code (void) declare_runtime_imported_data (); /* Imported objects. */ EMACS_INT d_reloc_len = - XFIXNUM (FUNCALL1 (hash-table-count, - FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - Lisp_Object d_reloc = Fnreverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + XFIXNUM (CALL1I (hash-table-count, + CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + Lisp_Object d_reloc = Fnreverse (CALL1I (comp-ctxt-data-relocs-l, Vcomp_ctxt)); d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = @@ -1777,7 +1778,7 @@ emit_ctxt_code (void) EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); /* Imported subrs. */ - Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); + Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); f_reloc_len += XFIXNUM (Flength (f_subr)); gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); @@ -2702,14 +2703,14 @@ static void declare_function (Lisp_Object func) { gcc_jit_function *gcc_func; - char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); - Lisp_Object args = FUNCALL1 (comp-func-args, func); - bool nargs = (FUNCALL1 (comp-nargs-p, args)); + char *c_name = SSDATA (CALL1I (comp-func-c-func-name, func)); + Lisp_Object args = CALL1I (comp-func-args, func); + bool nargs = (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; if (!nargs) { - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); for (unsigned i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; @@ -2747,7 +2748,7 @@ declare_function (Lisp_Object func) c_name, 2, param, 0); } - Fputhash (FUNCALL1 (comp-func-symbol-name, func), + Fputhash (CALL1I (comp-func-symbol-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); @@ -2758,9 +2759,9 @@ static void compile_function (Lisp_Object func) { USE_SAFE_ALLOCA; - EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); - comp.func = xmint_pointer (Fgethash (FUNCALL1 (comp-func-symbol-name, func), + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-symbol-name, func), comp.exported_funcs_h, Qnil)); gcc_jit_lvalue *frame_array = @@ -2813,7 +2814,7 @@ compile_function (Lisp_Object func) /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ declare_block (Qentry); - Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); + Lisp_Object blocks = CALL1I (comp-func-blocks, func); Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); for (ptrdiff_t i = 0; i < ht->count; i++) @@ -2827,7 +2828,7 @@ compile_function (Lisp_Object func) { Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); - Lisp_Object insns = FUNCALL1 (comp-block-insns, block); + Lisp_Object insns = CALL1I (comp-block-insns, block); ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty"); comp.block = retrive_block (block_name); @@ -2841,7 +2842,7 @@ compile_function (Lisp_Object func) const char *err = gcc_jit_context_get_first_error (comp.ctxt); ICE_IF (err, format_string ("failing to compile function %s with error: %s", - SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), + SSDATA (SYMBOL_NAME (CALL1I (comp-func-symbol-name, func))), err)); SAFE_FREE (); } @@ -3058,7 +3059,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_negate (); struct Lisp_Hash_Table *func_h - = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); + = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) declare_function (HASH_VALUE (func_h, i)); /* Compile all functions. Can't be done before because the From 009089f0d69a26e9779628e5b9c1d139eddf20d2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 17:46:34 +0100 Subject: [PATCH 0541/1452] chasing GNU style --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 73 +++++++++++++++++++++-------------------- 2 files changed, 38 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99243fda2c7..bf373e0b022 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1428,7 +1428,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (aref in-frame slot-n))) )) + collect (aref in-frame slot-n))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for (op . args) in (comp-block-insns b) diff --git a/src/comp.c b/src/comp.c index 6b00e1a429f..ffe0ee81e13 100644 --- a/src/comp.c +++ b/src/comp.c @@ -57,11 +57,11 @@ along with GNU Emacs. If not, see . */ /* Like call1 but stringify and intern. */ #define CALL1I(fun, arg) \ - CALLN (Ffuncall, intern_c_string (STR(fun)), arg) + CALLN (Ffuncall, intern_c_string (STR (fun)), arg) #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ - gcc_jit_function_new_block ((func), STR(name)) + gcc_jit_function_new_block ((func), STR (name)) #ifdef HAVE__SETJMP #define SETJMP _setjmp @@ -72,11 +72,11 @@ along with GNU Emacs. If not, see . */ #define ICE_IF(test, msg) \ do { \ - if (test) \ - ice (msg); \ + if (test) \ + ice (msg); \ } while (0) -/* C side of the compiler context. */ +/* C side of the compiler context. */ typedef struct { gcc_jit_context *ctxt; @@ -340,10 +340,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[i] = comp.lisp_obj_type; } - /* String containing the function ptr name. */ + /* String containing the function ptr name. */ Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); + subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = gcc_jit_context_new_function_ptr_type (comp.ctxt, @@ -381,7 +381,8 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, xmint_pointer (func), nargs, args); - } else { + } + else { gcc_jit_lvalue *f_ptr = gcc_jit_lvalue_access_field (comp.func_relocs, NULL, @@ -402,9 +403,9 @@ emit_call_ref (Lisp_Object subr_sym, unsigned nargs, gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = - { gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs), + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); } @@ -757,7 +758,7 @@ emit_NUMBERP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, - emit_INTEGERP(obj), + emit_INTEGERP (obj), emit_cast (comp.bool_type, emit_FLOATP (obj))); } @@ -962,7 +963,7 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { emit_comment ("XSETCAR"); - gcc_jit_block_add_assignment( + gcc_jit_block_add_assignment ( comp.block, NULL, gcc_jit_rvalue_dereference ( @@ -976,7 +977,7 @@ emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { emit_comment ("XSETCDR"); - gcc_jit_block_add_assignment( + gcc_jit_block_add_assignment ( comp.block, NULL, gcc_jit_rvalue_dereference ( @@ -1033,9 +1034,9 @@ emit_mvar_val (Lisp_Object mvar) (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = - gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - constant); + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + constant); return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ @@ -1079,7 +1080,7 @@ emit_set_internal (Lisp_Object args) gcc_args, false); } -/* This is for a regular function with arguments as m-var. */ +/* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) @@ -1192,7 +1193,7 @@ emit_limple_insn (Lisp_Object insn) if (EQ (op, Qjump)) { - /* Unconditional branch. */ + /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg[0]); gcc_jit_block_end_with_jump (comp.block, NULL, target); } @@ -1230,7 +1231,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qphi)) { - /* Nothing to do for phis into the backend. */ + /* Nothing to do for phis into the backend. */ } else if (EQ (op, Qpush_handler)) { @@ -1266,7 +1267,7 @@ emit_limple_insn (Lisp_Object insn) NULL, comp.m_handlerlist); - gcc_jit_block_add_assignment( + gcc_jit_block_add_assignment ( comp.block, NULL, m_handlerlist, @@ -1294,14 +1295,14 @@ emit_limple_insn (Lisp_Object insn) comp.block, NULL, m_handlerlist, - gcc_jit_lvalue_as_rvalue( + gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_next_field))); emit_frame_assignment ( arg[0], - gcc_jit_lvalue_as_rvalue( + gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, @@ -1667,7 +1668,7 @@ static Lisp_Object declare_runtime_imported_funcs (void) { /* For subr imported by the runtime we rely on the standard mechanism in place - for functions imported by lisp code. */ + for functions imported by lisp code. */ CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); CALL1I (comp-add-subr-to-relocs, Qplus); @@ -1760,7 +1761,7 @@ emit_ctxt_code (void) d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = - gcc_jit_lvalue_as_rvalue( + gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( comp.ctxt, NULL, @@ -1777,7 +1778,7 @@ emit_ctxt_code (void) Lisp_Object f_runtime = declare_runtime_imported_funcs (); EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); - /* Imported subrs. */ + /* Imported subrs. */ Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); f_reloc_len += XFIXNUM (Flength (f_subr)); @@ -1805,7 +1806,7 @@ emit_ctxt_code (void) FIXNUMP (maxarg) ? XFIXNUM (maxarg) : EQ (maxarg, Qmany) ? MANY : UNEVALLED, NULL); - fields [n_frelocs++] = field; + fields[n_frelocs++] = field; f_reloc_list = Fcons (subr_sym, f_reloc_list); } } @@ -2261,7 +2262,7 @@ define_CAR_CDR (void) gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, - f_name [i], + f_name[i], 2, param, 0); gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]); @@ -2865,7 +2866,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, if (NILP (comp.emitter_dispatcher)) { - /* Move this into syms_of_comp the day will be dumpable. */ + /* Move this into syms_of_comp the day will be dumpable. */ comp.emitter_dispatcher = CALLN (Fmake_hash_table); register_emitter (Qset_internal, emit_set_internal); register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret); @@ -2890,7 +2891,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, register_emitter (Qintegerp, emit_integerp); } - comp.ctxt = gcc_jit_context_acquire(); + comp.ctxt = gcc_jit_context_acquire (); if (COMP_DEBUG) { @@ -3016,7 +3017,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, (void) { if (comp.ctxt) - gcc_jit_context_release(comp.ctxt); + gcc_jit_context_release (comp.ctxt); if (logfile) fclose (logfile); @@ -3049,7 +3050,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); /* Define inline functions. */ - define_CAR_CDR(); + define_CAR_CDR (); define_PSEUDOVECTORP (); define_CHECK_TYPE (); define_CHECK_IMPURE (); @@ -3165,7 +3166,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) { static_obj_t *(*f)(void) = dynlib_sym (handle, name); eassert (f); - static_obj_t *res = f(); + static_obj_t *res = f (); return Fread (make_string (res->data, res->len)); } @@ -3284,12 +3285,12 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = SSDATA (Fsymbol_name (name)); x->s.native_elisp = true; - defsubr(x); + defsubr (x); return Qnil; } -/* Load related routines. */ +/* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, doc: /* Load native elisp code FILE. */) (Lisp_Object file) @@ -3382,7 +3383,7 @@ syms_of_comp (void) DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* - The compiler context. */); + The compiler context. */); Vcomp_ctxt = Qnil; /* Load mechanism. */ From fd42b6c696564cdb44999f6d4d3f91a63799191a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 21:03:48 +0100 Subject: [PATCH 0542/1452] make sure to invoke the right emacs when spawning the compiler job --- lisp/emacs-lisp/comp.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bf373e0b022..eab8ffc2166 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -51,6 +51,7 @@ (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. - 0 no debug facility. + This is the raccomanded value unless you are debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." @@ -1288,7 +1289,7 @@ Top level forms for the current context are rendered too." initially (setf changed nil) do (cl-loop for p in (delq new-idom preds) when (comp-block-dom p) - do (setf new-idom (intersect p new-idom))) + do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) do (setf (comp-block-dom b) new-idom) (setf changed t)))))) @@ -1782,7 +1783,8 @@ Prepare every function for final compilation and drive the C back-end." (comp-debug ,comp-debug) (comp-verbose ,comp-verbose)) (native-compile ,f))) - (cmd (concat "emacs --batch --eval='" + (cmd (concat invocation-directory invocation-name + " --batch --eval='" (prin1-to-string code) "'")) (prc (start-process-shell-command (concat "async compilation: " f) "async-compile-buffer" From 0cf4a9fdfc63577c97ff0d0e46f49cd685c5291f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 Nov 2019 22:16:38 +0100 Subject: [PATCH 0543/1452] set intspec to NULL when creating subrs --- src/comp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/comp.c b/src/comp.c index ffe0ee81e13..3cb0fb285bf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3284,6 +3284,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.intspec = NULL; x->s.native_elisp = true; defsubr (x); From 4320307843b44fa049ba7e8217f0349932ff56e5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 12 Nov 2019 19:55:57 +0100 Subject: [PATCH 0544/1452] propagate load-path into async workers + better messaging --- lisp/emacs-lisp/comp.el | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eab8ffc2166..1acb97d1e0a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1779,18 +1779,23 @@ Prepare every function for final compilation and drive the C back-end." (while (setf f (with-mutex comp-src-pool-mutex (pop comp-src-pool))) (when (comp-to-file-p f) - (let* ((code `(let ((comp-speed ,comp-speed) - (comp-debug ,comp-debug) - (comp-verbose ,comp-verbose)) + (let* ((code `(progn + (require 'comp) + (setq comp-speed ,comp-speed) + (setq comp-debug ,comp-debug) + (setq comp-verbose ,comp-verbose) + (setq load-path ',load-path) + (message "Compiling %s started." ,f) (native-compile ,f))) - (cmd (concat invocation-directory invocation-name - " --batch --eval='" - (prin1-to-string code) "'")) - (prc (start-process-shell-command (concat "async compilation: " f) - "async-compile-buffer" - cmd))) + (prc (start-process (concat "Compiling: " f) + "async-compile-buffer" + (concat invocation-directory invocation-name) + "--batch" + "--eval" + (prin1-to-string code)))) (while (accept-process-output prc) - (thread-yield))))))))) + (thread-yield))))))) + "compilation thread")) ;;; Compiler entry points. From 8b8b8539d7415f1decde46d088c89c2fc69b1010 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 12 Nov 2019 19:56:35 +0100 Subject: [PATCH 0545/1452] cleanup unnecessary symbol definition --- src/comp.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 3cb0fb285bf..f92bc62506b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3325,7 +3325,6 @@ syms_of_comp (void) DEFSYM (Qcallref, "callref"); DEFSYM (Qdirect_call, "direct-call"); DEFSYM (Qdirect_callref, "direct-callref"); - DEFSYM (Qncall, "ncall"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); From d8f3f8736c7d36b220a478f98deae9f82f25a4f7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 12 Nov 2019 23:44:02 +0100 Subject: [PATCH 0546/1452] do not compile automatically autoloads --- lisp/emacs-lisp/comp.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1acb97d1e0a..8ee35b03114 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1767,9 +1767,10 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-to-file-p (file) "Return t if FILE has to be compiled." (let ((compiled-f (concat file "n"))) - (or comp-always-compile - (not (and (file-exists-p compiled-f) - (file-newer-than-file-p compiled-f file)))))) + (and (null (string-match-p "autoloads.el" file)) + (or comp-always-compile + (not (and (file-exists-p compiled-f) + (file-newer-than-file-p compiled-f file))))))) (defun comp-start-async-worker () "Start an async compiler worker." From f59a96f5655c0ac2846a06cbad11ef3039476fb0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 12 Nov 2019 23:00:02 +0100 Subject: [PATCH 0547/1452] fix compilation when native compiler is not enabled --- src/pdumper.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/pdumper.c b/src/pdumper.c index 7b3109607b4..38b70146b4f 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) 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); +#ifdef HAVE_NATIVE_COMP DUMP_FIELD_COPY (&out, subr, native_elisp); +#endif return dump_object_finish (ctx, &out, sizeof (out)); } From 06fc663f519eefb431912ebdae8711ed016e0703 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 12 Nov 2019 23:27:09 +0100 Subject: [PATCH 0548/1452] better configure check for libgccjit.h file instead of the shared lib in configure --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index c86dac6a65b..c1e39773300 100644 --- a/configure.ac +++ b/configure.ac @@ -3742,7 +3742,7 @@ HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) + AC_CHECK_HEADER([libgccjit.h], [HAVE_NATIVE_COMP=yes]) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" if test "${HAVE_MODULES}" = yes; then From 0f59ce58fc558643f97175a32f2a82cc209f2bb4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 12 Nov 2019 23:39:24 +0100 Subject: [PATCH 0549/1452] temporary fix subr doc field to zero --- src/comp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/comp.c b/src/comp.c index f92bc62506b..04cee63dfbd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3285,6 +3285,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = SSDATA (Fsymbol_name (name)); x->s.intspec = NULL; + x->s.doc = 0; /* FIXME */ x->s.native_elisp = true; defsubr (x); From 6317f9e7b847f83e6a6d0f9ce9233a0566d84f0c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 13 Nov 2019 22:00:38 +0100 Subject: [PATCH 0550/1452] better error handling into load_comp_unit --- src/comp.c | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 04cee63dfbd..3ffb0db62a8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3170,9 +3170,10 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) return Fread (make_string (res->data, res->len)); } -static int -load_comp_unit (dynlib_handle_ptr handle) +static void +load_comp_unit (dynlib_handle_ptr handle, char *file_name) { + const char *err_msg; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); @@ -3185,7 +3186,10 @@ load_comp_unit (dynlib_handle_ptr handle) && data_relocs && f_relocs && top_level_run)) - return -1; + { + err_msg = "inconsistent eln file."; + goto exit_error; + } *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; @@ -3213,7 +3217,10 @@ load_comp_unit (dynlib_handle_ptr handle) { /* FIXME: This is really not robust in case of subr redefinition. */ if (!SUBRP (subr)) - error ("Native code load error, subr redefined or wrong relocation."); + { + err_msg = format_string ("subr %s redefined or wrong relocation?", f_str); + goto exit_error; + } f_relocs[i] = XSUBR (subr)->function.a0; } else if (!strcmp (f_str, "wrong_type_argument")) { @@ -3253,14 +3260,16 @@ load_comp_unit (dynlib_handle_ptr handle) f_relocs[i] = (void *) specbind; } else { - ice (format_string ("unexpected function relocation %s", f_str)); + err_msg = format_string ("unexpected function relocation %s.", f_str); } } /* Executing this will perform all the expected environment modification. */ top_level_run (); - return 0; + return; +exit_error: + error ("Native code load error while loading %s, %s", file_name, err_msg); } DEFUN ("comp--register-subr", Fcomp__register_subr, @@ -3303,9 +3312,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, if (!handle) xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); - int r = load_comp_unit (handle); - if (r != 0) - xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); + load_comp_unit (handle, SSDATA (file)); load_handle_stack = XCDR (load_handle_stack); @@ -3364,7 +3371,6 @@ syms_of_comp (void) DEFSYM (Qintegerp, "integerp"); /* Returned values. */ DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); - DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); From 9b44051ea530247e73dbc0bdc2998d2dbf9688c1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 13 Nov 2019 21:12:29 +0100 Subject: [PATCH 0551/1452] make load mechanism robust against primitives advises --- src/comp.c | 80 ++++++++++++++++++++++++++---------------------------- 1 file changed, 38 insertions(+), 42 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3ffb0db62a8..9f1317ef70a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3215,53 +3215,49 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - /* FIXME: This is really not robust in case of subr redefinition. */ if (!SUBRP (subr)) { - err_msg = format_string ("subr %s redefined or wrong relocation?", f_str); - goto exit_error; + /* If is not a subr try to recover the original one assuming was + advised. */ + if (!(!NILP (CALL1I (ad-has-any-advice, f_sym)) + && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) + { + /* FIXME: This is not robust in case of primitive + redefinition. */ + err_msg = format_string ("primitive %s redefined " + "or wrong relocation?", + f_str); + goto exit_error; + } } f_relocs[i] = XSUBR (subr)->function.a0; - } else if (!strcmp (f_str, "wrong_type_argument")) - { - f_relocs[i] = (void *) wrong_type_argument; - } else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) - { - f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; - } else if (!strcmp (f_str, "pure_write_error")) - { - f_relocs[i] = (void *) pure_write_error; - } else if (!strcmp (f_str, "push_handler")) - { - f_relocs[i] = (void *) push_handler; - } else if (!strcmp (f_str, SETJMP_NAME)) - { - f_relocs[i] = (void *) SETJMP; - } else if (!strcmp (f_str, "record_unwind_protect_excursion")) - { - f_relocs[i] = (void *) record_unwind_protect_excursion; - } else if (!strcmp (f_str, "helper_unbind_n")) - { - f_relocs[i] = (void *) helper_unbind_n; - } else if (!strcmp (f_str, "helper_save_restriction")) - { - f_relocs[i] = (void *) helper_save_restriction; - } else if (!strcmp (f_str, "record_unwind_current_buffer")) - { - f_relocs[i] = (void *) record_unwind_current_buffer; - } else if (!strcmp (f_str, "set_internal")) - { - f_relocs[i] = (void *) set_internal; - } else if (!strcmp (f_str, "helper_unwind_protect")) - { - f_relocs[i] = (void *) helper_unwind_protect; - } else if (!strcmp (f_str, "specbind")) - { - f_relocs[i] = (void *) specbind; - } else - { - err_msg = format_string ("unexpected function relocation %s.", f_str); } + else if (!strcmp (f_str, "wrong_type_argument")) + f_relocs[i] = (void *) wrong_type_argument; + else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) + f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; + else if (!strcmp (f_str, "pure_write_error")) + f_relocs[i] = (void *) pure_write_error; + else if (!strcmp (f_str, "push_handler")) + f_relocs[i] = (void *) push_handler; + else if (!strcmp (f_str, SETJMP_NAME)) + f_relocs[i] = (void *) SETJMP; + else if (!strcmp (f_str, "record_unwind_protect_excursion")) + f_relocs[i] = (void *) record_unwind_protect_excursion; + else if (!strcmp (f_str, "helper_unbind_n")) + f_relocs[i] = (void *) helper_unbind_n; + else if (!strcmp (f_str, "helper_save_restriction")) + f_relocs[i] = (void *) helper_save_restriction; + else if (!strcmp (f_str, "record_unwind_current_buffer")) + f_relocs[i] = (void *) record_unwind_current_buffer; + else if (!strcmp (f_str, "set_internal")) + f_relocs[i] = (void *) set_internal; + else if (!strcmp (f_str, "helper_unwind_protect")) + f_relocs[i] = (void *) helper_unwind_protect; + else if (!strcmp (f_str, "specbind")) + f_relocs[i] = (void *) specbind; + else + err_msg = format_string ("unexpected function relocation %s.", f_str); } /* Executing this will perform all the expected environment modification. */ From 0f526028b1830e72df1c39220c5efdc7e545885b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 13 Nov 2019 21:25:00 +0100 Subject: [PATCH 0552/1452] do not compile if there's nothing to --- lisp/emacs-lisp/comp.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8ee35b03114..d62b4cbbe1a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -433,6 +433,8 @@ Put PREFIX in front of it." (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) + (unless byte-to-native-top-level-forms + (error "Empty byte compiler output")) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. @@ -1767,10 +1769,9 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-to-file-p (file) "Return t if FILE has to be compiled." (let ((compiled-f (concat file "n"))) - (and (null (string-match-p "autoloads.el" file)) - (or comp-always-compile - (not (and (file-exists-p compiled-f) - (file-newer-than-file-p compiled-f file))))))) + (or comp-always-compile + (not (and (file-exists-p compiled-f) + (file-newer-than-file-p compiled-f file)))))) (defun comp-start-async-worker () "Start an async compiler worker." From a1fd3d6eacaf425eadd121dcacee95a26f96505f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 Nov 2019 21:36:30 +0100 Subject: [PATCH 0553/1452] improve subr-native-elisp-p --- src/data.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/data.c b/src/data.c index 2a32d47c49b..50dce9e4644 100644 --- a/src/data.c +++ b/src/data.c @@ -866,12 +866,11 @@ SUBR must be a built-in function. */) #ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, - doc: /* Return t if the subr is native compiled elisp, + doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) - (Lisp_Object subr) + (Lisp_Object object) { - CHECK_SUBR (subr); - return XSUBR (subr)->native_elisp ? Qt : Qnil; + return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; } #endif From 787444c7690d97d8702db059cb51ac506cb8a5e4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 Nov 2019 18:01:00 +0100 Subject: [PATCH 0554/1452] fix max depth compilation --- src/eval.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/eval.c b/src/eval.c index 4559a0e1f66..bf37ed9cefa 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,8 +219,14 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ +#ifndef HAVE_NATIVE_COMP max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ max_lisp_eval_depth = 800; +#else + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; +#endif Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } From b91cbf80aeb4487ad3e1fa0e64e3cb5549ec663c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 16 Nov 2019 09:58:05 +0100 Subject: [PATCH 0555/1452] add comp-tests-bootstrap --- test/src/comp-tests.el | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2e388b9f148..1f43a91d49c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -32,13 +32,37 @@ (setq comp-speed 3) (setq comp-debug 1) +(defconst comp-test-directory (file-name-directory (or load-file-name + buffer-file-name))) (defconst comp-test-src - (concat (file-name-directory (or load-file-name buffer-file-name)) - "comp-test-funcs.el")) + (concat comp-test-directory "comp-test-funcs.el")) (message "Compiling %s" comp-test-src) (load (native-compile comp-test-src)) +(ert-deftest comp-tests-bootstrap () + "Compile the compiler and load it to compile it-self. +Check that the resulting binaries do not differ." + (let ((comp-file (concat comp-test-directory + "../../lisp/emacs-lisp/comp.el")) + (comp1-file (concat temporary-file-directory + (make-temp-name "stage1-") + ".el")) + (comp2-file (concat temporary-file-directory + (make-temp-name "stage2-") + ".el"))) + (copy-file comp-file comp1-file) + (copy-file comp-file comp2-file) + (load (concat comp-file "c") nil nil t t) + (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) + (message "Compiling stage1...") + (load (native-compile comp1-file) nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (native-compile comp2-file) + (message "Comparing %s %s" comp1-file comp2-file) + (should (= (call-process "cmp" nil nil nil comp1-file comp2-file) 0)))) + (ert-deftest comp-tests-provide () "Testing top level provide." (should (featurep 'comp-test-funcs))) From 11b34169f802908348e99d0a52b9c50a64028964 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 16 Nov 2019 15:12:37 +0100 Subject: [PATCH 0556/1452] add comp-tests-trampoline-removal --- test/src/comp-test-funcs.el | 3 +++ test/src/comp-tests.el | 5 +++++ 2 files changed, 8 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5f33eacdb2f..214e07e6dde 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -241,6 +241,9 @@ (defun comp-tests-string-trim-f (url) (string-trim url)) +(defun comp-tests-trampoline-removal-f () + (make-hash-table)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1f43a91d49c..34d00896b4f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -306,6 +306,11 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-string-trim () (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) +(ert-deftest comp-tests-trampoline-removal () + ;; This tests that we can can call primitives with no dedicated bytecode. + ;; At speed >= 2 the trampoline will not be used. + (should (hash-table-p (comp-tests-trampoline-removal-f)))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 4bb671f1c6adb6cbdcf90abe73967c24e5296372 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 16 Nov 2019 15:23:28 +0100 Subject: [PATCH 0557/1452] fix emit_limple_call_ref for 0 args case --- src/comp.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 9f1317ef70a..d05d17bd010 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1139,7 +1139,9 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_INT base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); + EMACS_INT base_ptr = 0; + if (nargs) + base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } From a82f1929fef5072a4b04e326b467cca8a8a21c0e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 16 Nov 2019 15:24:35 +0100 Subject: [PATCH 0558/1452] rework comp-callref lambda list --- lisp/emacs-lisp/comp.el | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d62b4cbbe1a..40125103024 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -566,12 +566,13 @@ The basic block is returned regardless it was already declared or not." (comp-add-subr-to-relocs func) `(call ,func ,@args)) -(defun comp-callref (func &rest args) - "Emit a call usign narg abi for FUNC with ARGS." +(defun comp-callref (func nargs stack-off) + "Emit a call usign narg abi for FUNC. +NARGS is the number of arguments. +STACK-OFF is the index of the first slot frame involved." (comp-add-subr-to-relocs func) - `(callref ,func ,@(cl-loop with (nargs off) = args - repeat nargs - for sp from off + `(callref ,func ,@(cl-loop repeat nargs + for sp from stack-off collect (comp-slot-n sp)))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) From 76fcc2a69a96a7ab68b82ebc96c234dd58ef7e61 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 16 Nov 2019 15:25:01 +0100 Subject: [PATCH 0559/1452] emit_limple_push_handler style fix --- src/comp.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index d05d17bd010..066440bcf87 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1156,11 +1156,11 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( - comp.block, - NULL, - comp.loc_handler, - emit_call (intern_c_string ("push_handler"), - comp.handler_ptr_type, 2, args, false)); + comp.block, + NULL, + comp.loc_handler, + emit_call (intern_c_string ("push_handler"), + comp.handler_ptr_type, 2, args, false)); args[0] = gcc_jit_lvalue_get_address ( From 3d0a3a51b8f1635ec872fc3f0a54c2d58ba48b4e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 11:19:17 +0100 Subject: [PATCH 0560/1452] fix configure.ac --- configure.ac | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index c1e39773300..03570bd6c90 100644 --- a/configure.ac +++ b/configure.ac @@ -3753,6 +3753,11 @@ if test "${with_nativecomp}" != "no"; then AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) + else + AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. +If you are sure you want Emacs compiled without elisp native compiler, pass + --without-nativecomp +to configure.]) fi fi AC_SUBST(LIBGCCJIT_LIB) @@ -5737,7 +5742,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? ${with_nativecomp} + Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} "]) if test -n "${EMACSDATA}"; then From f7c52087b2a836ab8913b7718ad37230a2895ef3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 11:20:29 +0100 Subject: [PATCH 0561/1452] do not force compiler settings within the testsuite --- test/src/comp-tests.el | 3 --- 1 file changed, 3 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 34d00896b4f..2a4c849a7c8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,9 +29,6 @@ (require 'cl-lib) (require 'comp) -(setq comp-speed 3) -(setq comp-debug 1) - (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) (defconst comp-test-src From 13f3b52fa422bed85fd7d50b43a167bb011e9070 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 11:48:30 +0100 Subject: [PATCH 0562/1452] always name the compilation unit responsible for the error --- lisp/emacs-lisp/comp.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 40125103024..e279713523a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1819,10 +1819,12 @@ Return the compilation unit filename." (symbol-name input) (file-name-sans-extension (expand-file-name input)))))) (comp-log "\n \n" 1) - (mapc (lambda (pass) - (comp-log (format "Running pass %s:\n" pass) 2) - (setq data (funcall pass data))) - comp-passes) + (condition-case err + (mapc (lambda (pass) + (comp-log (format "Running pass %s:\n" pass) 2) + (setq data (funcall pass data))) + comp-passes) + (error (error "While compiling %s: %s" input (error-message-string err)))) data)) ;;;###autoload From 437c75cfcda4a0e9fd387d22aa8c0177c835c66b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 12:01:59 +0100 Subject: [PATCH 0563/1452] add native-units-loaded --- src/comp.c | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 066440bcf87..2638290859f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3305,6 +3305,12 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, (Lisp_Object file) { CHECK_STRING (file); + + if (NILP (Fhash_table_p (Vnative_units_loaded))) + Vnative_units_loaded = CALLN (Fmake_hash_table, QCtest, Qequal); + + Fputhash (file, Qt, Vnative_units_loaded); + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) @@ -3387,10 +3393,14 @@ syms_of_comp (void) comp.emitter_dispatcher = Qnil; DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, - doc: /* - The compiler context. */); + doc: /* The compiler context. */); Vcomp_ctxt = Qnil; + DEFVAR_LISP ("native-units-loaded", Vnative_units_loaded, + doc: /* Hash table containing all the currently loaded + compilation units file names. */); + Vnative_units_loaded = Qnil; + /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); Vnative_elisp_refs_hash From ab3f36fac2da2979713109561f086d95bb26d580 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 12:46:21 +0100 Subject: [PATCH 0564/1452] style nit into load_comp_unit --- src/comp.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2638290859f..e5d703f769f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3217,20 +3217,18 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - if (!SUBRP (subr)) - { + if (!SUBRP (subr) /* If is not a subr try to recover the original one assuming was advised. */ - if (!(!NILP (CALL1I (ad-has-any-advice, f_sym)) - && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) - { - /* FIXME: This is not robust in case of primitive - redefinition. */ - err_msg = format_string ("primitive %s redefined " - "or wrong relocation?", - f_str); - goto exit_error; - } + && !(!NILP (CALL1I (ad-has-any-advice, f_sym)) + && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) + { + /* FIXME: This is not robust in case of primitive + redefinition. */ + err_msg = format_string ("primitive %s redefined " + "or wrong relocation?", + f_str); + goto exit_error; } f_relocs[i] = XSUBR (subr)->function.a0; } From f6b58e8016c7ce7b332a3b2a8a56bd2f9987d95a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 14:03:10 +0100 Subject: [PATCH 0565/1452] message when finished compiling --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e279713523a..859e0dedd9c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1797,7 +1797,8 @@ Prepare every function for final compilation and drive the C back-end." "--eval" (prin1-to-string code)))) (while (accept-process-output prc) - (thread-yield))))))) + (thread-yield))))) + (message "Finished compiling."))) "compilation thread")) ;;; Compiler entry points. From 6a546e63d0134861b208ab1bac259f71fcb30b83 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 14:17:59 +0100 Subject: [PATCH 0566/1452] remove old eln before creating a new one to prevent crashes --- src/comp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.c b/src/comp.c index e5d703f769f..cbf38de29af 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3078,8 +3078,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); + Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); + /* Remove the old eln before creating the new one to get a new inode and + prevent crashes in case the old one is currently loaded. */ + if (!NILP (Ffile_exists_p (out_file))) + Fdelete_file (out_file, Qnil); + gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (out_file)); From 207b15147366be47d58c40a6f03888243602b11e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 16:04:25 +0100 Subject: [PATCH 0567/1452] Vnative_units_loaded -> Vnative_load_history --- src/comp.c | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index cbf38de29af..1de24eaaf98 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3310,10 +3310,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); - if (NILP (Fhash_table_p (Vnative_units_loaded))) - Vnative_units_loaded = CALLN (Fmake_hash_table, QCtest, Qequal); - - Fputhash (file, Qt, Vnative_units_loaded); + Vnative_load_history = Fcons (file, Vnative_load_history); dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); @@ -3400,10 +3397,9 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - DEFVAR_LISP ("native-units-loaded", Vnative_units_loaded, - doc: /* Hash table containing all the currently loaded - compilation units file names. */); - Vnative_units_loaded = Qnil; + DEFVAR_LISP ("native-load-history", Vnative_load_history, + doc: /* List with the history of the eln loaded. */); + Vnative_load_history = Qnil; /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); From 065dd0b5c6a7e11e79fe5ec02b153bb53bde0e77 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 16:38:07 +0100 Subject: [PATCH 0568/1452] better error signaling while loading --- src/comp.c | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1de24eaaf98..33c39b53467 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,6 +70,8 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME STR (SETJMP) +/* Raise an internal compiler error if test. + msg is evaluated only in that case. */ #define ICE_IF(test, msg) \ do { \ if (test) \ @@ -3271,7 +3273,9 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) return; exit_error: - error ("Native code load error while loading %s, %s", file_name, err_msg); + xsignal1 (Qcomp_unit_load_failed, + build_string (format_string ("while loading %s, %s", + file_name, err_msg))); } DEFUN ("comp--register-subr", Fcomp__register_subr, @@ -3284,7 +3288,9 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) - error ("comp--register-subr can only be called during native code load phase."); + xsignal1 (Qcomp_unit_load_failed, + build_string ("comp--register-subr can only be called during " + "native code load phase.")); void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); @@ -3315,7 +3321,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) - xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); + xsignal2 (Qcomp_unit_load_failed, file, build_string (dynlib_error ())); load_comp_unit (handle, SSDATA (file)); @@ -3374,8 +3380,8 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); - /* Returned values. */ - DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); + /* To be signaled. */ + DEFSYM (Qcomp_unit_load_failed, "comp-unit-load-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); From 3850be836ec7223c895901dd21f2a4e429314b94 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 18:39:22 +0100 Subject: [PATCH 0569/1452] make compilation too robust against advices --- src/comp.c | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 33c39b53467..ad669a5dafb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -224,6 +224,20 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } +static Lisp_Object +symbol_subr (Lisp_Object symbol) +{ + Lisp_Object subr = Fsymbol_function (symbol); + + if (SUBRP (subr)) + return subr; + + if (!NILP (CALL1I (ad-has-any-advice, symbol))) + subr = CALL1I (ad-get-orig-definition, symbol); + + return SUBRP (subr) ? subr : Qnil; +} + static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -1800,7 +1814,7 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_subr) { Lisp_Object subr_sym = XCAR (f_subr); - Lisp_Object subr = Fsymbol_function (subr_sym); + Lisp_Object subr = symbol_subr (subr_sym); /* Ignore inliners. This are not real functions to be imported. */ if (SUBRP (subr)) { @@ -3225,11 +3239,8 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - if (!SUBRP (subr) - /* If is not a subr try to recover the original one assuming was - advised. */ - && !(!NILP (CALL1I (ad-has-any-advice, f_sym)) - && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) + subr = symbol_subr (f_sym); + if (NILP (subr)) { /* FIXME: This is not robust in case of primitive redefinition. */ From 41e5c9400cd9eeeecff2262907c09c3b10a5cde7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 19:25:21 +0100 Subject: [PATCH 0570/1452] require advice when compiling or loading --- src/comp.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/comp.c b/src/comp.c index ad669a5dafb..251ba242d43 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3052,6 +3052,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, { CHECK_STRING (ctxtname); + Frequire (Qadvice, Qnil, Qnil); + gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); @@ -3327,6 +3329,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); + Frequire (Qadvice, Qnil, Qnil); + Vnative_load_history = Fcons (file, Vnative_load_history); dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); @@ -3395,6 +3399,7 @@ syms_of_comp (void) DEFSYM (Qcomp_unit_load_failed, "comp-unit-load-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); + DEFSYM (Qadvice, "advice"); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); From 77c9236957a195a4ad0f50e8f19653a5c6918c8e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 07:26:14 +0100 Subject: [PATCH 0571/1452] add comp-tests-signal --- test/src/comp-test-funcs.el | 4 ++++ test/src/comp-tests.el | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 214e07e6dde..3ba12dc2a6a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -244,6 +244,10 @@ (defun comp-tests-trampoline-removal-f () (make-hash-table)) +(defun comp-tests-signal-f () + (signal 'foo t)) + + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2a4c849a7c8..a76a4a8c469 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -308,6 +308,12 @@ Check that the resulting binaries do not differ." ;; At speed >= 2 the trampoline will not be used. (should (hash-table-p (comp-tests-trampoline-removal-f)))) +(ert-deftest comp-tests-signal () + (should (equal (condition-case err + (comp-tests-signal-f) + (t err)) + '(foo . t)))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; From 41bfb91f5db878d139d5c0c631c569475018a7c2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 08:16:53 +0100 Subject: [PATCH 0572/1452] add comp-tests-jump-table-2-f --- test/src/comp-test-funcs.el | 5 +++++ test/src/comp-tests.el | 6 +++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 3ba12dc2a6a..ca604b748f3 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -111,6 +111,11 @@ ('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)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a76a4a8c469..0a1d45724fa 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -168,7 +168,11 @@ Check that the resulting binaries do not differ." "Testing jump tables" (should (eq (comp-tests-jump-table-1-f 'x) 'a)) (should (eq (comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)) + + ;; Jump table not with eq as test + (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) + (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) (ert-deftest comp-tests-conditionals () "Testing conditionals." From 42b08f8a9ada7791c992894e88f648909e1ecc95 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Nov 2019 23:23:50 +0100 Subject: [PATCH 0573/1452] some style nits --- src/comp.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/comp.c b/src/comp.c index 251ba242d43..8001580eba2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -398,20 +398,21 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, nargs, args); } - else { - gcc_jit_lvalue *f_ptr = - gcc_jit_lvalue_access_field (comp.func_relocs, - NULL, - (gcc_jit_field *) xmint_pointer (func)); - ICE_IF (!f_ptr, "undeclared function relocation"); - emit_comment (format_string ("calling subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); - return gcc_jit_context_new_call_through_ptr (comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (f_ptr), - nargs, - args); - } + else + { + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (func)); + ICE_IF (!f_ptr, "undeclared function relocation"); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); + } } static gcc_jit_rvalue * @@ -481,8 +482,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } /* - Emit the equivalent of - + Emit the equivalent of: (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ @@ -1046,8 +1046,8 @@ emit_mvar_val (Lisp_Object mvar) { if (FIXNUMP (constant)) { - /* We can still emit directly objects that are selfcontained in a word - (read fixnums). */ + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, @@ -1168,7 +1168,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) { - /* struct handler *c = push_handler (POP, type); */ + /* struct handler *c = push_handler (POP, type); */ gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( From a99a3fbc40076aa3965feb759e816a8a25621c6a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 18 Nov 2019 00:05:55 +0100 Subject: [PATCH 0574/1452] fix jump table emission when test fn is not eq --- lisp/emacs-lisp/comp.el | 33 +++++++++++++++++++++++---------- src/comp.c | 12 ++++++++++++ 2 files changed, 35 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 859e0dedd9c..f805540fcd4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -256,7 +256,8 @@ structure.") (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum - :documentation "Slot number.") + :documentation "Slot number. +-1 is a special value and indicates the scratch slot.") (id nil :type (or null number) :documentation "SSA number.") (const-vld nil :type boolean @@ -712,12 +713,15 @@ Return value is the fall through block name." (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." + ;; FIXME this not efficent for big jump tables. We should have a second + ;; strategy for this case. (pcase last-insn - (`(setimm ,_ ,_ ,const) + (`(setimm ,_ ,_ ,jmp-table) (cl-loop - for test being each hash-keys of const + for test being each hash-keys of jmp-table using (hash-value target-label) - with len = (hash-table-count const) + with len = (hash-table-count jmp-table) + with test-func = (hash-table-test jmp-table) for n from 1 for last = (= n len) for m-test = (make-comp-mvar :constant test) @@ -730,12 +734,21 @@ Return value is the fall through block name." (comp-sp) (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) - do - (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) - (unless last - ;; All fall through are artificially created here except the last one. - (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) - (setf (comp-limplify-curr-block comp-pass) ff-bb)))) + if (eq test-func 'eq) + do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + else + ;; Store the result of the comparison into the scratch slot before + ;; emitting the conditional jump. + do (comp-emit (list 'set (make-comp-mvar :slot -1) + (comp-call test-func var m-test))) + (comp-emit (list 'cond-jump + (make-comp-mvar :slot -1) + (make-comp-mvar :constant nil) + target-name ff-bb-name)) + do (unless last + ;; All fall through are artificially created here except the last one. + (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) diff --git a/src/comp.c b/src/comp.c index 8001580eba2..3687bdb86a9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -146,6 +146,7 @@ typedef struct { gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ + gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -301,6 +302,15 @@ static gcc_jit_lvalue * get_slot (Lisp_Object mvar) { EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); + if (slot_n == -1) + { + if (!comp.scratch) + comp.scratch = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "scratch"); + return comp.scratch; + } gcc_jit_lvalue **frame = (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; @@ -2823,6 +2833,8 @@ compile_function (Lisp_Object func) format_string ("local%u", i)); } + comp.scratch = NULL; + comp.loc_handler = gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, From 16fe8a4678d20eac893bd05941071396b67bc84d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 18 Nov 2019 19:35:44 +0100 Subject: [PATCH 0575/1452] allow for pure function call removal optimization --- lisp/emacs-lisp/comp.el | 31 ++++++++++++++++++++++--------- test/src/comp-test-funcs.el | 5 +++++ test/src/comp-tests.el | 5 +++++ 3 files changed, 32 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f805540fcd4..b6a3662ec5d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1472,6 +1472,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;;; propagate pass specific code. ;; A very basic propagation pass follows. +;; This propagates values and types plus in the control flow graph. +;; Is also responsible for removing function calls to pure functions when +;; possible. (defsubst comp-strict-type-of (obj) "Given OBJ return its type understanding fixnums." @@ -1506,29 +1509,39 @@ This can run just once." for insn in (comp-block-insns b) do (pcase insn (`(setimm ,lval ,_ ,v) - (setf (comp-mvar-const-vld lval) t) - (setf (comp-mvar-constant lval) v) - (setf (comp-mvar-type lval) (comp-strict-type-of v))))))) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) v + (comp-mvar-type lval) (comp-strict-type-of v))))))) (defsubst comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) - (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) - (setf (comp-mvar-type lval) (comp-mvar-type rval))) + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval) + (comp-mvar-constant lval) (comp-mvar-constant rval) + (comp-mvar-type lval) (comp-mvar-type rval))) + +(defsubst comp-function-call-remove (insn f args) + "Given INSN when F is pure if all ARGS are known remove the function call." + (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el + (cl-every #'comp-mvar-const-vld args)) + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + (setf (car insn) 'setimm + (caddr insn) (comp-add-const-to-relocs val))))) (defun comp-propagate-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval - (`(,(or 'call 'direct-call) ,f . ,_) + (`(,(or 'call 'direct-call) ,f . ,args) (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types))) + (alist-get f comp-known-ret-types)) + (comp-function-call-remove insn f args)) (`(,(or 'callref 'direct-callref) ,f . ,args) (cl-loop for v in args do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types))) + (alist-get f comp-known-ret-types)) + (comp-function-call-remove insn f args)) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index ca604b748f3..20d15ac0e7a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -252,6 +252,11 @@ (defun comp-tests-signal-f () (signal 'foo t)) +(defun comp-tests-func-call-removal-f () + (let ((a 10) + (b 3)) + (% a b))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0a1d45724fa..b008dbd574e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -317,6 +317,11 @@ Check that the resulting binaries do not differ." (comp-tests-signal-f) (t err)) '(foo . t)))) + +(ert-deftest comp-tests-func-call-removal () + ;; See `comp-propagate-insn' `comp-function-call-remove'. + (should (= (comp-tests-func-call-removal-f) 1))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; From 3681402bf163a3b5a7b7642f553e87693028649e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Nov 2019 20:27:27 +0100 Subject: [PATCH 0576/1452] improve dead assignment --- lisp/emacs-lisp/comp.el | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6a3662ec5d..073af957bed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1684,13 +1684,14 @@ Return t if something was changed." "Collect the mvar unique identifiers into INSN." (cl-loop for x in insn if (consp x) - append (comp-collect-mvar-ids x) + append (comp-collect-mvar-ids x) else - when (comp-mvar-p x) - collect (comp-mvar-id x))) + when (comp-mvar-p x) + collect (comp-mvar-id x))) (defun comp-dead-assignments-func () - "Clean-up dead assignments into current function." + "Clean-up trivial dead assignments into current function. +Return the list of m-var ids nuked." (let ((l-vals ()) (r-vals ())) ;; Collect used r and l values. @@ -1725,7 +1726,8 @@ Return t if something was changed." (if (comp-limple-insn-call-p rest) rest `(comment ,(format "optimized out: %s" - insn))))))))) + insn)))))) + nuke-list))) (defun comp-remove-type-hints-func () "Remove type hints from the current function. @@ -1744,7 +1746,11 @@ These are substituted with normals 'set'." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-dead-assignments-func) + (cl-loop + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)) (comp-remove-type-hints-func) (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt)))) From 407f5aac70f1481dfb365db7ba2e435f439498d0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Nov 2019 20:49:51 +0100 Subject: [PATCH 0577/1452] better comp-function-call-remove --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 073af957bed..7408034b932 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1524,8 +1524,9 @@ This can run just once." (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el (cl-every #'comp-mvar-const-vld args)) (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. (setf (car insn) 'setimm - (caddr insn) (comp-add-const-to-relocs val))))) + (cddr insn) (list (comp-add-const-to-relocs val) val))))) (defun comp-propagate-insn (insn) "Propagate within INSN." From ab5611c25b92ca06238de3d0ae53226176c2ae0d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Nov 2019 20:50:18 +0100 Subject: [PATCH 0578/1452] fix comp-propagate* --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7408034b932..2ee244077ba 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1571,7 +1571,7 @@ Return t if something was changed." do (comp-propagate-insn insn) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) - finally (cl-return modified))) + finally return modified)) (defun comp-propagate (_) (maphash (lambda (_ f) From 0c60b3bae71a010e6abdcfd4d8d38b92c7874609 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Nov 2019 21:26:45 +0100 Subject: [PATCH 0579/1452] fix comp-tests-bootstrap --- test/src/comp-tests.el | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b008dbd574e..55570d48a30 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,6 +29,9 @@ (require 'cl-lib) (require 'comp) +;; (setq comp-debug 1) +(setq comp-speed 3) + (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) (defconst comp-test-src @@ -40,25 +43,27 @@ (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." - (let ((comp-file (concat comp-test-directory + (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) - (comp1-file (concat temporary-file-directory + (comp1-src (concat temporary-file-directory (make-temp-name "stage1-") ".el")) - (comp2-file (concat temporary-file-directory + (comp2-src (concat temporary-file-directory (make-temp-name "stage2-") - ".el"))) - (copy-file comp-file comp1-file) - (copy-file comp-file comp2-file) - (load (concat comp-file "c") nil nil t t) + ".el")) + (comp1 (concat comp1-src "n")) + (comp2 (concat comp2-src "n"))) + (copy-file comp-src comp1-src) + (copy-file comp-src comp2-src) + (load (concat comp-src "c") nil nil t t) (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) (message "Compiling stage1...") - (load (native-compile comp1-file) nil nil t t) + (load (native-compile comp1-src) nil nil t t) (should (subr-native-elisp-p (symbol-function 'native-compile))) (message "Compiling stage2...") - (native-compile comp2-file) - (message "Comparing %s %s" comp1-file comp2-file) - (should (= (call-process "cmp" nil nil nil comp1-file comp2-file) 0)))) + (native-compile comp2-src) + (message "Comparing %s %s" comp1 comp2) + (should (= (call-process "cmp" nil nil nil comp1 comp2) 0)))) (ert-deftest comp-tests-provide () "Testing top level provide." From e97826ab845597fe09be43b2df888e96c7502bee Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Nov 2019 21:35:18 +0100 Subject: [PATCH 0580/1452] remove native-load-history --- src/comp.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3687bdb86a9..31f6c8dbd25 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3343,8 +3343,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, Frequire (Qadvice, Qnil, Qnil); - Vnative_load_history = Fcons (file, Vnative_load_history); - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) @@ -3431,10 +3429,6 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - DEFVAR_LISP ("native-load-history", Vnative_load_history, - doc: /* List with the history of the eln loaded. */); - Vnative_load_history = Qnil; - /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); Vnative_elisp_refs_hash From 37989f9431bc32f7ebac76cfc02f5e1d03486bcf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Nov 2019 21:53:19 +0100 Subject: [PATCH 0581/1452] remove unsigned in favor of ptrdiff_t --- src/comp.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 31f6c8dbd25..e604c31c5fe 100644 --- a/src/comp.c +++ b/src/comp.c @@ -362,7 +362,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, else if (!types) { types = alloca (nargs * sizeof (* types)); - for (unsigned i = 0; i < nargs; i++) + for (ptrdiff_t i = 0; i < nargs; i++) types[i] = comp.lisp_obj_type; } @@ -390,7 +390,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, /* Emit calls fetching from existing declarations. */ static gcc_jit_rvalue * -emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, +emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue **args, bool direct) { Lisp_Object func = @@ -426,7 +426,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_rvalue * -emit_call_ref (Lisp_Object subr_sym, unsigned nargs, +emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = @@ -468,7 +468,7 @@ emit_cond_jump (gcc_jit_rvalue *test, static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { - static unsigned i; + static ptrdiff_t i; gcc_jit_field *orig_field = type_to_cast_field (gcc_jit_rvalue_get_type (obj)); @@ -478,7 +478,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_function_new_local (comp.func, NULL, comp.cast_union_type, - format_string ("union_cast_%u", i++)); + format_string ("union_cast_%td", i++)); gcc_jit_block_add_assignment (comp.block, NULL, gcc_jit_lvalue_access_field (tmp_u, @@ -566,7 +566,7 @@ emit_lval_XLP (gcc_jit_lvalue *obj) comp.lisp_obj_as_ptr); } */ static gcc_jit_rvalue * -emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, ptrdiff_t lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ @@ -608,7 +608,7 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) } static gcc_jit_rvalue * -emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) +emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) { /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -1211,7 +1211,7 @@ emit_limple_insn (Lisp_Object insn) Lisp_Object arg[6]; Lisp_Object p = XCDR (insn); - unsigned i = 0; + ptrdiff_t i = 0; FOR_EACH_TAIL (p) { if (i == sizeof (arg) / sizeof (Lisp_Object)) @@ -2428,7 +2428,7 @@ define_add1_sub1 (void) { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; - for (unsigned i = 0; i < 2; i++) + for (ptrdiff_t i = 0; i < 2; i++) { gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, @@ -2741,7 +2741,7 @@ declare_function (Lisp_Object func) { EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); - for (unsigned i = 0; i < max_args; i++) + for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); @@ -2825,12 +2825,12 @@ compile_function (Lisp_Object func) if (SPEED >= 2) { comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); - for (unsigned i = 0; i < frame_size; ++i) + for (ptrdiff_t i = 0; i < frame_size; ++i) comp.f_frame[i] = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - format_string ("local%u", i)); + format_string ("local%td", i)); } comp.scratch = NULL; From 630fcab4fcfa9afab4688d803892d76cf6f46961 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Nov 2019 19:13:57 +0100 Subject: [PATCH 0582/1452] fix missing goto into load_comp_unit --- src/comp.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index e604c31c5fe..3e5f8f29901 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3290,7 +3290,10 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) else if (!strcmp (f_str, "specbind")) f_relocs[i] = (void *) specbind; else - err_msg = format_string ("unexpected function relocation %s.", f_str); + { + err_msg = format_string ("unexpected function relocation %s.", f_str); + goto exit_error; + } } /* Executing this will perform all the expected environment modification. */ From eae7f30a9a338b5713d7808c9f791e1a7f79b3cf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Nov 2019 19:37:47 +0100 Subject: [PATCH 0583/1452] comment nit --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ee244077ba..e1f0e657864 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1691,7 +1691,7 @@ Return t if something was changed." collect (comp-mvar-id x))) (defun comp-dead-assignments-func () - "Clean-up trivial dead assignments into current function. + "Clean-up dead assignments into current function. Return the list of m-var ids nuked." (let ((l-vals ()) (r-vals ())) From 95eb82644d348c59af9f4ec10ad315bf5e498353 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Nov 2019 21:51:11 +0100 Subject: [PATCH 0584/1452] fix symbol_subr + better naming --- src/comp.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3e5f8f29901..fc8ec406987 100644 --- a/src/comp.c +++ b/src/comp.c @@ -228,15 +228,15 @@ bcall0 (Lisp_Object f) static Lisp_Object symbol_subr (Lisp_Object symbol) { - Lisp_Object subr = Fsymbol_function (symbol); + Lisp_Object maybe_subr = Fsymbol_function (symbol); - if (SUBRP (subr)) - return subr; + if (SUBRP (maybe_subr)) + return maybe_subr; - if (!NILP (CALL1I (ad-has-any-advice, symbol))) - subr = CALL1I (ad-get-orig-definition, symbol); + if (!NILP (CALL1I (advice--p, maybe_subr))) + maybe_subr = CALL1I (ad-get-orig-definition, symbol); - return SUBRP (subr) ? subr : Qnil; + return SUBRP (maybe_subr) ? maybe_subr : Qnil; } static gcc_jit_field * From 4fe02acb6b0556c4b17c7a8e01f41698f5109512 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Nov 2019 22:26:56 +0100 Subject: [PATCH 0585/1452] better error handling while loading eln files --- src/comp.c | 65 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 36 insertions(+), 29 deletions(-) diff --git a/src/comp.c b/src/comp.c index fc8ec406987..b3e61297513 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3209,9 +3209,8 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } static void -load_comp_unit (dynlib_handle_ptr handle, char *file_name) +load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) { - const char *err_msg; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); @@ -3224,10 +3223,7 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) && data_relocs && f_relocs && top_level_run)) - { - err_msg = "inconsistent eln file."; - goto exit_error; - } + xsignal1 (Qnative_lisp_file_inconsistent, file); *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; @@ -3255,14 +3251,10 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) { subr = symbol_subr (f_sym); if (NILP (subr)) - { - /* FIXME: This is not robust in case of primitive - redefinition. */ - err_msg = format_string ("primitive %s redefined " - "or wrong relocation?", - f_str); - goto exit_error; - } + /* FIXME: This is not robust in case of primitive + redefinition. */ + xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); + f_relocs[i] = XSUBR (subr)->function.a0; } else if (!strcmp (f_str, "wrong_type_argument")) @@ -3290,20 +3282,13 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) else if (!strcmp (f_str, "specbind")) f_relocs[i] = (void *) specbind; else - { - err_msg = format_string ("unexpected function relocation %s.", f_str); - goto exit_error; - } + xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); } /* Executing this will perform all the expected environment modification. */ top_level_run (); return; -exit_error: - xsignal1 (Qcomp_unit_load_failed, - build_string (format_string ("while loading %s, %s", - file_name, err_msg))); } DEFUN ("comp--register-subr", Fcomp__register_subr, @@ -3316,9 +3301,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) - xsignal1 (Qcomp_unit_load_failed, - build_string ("comp--register-subr can only be called during " - "native code load phase.")); + xsignal0 (Qwrong_register_subr_call); void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); @@ -3349,9 +3332,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) - xsignal2 (Qcomp_unit_load_failed, file, build_string (dynlib_error ())); + xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - load_comp_unit (handle, SSDATA (file)); + load_comp_unit (handle, file); load_handle_stack = XCDR (load_handle_stack); @@ -3408,12 +3391,36 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); - /* To be signaled. */ - DEFSYM (Qcomp_unit_load_failed, "comp-unit-load-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qadvice, "advice"); + /* To be signaled. */ + DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); + Fput (Qnative_lisp_load_failed, Qerror_conditions, + pure_list (Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_load_failed, Qerror_message, + build_pure_c_string ("Native elisp load failed")); + + DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc"); + Fput (Qnative_lisp_wrong_reloc, Qerror_conditions, + pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_wrong_reloc, Qerror_message, + build_pure_c_string ("Primitive redefined or wrong relocation")); + + DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call"); + Fput (Qwrong_register_subr_call, Qerror_conditions, + pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed, Qerror)); + Fput (Qwrong_register_subr_call, Qerror_message, + build_pure_c_string ("comp--register-subr can only be called during " + "native lisp load phase.")); + + DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent"); + Fput (Qnative_lisp_file_inconsistent, Qerror_conditions, + pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_file_inconsistent, Qerror_message, + build_pure_c_string ("inconsistent eln file")); + defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); From 23874aee8825a6f670b6c2da9eca2d9cf643b3af Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Nov 2019 22:37:09 +0100 Subject: [PATCH 0586/1452] define internal-native-compiler-error as error --- src/comp.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index b3e61297513..f7950bcc72c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -214,9 +214,9 @@ static void ice (const char* msg) { if (msg) - error ("Internal native compiler error: %s", msg); + xsignal1 (Qinternal_native_compiler_error, build_string (msg)); else - error ("Internal native compiler error"); + xsignal0 (Qinternal_native_compiler_error); } static void @@ -3396,6 +3396,12 @@ syms_of_comp (void) DEFSYM (Qadvice, "advice"); /* To be signaled. */ + DEFSYM (Qinternal_native_compiler_error, "internal-native-compiler-error"); + Fput (Qinternal_native_compiler_error, Qerror_conditions, + pure_list (Qinternal_native_compiler_error, Qerror)); + Fput (Qinternal_native_compiler_error, Qerror_message, + build_pure_c_string ("Internal native compiler error")); + DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); Fput (Qnative_lisp_load_failed, Qerror_conditions, pure_list (Qnative_lisp_load_failed, Qerror)); From 71b363e2b3c709e64f8ef8ab7446cc3a19573eeb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 21 Nov 2019 16:09:30 +0100 Subject: [PATCH 0587/1452] error handling rework --- lisp/emacs-lisp/comp.el | 70 ++++++++++++++++------------ src/comp.c | 100 ++++++++++++++++++++++++---------------- 2 files changed, 100 insertions(+), 70 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1f0e657864..666d467051e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -389,7 +389,8 @@ Put PREFIX in front of it." (defun comp-decrypt-lambda-list (x) "Decript lambda list X." (unless (fixnump x) - (error "Can't native compile a non lexical scoped function")) + (signal 'native-compiler-error + "can't native compile a non lexical scoped function")) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -409,7 +410,7 @@ Put PREFIX in front of it." (defun comp-spill-lap-function (_function-name) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (error "To be reimplemented") + (signal 'native-ice "to be reimplemented") ;; (let* ((f (symbol-function function-name)) ;; (func (make-comp-func :symbol-name function-name ;; :c-func-name (comp-c-func-name @@ -435,7 +436,7 @@ Put PREFIX in front of it." "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms - (error "Empty byte compiler output")) + (signal 'native-compiler-error "empty byte compiler output")) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. @@ -538,7 +539,7 @@ Restore the original value afterwards." (defsubst comp-label-to-addr (label) "Find the address of LABEL." (or (gethash label (comp-limplify-label-to-addr comp-pass)) - (error "Can't find label %d" label))) + (signal 'native-ice (list "label not found" label)))) (defsubst comp-mark-curr-bb-closed () "Mark the current basic block as closed." @@ -556,8 +557,9 @@ The basic block is returned regardless it was already declared or not." (comp-limplify-pending-blocks comp-pass))))) (if bb (progn - (cl-assert (or (null sp) (= sp (comp-block-sp bb))) - (sp (comp-block-sp bb)) "sp %d %d differs") + (unless (or (null sp) (= sp (comp-block-sp bb))) + (signal 'native-ice (list "incoherent stack pointers" + sp (comp-block-sp bb)))) bb) (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) @@ -607,7 +609,7 @@ If the callee function is known to have a return type propagate it." (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. If DST-N is specified use it otherwise assume it to be the current slot." - (comp-with-sp (if dst-n dst-n (comp-sp)) + (comp-with-sp (or dst-n (comp-sp)) (let ((src-slot (comp-slot-n src-n))) (cl-assert src-slot) (comp-emit `(set ,(comp-slot) ,src-slot))))) @@ -749,28 +751,28 @@ Return value is the fall through block name." ;; All fall through are artificially created here except the last one. (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) ff-bb)))) - (_ (error "Missing previous setimm while creating a switch")))) + (_ (signal 'native-ice + "missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. SP-DELTA is the stack adjustment." (let ((subr (symbol-function subr-name)) - (subr-str (symbol-name subr-name)) (nargs (1+ (- sp-delta)))) - (cl-assert (subrp subr) nil - "%s not a subr" subr-str) + (unless (subrp subr) + (signal 'native-ice (list "not a subr" subr))) (let* ((arity (subr-arity subr)) (minarg (car arity)) (maxarg (cdr arity))) - (cl-assert (not (eq maxarg 'unevalled)) nil - "%s contains unevalled arg" subr-name) + (when (eq maxarg 'unevalled) + (signal 'native-ice (list "subr contains unevalled args" subr-name))) (if (eq maxarg 'many) ;; callref case. (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) ;; Normal call. - (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) - (nargs maxarg minarg) - "Incoherent stack adjustment %d, maxarg %d minarg %d") + (unless (and (>= maxarg nargs) (<= minarg nargs)) + (signal 'native-ice + (list "incoherent stack adjustment" nargs maxarg minarg))) (let* ((subr-name subr-name) (slots (cl-loop for i from 0 below maxarg collect (comp-slot-n (+ i (comp-sp)))))) @@ -817,9 +819,9 @@ the annotation emission." `(cl-incf (comp-sp) ,sp-delta)) ,@(comp-body-eff body op-name sp-delta)) else - collect `(',op (error ,(concat "Unsupported LAP op " - op-name)))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))) + collect `(',op (signal 'native-ice + (list "unsupported LAP op" ',op-name)))) + (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) (defun comp-limplify-lap-inst (insn) "Limplify LAP instruction INSN pushng it in the proper basic block." @@ -1011,8 +1013,7 @@ the annotation emission." (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set - (comp-with-sp (1+ (comp-sp)) ;; FIXME!! - (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) + (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN (cl-incf (comp-sp) (- arg))) @@ -1203,9 +1204,9 @@ Top level forms for the current context are rendered too." ;; This pass should be run every time basic blocks or mvar are shuffled. (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) - (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) - :slot slot :const-vld const-vld :constant constant - :type type)) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) (defun comp-compute-edges () "Compute the basic block edges for the current function." @@ -1234,8 +1235,10 @@ Top level forms for the current context are rendered too." (edge-add :src bb :dst (gethash forth blocks))) (return) (otherwise - (error "Block %s does not end with a branch in func %s" - bb (comp-func-symbol-name comp-func)))) + (signal 'native-ice + (list "block does not end with a branch" + bb + (comp-func-symbol-name comp-func))))) finally (progn (setf (comp-func-edges comp-func) (nreverse (comp-func-edges comp-func))) @@ -1280,7 +1283,7 @@ Top level forms for the current context are rendered too." (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) p - (error "Cant't find first preprocessed")))) + (signal 'native-ice "cant't find first preprocessed")))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) @@ -1845,7 +1848,8 @@ If INPUT is a string, use it as the file path to be native compiled. Return the compilation unit filename." (unless (or (symbolp input) (stringp input)) - (error "Trying to native compile something not a symbol function or file")) + (signal 'native-compiler-error + (list "not a symbol function or file" input))) (let ((data input) (comp-native-compiling t) (comp-ctxt (make-comp-ctxt @@ -1858,7 +1862,12 @@ Return the compilation unit filename." (comp-log (format "Running pass %s:\n" pass) 2) (setq data (funcall pass data))) comp-passes) - (error (error "While compiling %s: %s" input (error-message-string err)))) + (native-compiler-error + ;; Add source input. + (let ((err-val (cdr err))) + (signal (car err) (if (consp err-val) + (cons input err-val) + (list input err-val)))))) data)) ;;;###autoload @@ -1874,7 +1883,8 @@ Follow folders RECURSIVELY if non nil." (directory-files input t "\\.el$")) (if (file-exists-p input) (list input) - (error "Input not a file nor directory"))))) + (signal 'native-compiler-error + "input not a file nor directory"))))) (with-mutex comp-src-pool-mutex (setf comp-src-pool (nconc files comp-src-pool))) (cl-loop repeat jobs diff --git a/src/comp.c b/src/comp.c index f7950bcc72c..61f297ea3d0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,14 +70,6 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME STR (SETJMP) -/* Raise an internal compiler error if test. - msg is evaluated only in that case. */ -#define ICE_IF(test, msg) \ - do { \ - if (test) \ - ice (msg); \ - } while (0) - /* C side of the compiler context. */ typedef struct { @@ -210,15 +202,6 @@ format_string (const char *format, ...) return scratch_area; } -static void -ice (const char* msg) -{ - if (msg) - xsignal1 (Qinternal_native_compiler_error, build_string (msg)); - else - xsignal0 (Qinternal_native_compiler_error); -} - static void bcall0 (Lisp_Object f) { @@ -273,7 +256,7 @@ type_to_cast_field (gcc_jit_type *type) else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else - ice ("unsupported cast"); + xsignal1 (Qnative_ice, build_string ("unsupported cast")); return field; } @@ -282,7 +265,9 @@ static gcc_jit_block * retrive_block (Lisp_Object block_name) { Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); - ICE_IF (NILP (value), "missing basic block"); + + if (NILP (value)) + xsignal1 (Qnative_ice, build_string ("missing basic block")); return (gcc_jit_block *) xmint_pointer (value); } @@ -293,8 +278,10 @@ declare_block (Lisp_Object block_name) char *name_str = SSDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)), - "double basic block declaration"); + + if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil))) + xsignal1 (Qnative_ice, build_string ("double basic block declaration")); + Fputhash (block_name, value, comp.func_blocks_h); } @@ -343,8 +330,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)), - "unexpected double function declaration"); + if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil))) + xsignal2 (Qnative_ice, + build_string ("unexpected double function declaration"), + subr_sym); if (nargs == MANY) { @@ -396,7 +385,10 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, Lisp_Object func = Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, Qnil); - ICE_IF (NILP (func), "missing function declaration"); + if (NILP (func)) + xsignal2 (Qnative_ice, + build_string ("missing function declaration"), + subr_sym); if (direct) { @@ -414,7 +406,10 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_lvalue_access_field (comp.func_relocs, NULL, (gcc_jit_field *) xmint_pointer (func)); - ICE_IF (!f_ptr, "undeclared function relocation"); + if (!f_ptr) + xsignal2 (Qnative_ice, + build_string ("missing function relocation"), + subr_sym); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr (comp.ctxt, @@ -1092,7 +1087,11 @@ emit_set_internal (Lisp_Object args) #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ - ICE_IF (list_length (args) != 3, "unexpected arg length for insns"); + if (list_length (args) != 3) + xsignal2 (Qnative_ice, + build_string ("unexpected arg length for insns"), + args); + args = XCDR (args); int i = 0; gcc_jit_rvalue *gcc_args[4]; @@ -1272,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (handler_spec, Qcondition_case)) h_num = CONDITION_CASE; else - ice ("incoherent insn"); + xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1372,9 +1371,13 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (FIRST (arg1), Qdirect_callref)) res = emit_limple_call_ref (XCDR (arg1), true); else - ice ("LIMPLE inconsistent arg1 for op ="); + xsignal2 (Qnative_ice, + build_string ("LIMPLE inconsistent arg1 for insn"), + insn); - ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); + if (!res) + xsignal1 (Qnative_ice, + build_string (gcc_jit_context_get_first_error (comp.ctxt))); emit_frame_assignment (arg[0], res); } @@ -1480,7 +1483,9 @@ emit_limple_insn (Lisp_Object insn) } else { - ice ("LIMPLE op inconsistent"); + xsignal2 (Qnative_ice, + build_string ("LIMPLE op inconsistent"), + op); } } @@ -2860,7 +2865,10 @@ compile_function (Lisp_Object func) Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = CALL1I (comp-block-insns, block); - ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty"); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + comp.block = retrive_block (block_name); while (CONSP (insns)) @@ -2871,10 +2879,12 @@ compile_function (Lisp_Object func) } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); - ICE_IF (err, - format_string ("failing to compile function %s with error: %s", - SSDATA (SYMBOL_NAME (CALL1I (comp-func-symbol-name, func))), - err)); + if (err) + xsignal3 (Qnative_ice, + build_string ("failing to compile function"), + CALL1I (comp-func-symbol-name, func), + build_string (err)); + SAFE_FREE (); } @@ -2890,7 +2900,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, { if (comp.ctxt) { - ice ("compiler context already taken"); + xsignal1 (Qnative_ice, + build_string ("compiler context already taken")); return Qnil; } @@ -3396,12 +3407,21 @@ syms_of_comp (void) DEFSYM (Qadvice, "advice"); /* To be signaled. */ - DEFSYM (Qinternal_native_compiler_error, "internal-native-compiler-error"); - Fput (Qinternal_native_compiler_error, Qerror_conditions, - pure_list (Qinternal_native_compiler_error, Qerror)); - Fput (Qinternal_native_compiler_error, Qerror_message, + + /* By the compiler. */ + DEFSYM (Qnative_compiler_error, "native-compiler-error"); + Fput (Qnative_compiler_error, Qerror_conditions, + pure_list (Qnative_compiler_error, Qerror)); + Fput (Qnative_compiler_error, Qerror_message, + build_pure_c_string ("Native compiler error")); + + DEFSYM (Qnative_ice, "native-ice"); + Fput (Qnative_ice, Qerror_conditions, + pure_list (Qnative_ice, Qnative_compiler_error, Qerror)); + Fput (Qnative_ice, Qerror_message, build_pure_c_string ("Internal native compiler error")); + /* By the load machinery. */ DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); Fput (Qnative_lisp_load_failed, Qerror_conditions, pure_list (Qnative_lisp_load_failed, Qerror)); From 0bf55d3a8131da02999fe694caf34096d7408952 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 22 Nov 2019 14:00:02 +0100 Subject: [PATCH 0588/1452] fix type hints error kind --- lisp/emacs-lisp/comp.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 666d467051e..5ebaf9f0f5a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1789,10 +1789,12 @@ Prepare every function for final compilation and drive the C back-end." ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) - (cl-assert (fixnump x))) + (unless (fixnump x) + (signal 'wrong-type-argument x))) (defun comp-hint-cons (x) - (cl-assert (consp x))) + (unless (consp x) + (signal 'wrong-type-argument x))) ;; Some entry point support code. From d0e6a276643b2590eebf81e305b006c768653b10 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 22 Nov 2019 14:42:37 +0100 Subject: [PATCH 0589/1452] better ert usage into tests --- test/src/comp-tests.el | 44 ++++++++++++++---------------------------- 1 file changed, 14 insertions(+), 30 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 55570d48a30..a0e6e23cefd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -79,16 +79,12 @@ Check that the resulting binaries do not differ." (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) - (should (= (condition-case err - (comp-tests-car-f 3) - (error 10)) - 10)) + (should-error (comp-tests-car-f 3) + :type 'wrong-type-argument) (should (= (comp-tests-cdr-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-f nil))) - (should (= (condition-case err - (comp-tests-cdr-f 3) - (error 10)) - 10)) + (should-error (comp-tests-cdr-f 3) + :type 'wrong-type-argument) (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) (should (null (comp-tests-car-safe-f 'a))) (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) @@ -191,24 +187,18 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-fixnum-1-minus-f 10) 9)) (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) + (should-error (comp-tests-fixnum-1-minus-f 'a) + :type 'wrong-type-argument) (should (= (comp-tests-fixnum-1-plus-f 10) 11)) (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-plus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) + (should-error (comp-tests-fixnum-1-plus-f 'a) + :type 'wrong-type-argument) (should (= (comp-tests-fixnum-minus-f 10) -10)) (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) (- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a)))) + (should-error (comp-tests-fixnum-minus-f 'a) + :type 'wrong-type-argument)) (ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." @@ -232,16 +222,10 @@ Check that the resulting binaries do not differ." "Testing setcar setcdr." (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) - (should (equal (condition-case - err - (comp-tests-setcar-f 3 10) - (error err)) - '(wrong-type-argument consp 3))) - (should (equal (condition-case - err - (comp-tests-setcdr-f 3 10) - (error err)) - '(wrong-type-argument consp 3)))) + (should-error (comp-tests-setcar-f 3 10) + :type 'wrong-type-argument) + (should-error (comp-tests-setcdr-f 3 10) + :type 'wrong-type-argument)) (ert-deftest comp-tests-bubble-sort () "Run bubble sort." From 99258421bbb123e6f277610dcf94e022dde3a5c0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 22 Nov 2019 19:15:12 +0100 Subject: [PATCH 0590/1452] sanityze orthography in comp.el --- lisp/emacs-lisp/comp.el | 91 ++++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 43 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5ebaf9f0f5a..ff091e6cde9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -40,7 +40,7 @@ (defcustom comp-speed 0 "Compiler optimization level. From 0 to 3. -- 0 no otimizations are performed, compile time is favored. +- 0 no optimizations are performed, compile time is favored. - 1 lite optimizations. - 2 heavy optimizations. - 3 max optimization level, to be used only when necessary. @@ -50,8 +50,9 @@ (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. +This intended for debugging the compiler itself. - 0 no debug facility. - This is the raccomanded value unless you are debugging the compiler itself. + This is the recommended value unless you are debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." @@ -60,6 +61,7 @@ (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. +This intended for debugging the compiler itself. - 0 no logging. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. @@ -92,7 +94,6 @@ Can be used by code that wants to expand differently in this case.") comp-final) "Passes to be executed in order.") -;; TODO hash here. (defconst comp-known-ret-types '((cons . cons) (1+ . number) (1- . number) @@ -119,7 +120,7 @@ Can be used by code that wants to expand differently in this case.") (defconst comp-limple-assignments `(fetch-handler ,@comp-limple-sets) - "Limple operators that clobbers the first mvar argument.") + "Limple operators that clobbers the first m-var argument.") (defconst comp-limple-calls '(call callref @@ -140,7 +141,7 @@ Can be used by code that wants to expand differently in this case.") (cl-defstruct comp-ctxt "Lisp side of the compiler context." (output nil :type string - :documentation "Target output filename for the compilation.") + :documentation "Target output file-name for the compilation.") (top-level-forms () :type list :documentation "List of spilled top level forms.") (funcs-h (make-hash-table) :type hash-table @@ -165,7 +166,7 @@ This is to build the prev field.") To be used when ncall-conv is nil.")) (cl-defstruct (comp-nargs (:include comp-args-base)) - "Describe args when the functin signature is of kind: + "Describe args when the function signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." (nonrest nil :type number :documentation "Number of non rest arguments.") @@ -191,7 +192,7 @@ into it.") (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list - :documentation "List of outcoming edges.") + :documentation "List of out-coming edges.") (dom nil :type comp-block :documentation "Immediate dominator.") (df (make-hash-table) :type hash-table @@ -223,7 +224,7 @@ Is in use to help the SSA rename pass.")) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." (symbol-name nil - :documentation "Function symbol's name.") + :documentation "Function's symbol name.") (c-func-name nil :type string :documentation "The function name in the native world.") (byte-func nil @@ -259,16 +260,18 @@ structure.") :documentation "Slot number. -1 is a special value and indicates the scratch slot.") (id nil :type (or null number) - :documentation "SSA number.") + :documentation "SSA number when in SSA form.") (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil - :documentation "When const-vld non nil this is used for constant - propagation.") + :documentation "When const-vld non nil this is used for holding + a value known at compile time.") (type nil - :documentation "When non nil is used for type propagation.") + :documentation "When non nil is used for type when known at compile + time.") (ref nil :type boolean - :documentation "When t this is used by reference.")) + :documentation "When t the m-var is involved in a call where is passed by + reference.")) ;; Special vars used by some passes (defvar comp-func) @@ -340,7 +343,8 @@ BODY is evaluate only if `comp-verbose' is > 0." (insert "\n")))))) (defun comp-log-func (func verbosity) - "Log function FUNC." + "Log function FUNC. +VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) (comp-log (format "\nFunction: %s\n" (comp-func-symbol-name func)) verbosity) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) @@ -462,7 +466,7 @@ Put PREFIX in front of it." collect func)) (defun comp-spill-lap (input) - "Byte compile and spill the LAP rapresentation for INPUT. + "Byte compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) @@ -480,7 +484,7 @@ If INPUT is a string this is the file path to be compiled." (frame nil :type vector :documentation "Meta-stack used to flat LAP.") (curr-block nil :type comp-block - :documentation "Current block baing limplified.") + :documentation "Current block being limplified.") (sp -1 :type number :documentation "Current stack pointer while walking LAP. Points to the next slot to be filled.") @@ -570,7 +574,7 @@ The basic block is returned regardless it was already declared or not." `(call ,func ,@args)) (defun comp-callref (func nargs stack-off) - "Emit a call usign narg abi for FUNC. + "Emit a call using narg abi for FUNC. NARGS is the number of arguments. STACK-OFF is the index of the first slot frame involved." (comp-add-subr-to-relocs func) @@ -585,7 +589,8 @@ STACK-OFF is the index of the first slot frame involved." :type type)) (defun comp-new-frame (size &optional ssa) - "Return a clean frame of meta variables of size SIZE." + "Return a clean frame of meta variables of size SIZE. +If SSA non nil populate it of m-var in ssa form." (cl-loop with v = (make-vector size nil) for i below size for mvar = (if ssa @@ -715,7 +720,7 @@ Return value is the fall through block name." (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." - ;; FIXME this not efficent for big jump tables. We should have a second + ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn (`(setimm ,_ ,_ ,jmp-table) @@ -785,8 +790,8 @@ SP-DELTA is the stack adjustment." (defun comp-body-eff (body op-name sp-delta) "Given the original body BODY compute the effective one. -When BODY is auto guess function name form the LAP bytecode -name. Othewise expect lname fnname." +When BODY is auto guess function name form the LAP byte-code +name. Otherwise expect lname fnname." (pcase (car body) ('auto (list `(comp-emit-set-call-subr @@ -799,7 +804,7 @@ name. Othewise expect lname fnname." (_ body)))) (defmacro comp-op-case (&rest cases) - "Expand CASES into the corresponding pcase. + "Expand CASES into the corresponding `pcase' expansion. This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) @@ -824,7 +829,7 @@ the annotation emission." (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) (defun comp-limplify-lap-inst (insn) - "Limplify LAP instruction INSN pushng it in the proper basic block." + "Limplify LAP instruction INSN pushing it in the proper basic block." (let ((op (car insn)) (arg (if (consp (cdr insn)) (cadr insn) @@ -1110,7 +1115,7 @@ This will be called at load-time." (defun comp-addr-to-bb-name (addr) "Search for a block starting at ADDR into pending or limplified blocks." - ;; FIXME: Actually we could have another hash for this. + ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) (equal (comp-block-addr bb) addr))) (if-let ((pending (cl-find-if #'pred @@ -1201,7 +1206,7 @@ Top level forms for the current context are rendered too." ;; plus placing the needed phis. ;; Because the number of phis placed is (supposed) to be the minimum necessary ;; this form is called 'minimal SSA form'. -;; This pass should be run every time basic blocks or mvar are shuffled. +;; This pass should be run every time basic blocks or m-var are shuffled. (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) @@ -1251,7 +1256,7 @@ Top level forms for the current context are rendered too." (comp-log-edges comp-func))))) (defun comp-collect-rev-post-order (basic-block) - "Walk BASIC-BLOCK childs and return their name in reversed post-oder." + "Walk BASIC-BLOCK children and return their name in reversed post-order." (let ((visited (make-hash-table)) (acc ())) (cl-labels ((collect-rec (bb) @@ -1314,6 +1319,7 @@ Top level forms for the current context are rendered too." (setf changed t)))))) (defun comp-compute-dominator-frontiers () + "Compute the dominator frontier for each basic block in `comp-func'." ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). (cl-loop with blocks = (comp-func-blocks comp-func) @@ -1393,7 +1399,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector - :documentation "Vector of mvars.")) + :documentation "Vector of m-vars.")) (defun comp-ssa-rename-insn (insn frame) (dotimes (slot-n (comp-func-frame-size comp-func)) @@ -1419,7 +1425,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () - "Entry point to rename SSA within the current function." + "Entry point to rename into SSA within the current function." (comp-log "Renaming\n" 2) (let ((frame-size (comp-func-frame-size comp-func)) (visited (make-hash-table))) @@ -1442,7 +1448,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-finalize-phis () "Fixup r-values into phis in all basic blocks." (cl-flet ((finalize-phi (args b) - ;; Concatenate into args all incoming mvars for this phi. + ;; Concatenate into args all incoming m-vars for this phi. (setcdr args (cl-loop with slot-n = (comp-mvar-slot (car args)) for e in (comp-block-in-edges b) @@ -1456,7 +1462,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." do (finalize-phi args b))))) (defun comp-ssa (_) - "Port FUNCS into mininal SSA form." + "Port all functions into mininal SSA form." (maphash (lambda (_ f) (let ((comp-func f)) ;; TODO: if this is run more than once we should clean all CFG @@ -1475,8 +1481,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;;; propagate pass specific code. ;; A very basic propagation pass follows. -;; This propagates values and types plus in the control flow graph. -;; Is also responsible for removing function calls to pure functions when +;; This propagates values and types plus ref property in the control flow graph. +;; This is also responsible for removing function calls to pure functions if ;; possible. (defsubst comp-strict-type-of (obj) @@ -1650,7 +1656,7 @@ Return t if something was changed." `(call ,callee ,@args))))))) (defun comp-call-optim-func () - "Perform trampoline call optimization for the current function." + "Perform the trampoline call optimization for the current function." (cl-loop with self = (comp-func-symbol-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) @@ -1668,7 +1674,7 @@ Return t if something was changed." (setcar insn-cell new-form))))))) (defun comp-call-optim (_) - "Given FUNCS try to avoid funcall trampoline usage when possible." + "Try to optimize out funcall trampoline usage when possible." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) @@ -1679,13 +1685,12 @@ Return t if something was changed." ;;; Dead code elimination pass specific code. ;; This simple pass try to eliminate insns became useful after propagation. ;; Even if gcc would take care of this is good to perform this here -;; in the hope of removing memory references (remember that most lisp -;; objects are loaded from the reloc array). +;; in the hope of removing memory references. ;; ;; This pass can be run as last optim. (defun comp-collect-mvar-ids (insn) - "Collect the mvar unique identifiers into INSN." + "Collect the m-var unique identifiers into INSN." (cl-loop for x in insn if (consp x) append (comp-collect-mvar-ids x) @@ -1698,7 +1703,7 @@ Return t if something was changed." Return the list of m-var ids nuked." (let ((l-vals ()) (r-vals ())) - ;; Collect used r and l values. + ;; Collect used r and l-values. (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1735,7 +1740,7 @@ Return the list of m-var ids nuked." (defun comp-remove-type-hints-func () "Remove type hints from the current function. -These are substituted with normals 'set'." +These are substituted with a normal 'set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1770,7 +1775,7 @@ Prepare every function for final compilation and drive the C back-end." (comp--compile-ctxt-to-file name)) (defun comp-final (_) - "Final pass driving DATA into the C back-end for code emission." + "Final pass driving the C back-end for code emission." (let (compile-result) (comp--init-ctxt) (unwind-protect @@ -1844,10 +1849,10 @@ Prepare every function for final compilation and drive the C back-end." ;;;###autoload (defun native-compile (input) "Compile INPUT into native code. -This is the entrypoint for the Emacs Lisp native compiler. +This is the entry-point for the Emacs Lisp native compiler. If INPUT is a symbol, native compile its function definition. If INPUT is a string, use it as the file path to be native compiled. -Return the compilation unit filename." +Return the compilation unit file name." (unless (or (symbolp input) (stringp input)) (signal 'native-compiler-error @@ -1874,7 +1879,7 @@ Return the compilation unit filename." ;;;###autoload (defun native-compile-async (input &optional jobs recursively) - "Compile INPUT asyncronosly. + "Compile INPUT asynchronously. INPUT can be either a folder or a file. JOBS specifies the number of jobs (commands) to run simultaneously (1 default). Follow folders RECURSIVELY if non nil." From 8ef0a1814eca5dc7f32e2784b3fa61498d220a70 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 22 Nov 2019 19:15:55 +0100 Subject: [PATCH 0591/1452] better loop style into comp-compute-edges --- lisp/emacs-lisp/comp.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ff091e6cde9..fffb845e4ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1244,16 +1244,15 @@ Top level forms for the current context are rendered too." (list "block does not end with a branch" bb (comp-func-symbol-name comp-func))))) - finally (progn - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - ;; Update edge refs into blocks. - (cl-loop for edge in (comp-func-edges comp-func) - do (push edge - (comp-block-out-edges (comp-edge-src edge))) - (push edge - (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func))))) + finally (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func)))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." From 954eb9b4a0b9d616db9646f081d11b2c6dd19581 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 22 Nov 2019 19:20:05 +0100 Subject: [PATCH 0592/1452] homogeneous setf style --- lisp/emacs-lisp/comp.el | 50 ++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fffb845e4ee..458c95a3227 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -251,8 +251,8 @@ structure.") (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." - (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) - (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) + (setf (comp-func-edge-cnt-gen func) (comp-gen-counter) + (comp-func-ssa-cnt-gen func) (comp-gen-counter))) (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." @@ -320,7 +320,7 @@ BODY is evaluate only if `comp-verbose' is > 0." (indent defun)) `(when (> comp-verbose 0) (with-current-buffer (get-buffer-create native-compile-log-buffer) - (setq buffer-read-only t) + (setf buffer-read-only t) (let ((inhibit-read-only t)) (goto-char (point-max)) ,@body)))) @@ -635,9 +635,9 @@ ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." (let ((bb (make--comp-block addr entry-sp block-name))) - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-pc comp-pass) addr) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-pc comp-pass) addr + (comp-limplify-sp comp-pass) (comp-block-sp bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) @@ -1127,9 +1127,9 @@ This will be called at load-time." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) - (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-sp comp-pass) (comp-block-sp bb) + (comp-limplify-pc comp-pass) (comp-block-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop for inst-cell on (nthcdr (comp-limplify-pc comp-pass) @@ -1278,11 +1278,11 @@ Top level forms for the current context are rendered too." (finger2 (comp-block-post-num b2))) (while (not (= finger1 finger2)) (while (< finger1 finger2) - (setf b1 (comp-block-dom b1)) - (setf finger1 (comp-block-post-num b1))) + (setf b1 (comp-block-dom b1) + finger1 (comp-block-post-num b1))) (while (< finger2 finger1) - (setf b2 (comp-block-dom b2)) - (setf finger2 (comp-block-post-num b2)))) + (setf b2 (comp-block-dom b2) + finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) @@ -1314,8 +1314,8 @@ Top level forms for the current context are rendered too." when (comp-block-dom p) do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) new-idom) - (setf changed t)))))) + do (setf (comp-block-dom b) new-idom + changed t)))))) (defun comp-compute-dominator-frontiers () "Compute the dominator frontier for each basic block in `comp-func'." @@ -1409,8 +1409,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (aref frame slot-n) mvar) - (setf (cadr insn) mvar)))) + (setf (aref frame slot-n) mvar + (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) (let ((mvar (aref frame slot-n))) @@ -1499,9 +1499,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (while (consp insn) (let ((newcar (car insn))) (if (or (consp (car insn)) (comp-mvar-p (car insn))) - (setq newcar (comp-copy-insn (car insn)))) + (setf newcar (comp-copy-insn (car insn)))) (push newcar result)) - (setq insn (cdr insn))) + (setf insn (cdr insn))) (nconc (nreverse result) (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) (if (comp-mvar-p insn) @@ -1778,7 +1778,7 @@ Prepare every function for final compilation and drive the C back-end." (let (compile-result) (comp--init-ctxt) (unwind-protect - (setq compile-result + (setf compile-result (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) (and (comp--release-ctxt) compile-result)))) @@ -1826,10 +1826,10 @@ Prepare every function for final compilation and drive the C back-end." (when (comp-to-file-p f) (let* ((code `(progn (require 'comp) - (setq comp-speed ,comp-speed) - (setq comp-debug ,comp-debug) - (setq comp-verbose ,comp-verbose) - (setq load-path ',load-path) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + load-path ',load-path) (message "Compiling %s started." ,f) (native-compile ,f))) (prc (start-process (concat "Compiling: " f) @@ -1866,7 +1866,7 @@ Return the compilation unit file name." (condition-case err (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass) 2) - (setq data (funcall pass data))) + (setf data (funcall pass data))) comp-passes) (native-compiler-error ;; Add source input. From d901221e2bb2168cd1f05e3b2355e078c45f1f42 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 23 Nov 2019 09:56:56 +0100 Subject: [PATCH 0593/1452] style fixes into comp.c --- src/comp.c | 51 +++++++++++++++++++++++++++------------------------ 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/src/comp.c b/src/comp.c index 61f297ea3d0..e7b8a044252 100644 --- a/src/comp.c +++ b/src/comp.c @@ -34,7 +34,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" -/* C symbols emited for the load relocation mechanism. */ +/* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" @@ -115,7 +115,7 @@ typedef struct { gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread_ref; - /* other globals */ + /* Other globals. */ gcc_jit_rvalue *pure_ref; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ @@ -175,7 +175,7 @@ typedef struct { /* - Helper functions called by the runtime. + Helper functions called by the run-time. */ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); @@ -208,6 +208,7 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } +/* Try to return the original subr from `symbol' even if this was advised. */ static Lisp_Object symbol_subr (Lisp_Object symbol) { @@ -323,7 +324,7 @@ emit_comment (const char *str) /* Declare an imported function. When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed. - When types is NULL types is assumed to be all Lisp_Objects. + When types is NULL args are assumed to be all Lisp_Objects. */ static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, @@ -342,7 +343,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[0] = comp.ptrdiff_type; types[1] = comp.lisp_obj_ptr_type; } - if (nargs == UNEVALLED) + else if (nargs == UNEVALLED) { nargs = 1; types = alloca (nargs * sizeof (* types)); @@ -681,11 +682,11 @@ emit_BIGNUMP (gcc_jit_rvalue *obj) /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ emit_comment ("BIGNUMP"); - gcc_jit_rvalue *args[2] = { - obj, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - PVEC_BIGNUM) }; + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; return gcc_jit_context_new_call (comp.ctxt, NULL, @@ -1598,7 +1599,7 @@ emit_integerp (Lisp_Object insn) } /* This is in charge of serializing an object and export a function to - retrive it at load time. */ + retrieve it at load time. */ static void emit_static_object (const char *name, Lisp_Object obj) { @@ -1760,7 +1761,7 @@ declare_runtime_imported_funcs (void) } /* -This emit the code needed by every compilation unit to be loaded. + This emit the code needed by every compilation unit to be loaded. */ static void emit_ctxt_code (void) @@ -2386,10 +2387,10 @@ define_setcar_setcdr (void) comp.func = *f_ref; comp.block = entry_block; - /* CHECK_CONS (cell); */ + /* CHECK_CONS (cell); */ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); - /* CHECK_IMPURE (cell, XCONS (cell)); */ + /* CHECK_IMPURE (cell, XCONS (cell)); */ gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (cell), emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; @@ -2402,7 +2403,7 @@ define_setcar_setcdr (void) 2, args)); - /* XSETCDR (cell, newel); */ + /* XSETCDR (cell, newel); */ if (!i) emit_XSETCAR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_el)); @@ -2410,7 +2411,7 @@ define_setcar_setcdr (void) emit_XSETCDR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_el)); - /* return newel; */ + /* return newel; */ gcc_jit_block_end_with_return (entry_block, NULL, gcc_jit_param_as_rvalue (new_el)); @@ -2733,6 +2734,7 @@ define_bool_to_lisp_obj (void) } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ + static void declare_function (Lisp_Object func) { @@ -2823,7 +2825,7 @@ compile_function (Lisp_Object func) locals if the are not going to be used in a nargs call. This has two advantages: - Enable gcc for better reordering (frame array is clobbered every time is - passed as parameter being invoved into an nargs function call). + passed as parameter being involved into an nargs function call). - Allow gcc to trigger other optimizations that are prevented by memory referencing. */ @@ -2847,7 +2849,7 @@ compile_function (Lisp_Object func) comp.func_blocks_h = CALLN (Fmake_hash_table); - /* Pre declare all basic blocks to gcc. + /* Pre-declare all basic blocks to gcc. The "entry" block must be declared as first. */ declare_block (Qentry); Lisp_Object blocks = CALL1I (comp-func-blocks, func); @@ -2869,7 +2871,6 @@ compile_function (Lisp_Object func) xsignal1 (Qnative_ice, build_string ("basic block is missing or empty")); - comp.block = retrive_block (block_name); while (CONSP (insns)) { @@ -3139,10 +3140,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, /******************************************************************************/ -/* Helper functions called from the runtime. */ +/* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ /* Note: this are all potentially definable directly to gcc and are here just */ -/* for lazyness. Change this if a performance impact is measured. */ +/* for laziness. Change this if a performance impact is measured. */ /******************************************************************************/ Lisp_Object @@ -3356,9 +3357,10 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { - /* Compiler control customize. */ + /* Compiler control customizes. */ DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); + /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); @@ -3371,7 +3373,7 @@ syms_of_comp (void) DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qphi, "phi"); - /* In use for prologue emission. */ + /* Ops in use for prologue emission. */ DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); @@ -3383,7 +3385,7 @@ syms_of_comp (void) DEFSYM (Qfetch_handler, "fetch-handler"); DEFSYM (Qcondition_case, "condition-case"); /* call operands. */ - DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */ + DEFSYM (Qcatcher, "catcher"); DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); @@ -3402,6 +3404,7 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); + /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qadvice, "advice"); From a421c277237ab6b5923473f6dbb9c196b16bc833 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 23 Nov 2019 17:03:08 +0100 Subject: [PATCH 0594/1452] fix single function compilation --- lisp/emacs-lisp/bytecomp.el | 5 ++-- lisp/emacs-lisp/comp.el | 58 ++++++++++++++++++------------------- 2 files changed, 31 insertions(+), 32 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 04c80c17577..ebbee2a0c7c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3147,9 +3147,8 @@ for symbols generated by the byte compiler itself." byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling ;; Spill LAP for the native compiler here - (when byte-compile-current-form - (push (cons byte-compile-current-form byte-compile-output) - byte-to-native-lap))) + (push (cons byte-compile-current-form byte-compile-output) + byte-to-native-lap)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 458c95a3227..7358e8616cc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -102,7 +102,7 @@ Can be used by code that wants to expand differently in this case.") (* . number) (/ . number) (% . number) - ;; Type hint + ;; Type hints (comp-hint-fixnum . fixnum) (comp-hint-cons . cons)) "Alist used for type propagation.") @@ -412,31 +412,33 @@ Put PREFIX in front of it." ;; For the 1+ see bytecode.c:365 (finger crossed). (1+ (aref byte-compiled-func 3))) -(defun comp-spill-lap-function (_function-name) - "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (signal 'native-ice "to be reimplemented") - ;; (let* ((f (symbol-function function-name)) - ;; (func (make-comp-func :symbol-name function-name - ;; :c-func-name (comp-c-func-name - ;; function-name - ;; "F")))) - ;; (when (byte-code-function-p f) - ;; (error "Can't native compile an already bytecompiled function")) - ;; (setf (comp-func-byte-func func) - ;; (byte-compile (comp-func-symbol-name func))) - ;; (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) - ;; (cl-assert lap) - ;; (comp-log lap) - ;; (let ((lambda-list (aref (comp-func-byte-func func) 0))) - ;; (setf (comp-func-args func) - ;; (comp-decrypt-lambda-list lambda-list))) - ;; (setf (comp-func-lap func) lap) - ;; (setf (comp-func-frame-size func) - ;; (comp-byte-frame-size (comp-func-byte-func func))) - ;; func)) - ) +(cl-defgeneric comp-spill-lap-function (input) + "Byte compile INPUT and spill lap for further stages.") -(defun comp-spill-lap-functions-file (filename) +(cl-defgeneric comp-spill-lap-function ((function-name symbol)) + "Byte compile FUNCTION-NAME spilling data from the byte compiler." + (let* ((f (symbol-function function-name)) + (func (make-comp-func :symbol-name function-name + :c-func-name (comp-c-func-name + function-name + "F")))) + (when (byte-code-function-p f) + (signal 'native-compiler-error + "can't native compile an already bytecompiled function")) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) + (let ((lap (alist-get nil byte-to-native-lap))) + (cl-assert lap) + (comp-log lap 1) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list) + (comp-func-lap func) lap + (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func)))) + (list func)))) + +(cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms @@ -472,9 +474,7 @@ If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lap ()) (byte-to-native-top-level-forms ())) - (cl-typecase input - (symbol (list (comp-spill-lap-function input))) - (string (comp-spill-lap-functions-file input))))) + (comp-spill-lap-function input))) ;;; Limplification pass specific code. @@ -1860,7 +1860,7 @@ Return the compilation unit file name." (comp-native-compiling t) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) - (symbol-name input) + (make-temp-file (concat (symbol-name input) "-")) (file-name-sans-extension (expand-file-name input)))))) (comp-log "\n \n" 1) (condition-case err From c039822082983d6618b6e06c73a31cf6b63467cc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 23 Nov 2019 17:27:44 +0100 Subject: [PATCH 0595/1452] better style into comp-tests-bootstrap --- test/src/comp-tests.el | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a0e6e23cefd..361f116edae 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -45,16 +45,12 @@ Check that the resulting binaries do not differ." (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) - (comp1-src (concat temporary-file-directory - (make-temp-name "stage1-") - ".el")) - (comp2-src (concat temporary-file-directory - (make-temp-name "stage2-") - ".el")) + (comp1-src (make-temp-file "stage1-" nil ".el")) + (comp2-src (make-temp-file "stage2-" nil ".el")) (comp1 (concat comp1-src "n")) (comp2 (concat comp2-src "n"))) - (copy-file comp-src comp1-src) - (copy-file comp-src comp2-src) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) (load (concat comp-src "c") nil nil t t) (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) (message "Compiling stage1...") From 960aa0c7985f6c61a26f99653c6e9ae9369e944e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 15:07:54 +0100 Subject: [PATCH 0596/1452] review two slot names in comp-func --- lisp/emacs-lisp/comp.el | 46 +++++++++++++++++++---------------------- src/comp.c | 8 +++---- 2 files changed, 25 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7358e8616cc..217b7ffcd86 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -223,10 +223,10 @@ Is in use to help the SSA rename pass.")) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." - (symbol-name nil - :documentation "Function's symbol name.") - (c-func-name nil :type string - :documentation "The function name in the native world.") + (name nil :type symbol + :documentation "Function symbol name.") + (c-name nil :type string + :documentation "The function name in the native world.") (byte-func nil :documentation "Byte compiled version.") (doc nil :type string @@ -346,7 +346,7 @@ BODY is evaluate only if `comp-verbose' is > 0." "Log function FUNC. VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) - (comp-log (format "\nFunction: %s\n" (comp-func-symbol-name func)) verbosity) + (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (comp-log (concat "<" (symbol-name block-name) ">\n") verbosity) @@ -357,7 +357,7 @@ VERBOSITY is a number between 0 and 3." (let ((edges (comp-func-edges func))) (when (> comp-verbose 2) (comp-log (format "\nEdges in function: %s\n" - (comp-func-symbol-name func)) + (comp-func-name func)) 0)) (mapc (lambda (e) (when (> comp-verbose 2) @@ -418,15 +418,13 @@ Put PREFIX in front of it." (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) - (func (make-comp-func :symbol-name function-name - :c-func-name (comp-c-func-name - function-name - "F")))) + (func (make-comp-func :name function-name + :c-name (comp-c-func-name function-name"F")))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) + (byte-compile (comp-func-name func))) (let ((lap (alist-get nil byte-to-native-lap))) (cl-assert lap) (comp-log lap 1) @@ -454,12 +452,10 @@ Put PREFIX in front of it." for doc = (when (>= (length data) 5) (aref data 4)) for lap = (alist-get name byte-to-native-lap) for lambda-list = (aref data 0) - for func = (make-comp-func :symbol-name name + for func = (make-comp-func :name name :byte-func data :doc doc - :c-func-name (comp-c-func-name - name - "F") + :c-name (comp-c-func-name name "F") :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (comp-byte-frame-size data)) @@ -1078,7 +1074,7 @@ the annotation emission." (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f)) - (c-name (comp-func-c-func-name f)) + (c-name (comp-func-c-name f)) (doc (comp-func-doc f))) (cl-assert (and name f)) (comp-emit (comp-call 'comp--register-subr @@ -1099,10 +1095,10 @@ the annotation emission." (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. This will be called at load-time." - (let* ((func (make-comp-func :symbol-name 'top-level-run - :c-func-name "top_level_run" - :args (make-comp-args :min 0 :max 0) - :frame-size 0)) + (let* ((func (make-comp-func :name 'top-level-run + :c-name "top_level_run" + :args (make-comp-args :min 0 :max 0) + :frame-size 0)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block -1 0 'top-level) @@ -1163,7 +1159,7 @@ This will be called at load-time." ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " - (symbol-name (comp-func-symbol-name func)))) + (symbol-name (comp-func-name func)))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) @@ -1188,7 +1184,7 @@ This will be called at load-time." (defun comp-add-func-to-ctxt (func) "Add FUNC to the current compiler contex." - (puthash (comp-func-symbol-name func) + (puthash (comp-func-name func) func (comp-ctxt-funcs-h comp-ctxt))) @@ -1243,7 +1239,7 @@ Top level forms for the current context are rendered too." (signal 'native-ice (list "block does not end with a branch" bb - (comp-func-symbol-name comp-func))))) + (comp-func-name comp-func))))) finally (setf (comp-func-edges comp-func) (nreverse (comp-func-edges comp-func))) ;; Update edge refs into blocks. @@ -1657,7 +1653,7 @@ Return t if something was changed." (defun comp-call-optim-func () "Perform the trampoline call optimization for the current function." (cl-loop - with self = (comp-func-symbol-name comp-func) + with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn-cell on (comp-block-insns b) @@ -1717,7 +1713,7 @@ Return the list of m-var ids nuked." ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n" - (comp-func-symbol-name comp-func) + (comp-func-name comp-func) l-vals r-vals nuke-list) diff --git a/src/comp.c b/src/comp.c index e7b8a044252..cbc91758fa7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2739,7 +2739,7 @@ static void declare_function (Lisp_Object func) { gcc_jit_function *gcc_func; - char *c_name = SSDATA (CALL1I (comp-func-c-func-name, func)); + char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); Lisp_Object args = CALL1I (comp-func-args, func); bool nargs = (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -2784,7 +2784,7 @@ declare_function (Lisp_Object func) c_name, 2, param, 0); } - Fputhash (CALL1I (comp-func-symbol-name, func), + Fputhash (CALL1I (comp-func-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); @@ -2797,7 +2797,7 @@ compile_function (Lisp_Object func) USE_SAFE_ALLOCA; EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); - comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-symbol-name, func), + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), comp.exported_funcs_h, Qnil)); gcc_jit_lvalue *frame_array = @@ -2883,7 +2883,7 @@ compile_function (Lisp_Object func) if (err) xsignal3 (Qnative_ice, build_string ("failing to compile function"), - CALL1I (comp-func-symbol-name, func), + CALL1I (comp-func-name, func), build_string (err)); SAFE_FREE (); From 0c94e69fa6ed5a4f5d551f37f7f2632d2f2b2952 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 16:03:01 +0100 Subject: [PATCH 0597/1452] add comp-tests-free-fun --- test/src/comp-tests.el | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 361f116edae..570dcbd1ffa 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -30,7 +30,7 @@ (require 'comp) ;; (setq comp-debug 1) -(setq comp-speed 3) +(setq comp-speed 0) (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) @@ -307,6 +307,14 @@ Check that the resulting binaries do not differ." ;; See `comp-propagate-insn' `comp-function-call-remove'. (should (= (comp-tests-func-call-removal-f) 1))) +(ert-deftest comp-tests-free-fun () + "Check we are able to compile a single function." + (defun comp-tests-free-fun-f () + 3) + (load (native-compile #'comp-tests-free-fun-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (= (comp-tests-free-fun-f) 3))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; From 4fc8524df0e2ce0579d6bc298dc07d1e442587c6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 16:18:51 +0100 Subject: [PATCH 0598/1452] fix single function top level generation --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 217b7ffcd86..47d4de87c6b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -434,6 +434,8 @@ Put PREFIX in front of it." (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-function :name function-name))) (list func)))) (cl-defgeneric comp-spill-lap-function ((filename string)) From d2d229043674c59dead9a58a9ae20f8e62427fc1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 16:21:43 +0100 Subject: [PATCH 0599/1452] better comp-byte-frame-size --- lisp/emacs-lisp/comp.el | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 47d4de87c6b..1815b1709a8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -406,11 +406,9 @@ Put PREFIX in front of it." :nonrest nonrest :rest rest)))) -(defun comp-byte-frame-size (byte-compiled-func) +(defsubst comp-byte-frame-size (byte-compiled-func) "Given BYTE-COMPILED-FUNC return the frame size to be allocated." - ;; Is this really correct? - ;; For the 1+ see bytecode.c:365 (finger crossed). - (1+ (aref byte-compiled-func 3))) + (aref byte-compiled-func 3)) (cl-defgeneric comp-spill-lap-function (input) "Byte compile INPUT and spill lap for further stages.") @@ -431,7 +429,8 @@ Put PREFIX in front of it." (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list) - (comp-func-lap func) lap + (comp-func-lap func) + lap (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) From d4a5aba954c838b32317560dd84e6681578b0e32 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 16:39:56 +0100 Subject: [PATCH 0600/1452] update limple comments --- src/comp.c | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index cbc91758fa7..fd7707a2630 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1083,9 +1083,8 @@ static gcc_jit_rvalue * emit_set_internal (Lisp_Object args) { /* - Ex: (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil)) + Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil) + #s(comp-mvar 1 4 t nil symbol nil)). */ /* TODO: Inline the most common case. */ if (list_length (args) != 3) @@ -1128,8 +1127,7 @@ static gcc_jit_rvalue * emit_simple_limple_call_lisp_ret (Lisp_Object args) { /* - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil)) + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)). */ return emit_simple_limple_call (args, comp.lisp_obj_type, false); } @@ -1160,8 +1158,9 @@ emit_limple_call (Lisp_Object insn) static gcc_jit_rvalue * emit_limple_call_ref (Lisp_Object insn, bool direct) { - /* Ex: (callref < #s(comp-mvar 1 6 nil nil nil t) - #s(comp-mvar 2 11 t 10 integer t)). */ + /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t) + #s(comp-mvar 2 6 nil nil nil t) + #s(comp-mvar 3 7 t 0 fixnum t)). */ Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); @@ -1384,7 +1383,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qset_par_to_local)) { - /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ + /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */ EMACS_INT param_n = XFIXNUM (arg[1]); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, @@ -1394,7 +1393,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_args_to_local)) { /* - Limple: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) + Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) C: local[1] = *args; */ gcc_jit_rvalue *gcc_args = @@ -1409,7 +1408,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_rest_args_to_local)) { /* - Limple: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) + Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) C: local[2] = list (nargs - 2, args); */ @@ -1440,7 +1439,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qinc_args)) { /* - Limple: (inc-args) + Ex: (inc-args) C: ++args; */ gcc_jit_lvalue *args = @@ -1457,7 +1456,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ + /* Ex: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1473,7 +1472,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qcomment)) { - /* Ex: (comment "Function: foo"). */ + /* Ex: (comment "Function: foo"). */ emit_comment (SSDATA (arg[0])); } else if (EQ (op, Qreturn)) From ea421cfefef6826dd99a9cc884b46178b2c0e1a8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 18:25:04 +0100 Subject: [PATCH 0601/1452] do not use thread for async compilation --- lisp/emacs-lisp/comp.el | 72 +++++++++++++++++++++++------------------ 1 file changed, 41 insertions(+), 31 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1815b1709a8..28b83a6199b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,6 +77,11 @@ This intended for debugging the compiler itself. (defconst native-compile-log-buffer "*Native-compile-Log*" "Name of the native-compiler log buffer.") +(defcustom comp-async-buffer-name "*Async-compilation*" + "Name of the async compilation buffer log." + :type 'string + :group 'comp) + (defvar comp-native-compiling nil "This gets bound to t while native compilation. Can be used by code that wants to expand differently in this case.") @@ -1803,8 +1808,8 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-src-pool () "List containing the files to be compiled.") -(defvar comp-src-pool-mutex (make-mutex) - "Mutex for `comp-src-pool'.") +(defvar comp-prc-pool () + "List containing all async compilation processes.") (defun comp-to-file-p (file) "Return t if FILE has to be compiled." @@ -1813,32 +1818,37 @@ Prepare every function for final compilation and drive the C back-end." (not (and (file-exists-p compiled-f) (file-newer-than-file-p compiled-f file)))))) -(defun comp-start-async-worker () - "Start an async compiler worker." - (make-thread - (lambda () - (let (f) - (while (setf f (with-mutex comp-src-pool-mutex - (pop comp-src-pool))) - (when (comp-to-file-p f) - (let* ((code `(progn - (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - load-path ',load-path) - (message "Compiling %s started." ,f) - (native-compile ,f))) - (prc (start-process (concat "Compiling: " f) - "async-compile-buffer" - (concat invocation-directory invocation-name) - "--batch" - "--eval" - (prin1-to-string code)))) - (while (accept-process-output prc) - (thread-yield))))) - (message "Finished compiling."))) - "compilation thread")) +(cl-defun comp-start-async-worker () + "Run an async compile worker." + (let (f) + (while (setf f (pop comp-src-pool)) + (when (comp-to-file-p f) + (let* ((code `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + load-path ',load-path) + (message "Compiling %s started." ,f) + (native-compile ,f)))) + (push (make-process :name (concat "Compiling: " f) + :buffer (get-buffer-create comp-async-buffer-name) + :command (list (concat invocation-directory + invocation-name) + "--batch" + "--eval" + (prin1-to-string code)) + :sentinel (lambda (prc _event) + (accept-process-output prc) + (comp-start-async-worker))) + comp-prc-pool) + (cl-return-from comp-start-async-worker)))) + (when (cl-notany #'process-live-p comp-prc-pool) + (let ((msg "Compilation finished.")) + (setf comp-prc-pool ()) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (insert msg "\n")) + (message msg))))) ;;; Compiler entry points. @@ -1888,10 +1898,10 @@ Follow folders RECURSIVELY if non nil." (list input) (signal 'native-compiler-error "input not a file nor directory"))))) - (with-mutex comp-src-pool-mutex - (setf comp-src-pool (nconc files comp-src-pool))) + (setf comp-src-pool (nconc files comp-src-pool)) (cl-loop repeat jobs - do (comp-start-async-worker)))) + do (comp-start-async-worker)) + (message "Compilation started."))) (provide 'comp) From f0b1519fbd0fea728238758d6bec074c32be1142 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 18:34:54 +0100 Subject: [PATCH 0602/1452] rename native-compile-log-buffer -> comp-log-buffer-name --- lisp/emacs-lisp/comp.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 28b83a6199b..b1460f21c5d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,8 +74,10 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) -(defconst native-compile-log-buffer "*Native-compile-Log*" - "Name of the native-compiler log buffer.") +(defconst comp-log-buffer-name "*Native-compile-Log*" + "Name of the native-compiler log buffer." + :type 'string + :group 'comp) (defcustom comp-async-buffer-name "*Async-compilation*" "Name of the async compilation buffer log." @@ -324,7 +326,7 @@ BODY is evaluate only if `comp-verbose' is > 0." (declare (debug (form body)) (indent defun)) `(when (> comp-verbose 0) - (with-current-buffer (get-buffer-create native-compile-log-buffer) + (with-current-buffer (get-buffer-create comp-log-buffer-name) (setf buffer-read-only t) (let ((inhibit-read-only t)) (goto-char (point-max)) From 831f5e606125c48f783daee9643d101b7fad665f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 18:42:40 +0100 Subject: [PATCH 0603/1452] make buffer names constant --- lisp/emacs-lisp/comp.el | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b1460f21c5d..1f23edb58f1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -75,14 +75,10 @@ This intended for debugging the compiler itself. :group 'comp) (defconst comp-log-buffer-name "*Native-compile-Log*" - "Name of the native-compiler log buffer." - :type 'string - :group 'comp) + "Name of the native-compiler log buffer.") -(defcustom comp-async-buffer-name "*Async-compilation*" - "Name of the async compilation buffer log." - :type 'string - :group 'comp) +(defconst comp-async-buffer-name "*Async-native-compile-log*" + "Name of the async compilation buffer log.") (defvar comp-native-compiling nil "This gets bound to t while native compilation. From 9650e5a1a90768953ce9f3eef014616180bfed8e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 18:48:37 +0100 Subject: [PATCH 0604/1452] revert unnecessary modifications --- lisp/emacs-lisp/byte-run.el | 2 -- lisp/emacs-lisp/bytecomp.el | 1 - src/lread.c | 11 ++++------- 3 files changed, 4 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index fedbd61ffd1..6a49c60099d 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -597,6 +597,4 @@ Otherwise, return nil. For internal use only." (make-obsolete 'macro-declaration-function 'macro-declarations-alist "24.3") -(provide 'byte-run) - ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ebbee2a0c7c..7be43204a16 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,7 +124,6 @@ (require 'backquote) (require 'macroexp) (require 'cconv) -(require 'byte-run) (eval-when-compile (require 'compile)) ;; Refrain from using cl-lib at run-time here, since it otherwise prevents ;; us from emitting warnings when compiling files which use cl-lib without diff --git a/src/lread.c b/src/lread.c index f1b17edd011..bd7182c398f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4195,16 +4195,13 @@ intern_c_string_1 (const char *str, ptrdiff_t len) { Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); - Lisp_Object string; if (!SYMBOLP (tem)) { - if (NILP (Vpurify_flag)) - string = make_string (str, len); - else - string = make_pure_c_string (str, len); - - tem = intern_driver (string, obarray, 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); } return tem; } From ba2bbea816ac5a20fa3090b634a17ed0d4a1c2ca Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 19:49:25 +0100 Subject: [PATCH 0605/1452] adjust print verbosity according to the doc --- lisp/emacs-lisp/comp.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1f23edb58f1..60cfd8e5163 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -428,7 +428,7 @@ Put PREFIX in front of it." (byte-compile (comp-func-name func))) (let ((lap (alist-get nil byte-to-native-lap))) (cl-assert lap) - (comp-log lap 1) + (comp-log lap 2) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list) @@ -1776,6 +1776,9 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." (let (compile-result) + (maphash (lambda (_ f) + (comp-log-func f 1)) + (comp-ctxt-funcs-h comp-ctxt)) (comp--init-ctxt) (unwind-protect (setf compile-result From 44023f3db21c0365ceeb179657447d7cdb1feb8f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 19:50:15 +0100 Subject: [PATCH 0606/1452] fix comp-log-edges --- lisp/emacs-lisp/comp.el | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60cfd8e5163..f9c0d62147e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -358,17 +358,15 @@ VERBOSITY is a number between 0 and 3." (defun comp-log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges func))) - (when (> comp-verbose 2) - (comp-log (format "\nEdges in function: %s\n" - (comp-func-name func)) - 0)) + (comp-log (format "\nEdges in function: %s\n" + (comp-func-name func)) + 2) (mapc (lambda (e) - (when (> comp-verbose 2) - (comp-log (format "n: %d src: %s dst: %s\n" - (comp-edge-number e) - (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e))) - 0))) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))) + 2)) edges))) From 6a3624eecbc0a116b293d05e044b8b40a86022e9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 23:22:49 +0100 Subject: [PATCH 0607/1452] fix wrong enum usage into declare_function --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index fd7707a2630..be92893d659 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2757,7 +2757,7 @@ declare_function (Lisp_Object func) type[i], format_string ("par_%d", i)); gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_GLOBAL_EXPORTED, + GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, c_name, max_args, From 10adad440b2eb3b09d9d4e876023dd13d8b3dab9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Nov 2019 23:23:16 +0100 Subject: [PATCH 0608/1452] update limple example --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index be92893d659..bb2b851e55a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1456,7 +1456,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* Ex: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ + /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, From ba51c31b47a62e6815d8cb2cb34ecd642a677105 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 25 Nov 2019 20:33:17 +0100 Subject: [PATCH 0609/1452] gate propagate to comp-speed > 1 --- lisp/emacs-lisp/comp.el | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f9c0d62147e..5f0b61b734f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1580,15 +1580,16 @@ Return t if something was changed." finally return modified)) (defun comp-propagate (_) - (maphash (lambda (_ f) - (let ((comp-func f)) - (comp-basic-const-propagate) - (cl-loop - for i from 1 - while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-log-func comp-func 3))) - (comp-ctxt-funcs-h comp-ctxt))) + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-basic-const-propagate) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt)))) ;;; Call optimizer pass specific code. From 5411beae0225937446eb8509c56277b120a2eb92 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 25 Nov 2019 20:33:47 +0100 Subject: [PATCH 0610/1452] remove unnecessary return when printing blocks --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5f0b61b734f..4167dcf4b91 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -352,7 +352,7 @@ VERBOSITY is a number between 0 and 3." (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) - do (comp-log (concat "<" (symbol-name block-name) ">\n") verbosity) + do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) (comp-log (comp-block-insns bb) verbosity)))) (defun comp-log-edges (func) From a214a29e48397cf259327e1ffb44479648301e47 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 25 Nov 2019 21:27:11 +0100 Subject: [PATCH 0611/1452] fix comp-propagate-insn type propagation --- lisp/emacs-lisp/comp.el | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4167dcf4b91..2ac912929d1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1553,14 +1553,19 @@ This can run just once." (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) ;; Const prop here. - (when (and (cl-every #'comp-mvar-const-vld rest) - (cl-reduce #'equal (mapcar #'comp-mvar-constant rest))) - (setf (comp-mvar-constant lval) (comp-mvar-constant (car rest)))) + (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) + (consts (mapcar #'comp-mvar-constant rest)) + (x (car consts)) + (equals (cl-every (lambda (y) (equal x y)) consts))) + (setf (comp-mvar-constant lval) x)) ;; Type propagation. ;; FIXME: checking for type equality is not sufficient cause does not - ;; account type hierarchy!! - (when (cl-reduce #'eq (mapcar #'comp-mvar-type rest)) - (setf (comp-mvar-type lval) (comp-mvar-type (car rest)))) + ;; account type hierarchy! + (when-let* ((types (mapcar #'comp-mvar-type rest)) + (non-empty (cl-notany #'null types)) + (x (car types)) + (eqs (cl-every (lambda (y) (eq x y)) types))) + (setf (comp-mvar-type lval) x)) ;; Reference propagation. (let ((operands (cons lval rest))) (when (cl-some #'comp-mvar-ref operands) From 7f5f60d54340aa0b36f22057fd3f2665fbcd5d67 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 25 Nov 2019 22:16:50 +0100 Subject: [PATCH 0612/1452] insert compilation end message at the bottom of the buffer --- lisp/emacs-lisp/comp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ac912929d1..b84a3e53364 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1852,7 +1852,9 @@ Prepare every function for final compilation and drive the C back-end." (let ((msg "Compilation finished.")) (setf comp-prc-pool ()) (with-current-buffer (get-buffer-create comp-async-buffer-name) - (insert msg "\n")) + (save-excursion + (goto-char (point-max)) + (insert msg "\n"))) (message msg))))) ;;; Compiler entry points. From 9a87c4404fd0097e2efa14f63b97a9df8df6c07d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 26 Nov 2019 17:13:44 +0100 Subject: [PATCH 0613/1452] native-compile-async accept list as input --- lisp/emacs-lisp/comp.el | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b84a3e53364..b225d4d9297 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1893,18 +1893,20 @@ Return the compilation unit file name." ;;;###autoload (defun native-compile-async (input &optional jobs recursively) "Compile INPUT asynchronously. -INPUT can be either a folder or a file. +INPUT can be either a list of files a folder or a file. JOBS specifies the number of jobs (commands) to run simultaneously (1 default). Follow folders RECURSIVELY if non nil." (let ((jobs (or jobs 1)) - (files (if (file-directory-p input) - (if recursively - (directory-files-recursively input "\\.el$") - (directory-files input t "\\.el$")) - (if (file-exists-p input) - (list input) - (signal 'native-compiler-error - "input not a file nor directory"))))) + (files (if (listp input) + input + (if (file-directory-p input) + (if recursively + (directory-files-recursively input "\\.el$") + (directory-files input t "\\.el$")) + (if (file-exists-p input) + (list input) + (signal 'native-compiler-error + "input not a file nor directory")))))) (setf comp-src-pool (nconc files comp-src-pool)) (cl-loop repeat jobs do (comp-start-async-worker)) From ce254ffa44e33352605e49aaa7d5fc4f545c1add Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 26 Nov 2019 21:48:21 +0100 Subject: [PATCH 0614/1452] do not emit elc file while native compiling --- lisp/emacs-lisp/bytecomp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7be43204a16..5d2558a579d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2032,7 +2032,9 @@ The value is non-nil if there were no errors, nil if errors." ;; 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)) + (if byte-native-compiling + (delete-file tempfile) + (rename-file tempfile target-file t))) (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (let ((exists (file-exists-p target-file))) From 4a639f3ae9594f0d16835d5151b6dda7e83e1a1f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 27 Nov 2019 00:23:56 +0100 Subject: [PATCH 0615/1452] documentation nit --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b225d4d9297..273bda8220f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -270,7 +270,7 @@ structure.") :documentation "When const-vld non nil this is used for holding a value known at compile time.") (type nil - :documentation "When non nil is used for type when known at compile + :documentation "When non nil indicates the type when known at compile time.") (ref nil :type boolean :documentation "When t the m-var is involved in a call where is passed by From 60a81f44e49c77ef9143a665f94f89109002133d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 27 Nov 2019 20:11:40 +0100 Subject: [PATCH 0616/1452] better naming variable --- src/comp.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index bb2b851e55a..e2629de0426 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2285,7 +2285,7 @@ define_CAR_CDR (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_cons") }; + "cert_cons") }; /* TODO: understand why after ipa-prop pass gcc is less keen on inlining and as consequence can refuse to compile these. (see dhrystone.el) Flag this and all the one involved in ipa-prop as @@ -2374,7 +2374,7 @@ define_setcar_setcdr (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_cons") }; + "cert_cons") }; gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, @@ -2443,7 +2443,7 @@ define_add1_sub1 (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_fixnum") }; + "cert_fixnum") }; comp.func = func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_INTERNAL, @@ -2457,7 +2457,7 @@ define_add1_sub1 (void) comp.block = entry_block; - /* is_fixnum || + /* cert_fixnum || ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM ? (XFIXNUM (n) + 1) : Fadd1 (n)) */ @@ -2526,7 +2526,7 @@ define_negate (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_fixnum") }; + "cert_fixnum") }; comp.func = comp.negate = gcc_jit_context_new_function (comp.ctxt, NULL, @@ -2541,7 +2541,7 @@ define_negate (void) comp.block = entry_block; - /* (is_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); From e05253cb9bc4a35c7dedc3cbb2830e37d385a339 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 10:24:13 +0100 Subject: [PATCH 0617/1452] let intern_c_string works creating with non-pure strings --- src/lread.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/lread.c b/src/lread.c index bd7182c398f..f280dad97c0 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4198,10 +4198,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; } From f4de790beec514808eafd1cb22fa5eacdecd4552 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 11:28:21 +0100 Subject: [PATCH 0618/1452] add native compiled function docstring support --- lisp/help-fns.el | 8 +++++--- src/alloc.c | 4 ++-- src/comp.c | 8 ++++++-- src/doc.c | 12 +++++++++++- src/lisp.h | 9 ++++++--- 5 files changed, 30 insertions(+), 11 deletions(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0e2ae6b3c3c..afa5c9be940 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -377,7 +377,7 @@ suitable file is found, return nil." ;; This applies to config files like ~/.emacs, ;; which people sometimes compile. ((let (fn) - (and (string-match "\\`\\..*\\.elc\\'" + (and (string-match "\\`\\..*\\.el[cn]\\'" (file-name-nondirectory file-name)) (string-equal (file-name-directory file-name) (file-name-as-directory (expand-file-name "~"))) @@ -386,7 +386,7 @@ suitable file is found, return nil." ;; When the Elisp source file can be found in the install ;; directory, return the name of that file. ((let ((lib-name - (if (string-match "[.]elc\\'" file-name) + (if (string-match "[.]el[cn]\\'" file-name) (substring-no-properties file-name 0 -1) file-name))) (or (and (file-readable-p lib-name) lib-name) @@ -399,7 +399,7 @@ suitable file is found, return nil." ;; name, convert that back to a file name and see if we ;; get the original one. If so, they are equivalent. (if (equal file-name (locate-file lib-name load-path '(""))) - (if (string-match "[.]elc\\'" lib-name) + (if (string-match "[.]el[cn]\\'" lib-name) (substring-no-properties lib-name 0 -1) lib-name) file-name)) @@ -738,6 +738,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) + "native compiled Lisp function") ((subrp def) (concat beg (if (eq 'unevalled (cdr (subr-arity def))) "special form" diff --git a/src/alloc.c b/src/alloc.c index 1c6b664b220..00da90464be 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7450,14 +7450,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); } diff --git a/src/comp.c b/src/comp.c index e2629de0426..5a00200ee87 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3317,17 +3317,21 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); + /* FIXME add gc support, now just leaking. */ union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; - x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.intspec = NULL; - x->s.doc = 0; /* FIXME */ + x->s.native_doc = doc; x->s.native_elisp = true; defsubr (x); + LOADHIST_ATTACH (Fcons (Qdefun, name)); + return Qnil; } diff --git a/src/doc.c b/src/doc.c index 285c0dbbbee..369997a3db4 100644 --- a/src/doc.c +++ b/src/doc.c @@ -335,6 +335,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 = XSUBR (fun)->native_doc; + else +#endif if (SUBRP (fun)) doc = make_fixnum (XSUBR (fun)->doc); #ifdef HAVE_MODULES @@ -508,7 +513,12 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) - XSUBR (fun)->doc = offset; + { +#ifdef HAVE_NATIVE_COMP + eassert (NILP (Fsubr_native_elisp_p (fun))); +#endif + XSUBR (fun)->doc = offset; + } /* Bytecode objects sometimes have slots for it. */ else if (COMPILEDP (fun)) diff --git a/src/lisp.h b/src/lisp.h index a84c08e5669..1c692933cdb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2087,10 +2087,13 @@ struct Lisp_Subr short min_args, max_args; const char *symbol_name; const char *intspec; - EMACS_INT doc; + union { + EMACS_INT doc; #ifdef HAVE_NATIVE_COMP - bool native_elisp; + Lisp_Object native_doc; #endif + }; + bool native_elisp; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -3103,7 +3106,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); From e2855d93ee41bf23a72fdcb49bd5347512989f6f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 17:31:54 +0100 Subject: [PATCH 0619/1452] renaming comp-decrypt-lambda-list -> comp-decrypt-arg-list --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 273bda8220f..30db2f18918 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -391,8 +391,8 @@ Put PREFIX in front of it." (rx (not (any "0-9a-z_"))) "" human-readable))) (concat prefix crypted "_" human-readable))) -(defun comp-decrypt-lambda-list (x) - "Decript lambda list X." +(defun comp-decrypt-arg-list (x) + "Decript argument list X." (unless (fixnump x) (signal 'native-compiler-error "can't native compile a non lexical scoped function")) @@ -427,9 +427,9 @@ Put PREFIX in front of it." (let ((lap (alist-get nil byte-to-native-lap))) (cl-assert lap) (comp-log lap 2) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (let ((arg-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list) + (comp-decrypt-arg-list arg-list) (comp-func-lap func) lap (comp-func-frame-size func) From d7071c64575bd3116e154f93915ff099c6e0f3a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 17:37:31 +0100 Subject: [PATCH 0620/1452] spill also interactive functions --- lisp/emacs-lisp/bytecomp.el | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5d2558a579d..3e354951ea3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2714,10 +2714,7 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (if (commandp code) - (make-byte-to-native-top-level ;FIXME compile interactive functions. - :form `(defalias ',name ,code)) - (make-byte-to-native-function :name name :data code))) + (make-byte-to-native-function :name name :data 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. From 48f5530e7922e4c46db1c4ab82b1c3532db724c9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 17:38:08 +0100 Subject: [PATCH 0621/1452] add int-spec to comp-func --- lisp/emacs-lisp/comp.el | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 30db2f18918..e46453e8516 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -234,6 +234,8 @@ Is in use to help the SSA rename pass.")) :documentation "Byte compiled version.") (doc nil :type string :documentation "Doc string.") + (int-spec nil :type list + :documentation "Interactive form.") (lap () :type list :documentation "LAP assembly representation.") (args nil :type comp-args-base) @@ -451,15 +453,14 @@ Put PREFIX in front of it." collect x) for name = (byte-to-native-function-name f) for data = (byte-to-native-function-data f) - for doc = (when (>= (length data) 5) (aref data 4)) for lap = (alist-get name byte-to-native-lap) - for lambda-list = (aref data 0) for func = (make-comp-func :name name :byte-func data - :doc doc + :doc (documentation data) + :int-spec (interactive-form data) :c-name (comp-c-func-name name "F") - :args (comp-decrypt-lambda-list lambda-list) - :lap lap + :args (comp-decrypt-arg-list (aref data 0)) + :lap (alist-get name byte-to-native-lap) :frame-size (comp-byte-frame-size data)) do (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1) From a248dfe2c3341ed73de38c2feea64ec12f053aaa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 18:19:00 +0100 Subject: [PATCH 0622/1452] native compile interactive functions support --- lisp/emacs-lisp/comp.el | 10 +++++----- src/alloc.c | 4 ++-- src/comp.c | 6 +++--- src/data.c | 4 ++++ src/lisp.h | 9 +++++++-- 5 files changed, 21 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e46453e8516..ffd4985301e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1076,9 +1076,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f)) - (c-name (comp-func-c-name f)) - (doc (comp-func-doc f))) + (args (comp-func-args f))) (cl-assert (and name f)) (comp-emit (comp-call 'comp--register-subr (make-comp-mvar :constant name) @@ -1086,8 +1084,10 @@ the annotation emission." (make-comp-mvar :constant (if (comp-args-p args) (comp-args-max args) 'many)) - (make-comp-mvar :constant c-name) - (make-comp-mvar :constant doc))))) + (make-comp-mvar :constant (comp-func-c-name f)) + (make-comp-mvar :constant (comp-func-doc f)) + (make-comp-mvar :constant + (comp-func-int-spec f)))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) diff --git a/src/alloc.c b/src/alloc.c index 00da90464be..5ff0d907915 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7450,14 +7450,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}, 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}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index 5a00200ee87..a15bedf41aa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3304,11 +3304,11 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 5, 5, 0, + 6, 6, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc) + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) @@ -3325,7 +3325,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); - x->s.intspec = NULL; + x->s.native_intspec = intspec; x->s.native_doc = doc; x->s.native_elisp = true; defsubr (x); diff --git a/src/data.c b/src/data.c index 50dce9e4644..67613881d67 100644 --- a/src/data.c +++ b/src/data.c @@ -899,6 +899,10 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { +#ifdef HAVE_NATIVE_COMP + if (XSUBR (fun)->native_elisp && XSUBR (fun)->native_intspec) + return XSUBR (fun)->native_intspec; +#endif const char *spec = XSUBR (fun)->intspec; if (spec) return list2 (Qinteractive, diff --git a/src/lisp.h b/src/lisp.h index 1c692933cdb..56aa7b151e6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2086,7 +2086,12 @@ struct Lisp_Subr } function; short min_args, max_args; const char *symbol_name; - const char *intspec; + union { + const char *intspec; +#ifdef HAVE_NATIVE_COMP + Lisp_Object native_intspec; +#endif + }; union { EMACS_INT doc; #ifdef HAVE_NATIVE_COMP @@ -3106,7 +3111,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}, 0}}; \ Lisp_Object fnname /* defsubr (Sname); From 3345399e87fe6100ef82c399337760ab01182240 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Dec 2019 10:28:23 +0100 Subject: [PATCH 0623/1452] add native documentation support test --- test/src/comp-test-funcs.el | 4 ++++ test/src/comp-tests.el | 6 ++++++ 2 files changed, 10 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 20d15ac0e7a..5e2fb0bd99a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -257,6 +257,10 @@ (b 3)) (% a b))) +(defun comp-tests-doc-f () + "A nice docstring" + t) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 570dcbd1ffa..73c1fe14caa 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -307,6 +307,12 @@ Check that the resulting binaries do not differ." ;; See `comp-propagate-insn' `comp-function-call-remove'. (should (= (comp-tests-func-call-removal-f) 1))) +(ert-deftest comp-tests-doc () + (should (string= (documentation #'comp-tests-doc-f) + "A nice docstring")) + (should (string= (symbol-file #'comp-tests-doc-f) + (concat comp-test-src "n")))) + (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." (defun comp-tests-free-fun-f () From b3db331e8c36ef9706ad16c12055079bcd93c022 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Dec 2019 10:28:54 +0100 Subject: [PATCH 0624/1452] add native interactive support test --- test/src/comp-test-funcs.el | 11 +++++++++++ test/src/comp-tests.el | 12 ++++++++++++ 2 files changed, 23 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5e2fb0bd99a..cbf287838cb 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -261,6 +261,17 @@ "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)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 73c1fe14caa..230d5bfbdaf 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -313,6 +313,18 @@ Check that the resulting binaries do not differ." (should (string= (symbol-file #'comp-tests-doc-f) (concat comp-test-src "n")))) +(ert-deftest comp-test-interactive-form () + (should (equal (interactive-form #'comp-test-interactive-form0-f) + '(interactive "D"))) + (should (equal (interactive-form #'comp-test-interactive-form1-f) + '(interactive '(1 2)))) + (should (equal (interactive-form #'comp-test-interactive-form2-f) + '(interactive nil))) + (should (cl-every #'commandp '(comp-test-interactive-form0-f + comp-test-interactive-form1-f + comp-test-interactive-form2-f))) + (should-not (commandp #'comp-tests-doc-f))) + (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." (defun comp-tests-free-fun-f () From 6c9acd13d0d2aa181d21bf78d6530b3399520533 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Dec 2019 20:52:34 +0100 Subject: [PATCH 0625/1452] single function native compilation doc + interactive support + tests --- lisp/emacs-lisp/comp.el | 4 +++- test/src/comp-tests.el | 10 +++++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ffd4985301e..0f0a90c82fb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -420,7 +420,9 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :name function-name - :c-name (comp-c-func-name function-name"F")))) + :c-name (comp-c-func-name function-name"F") + :doc (documentation f) + :int-spec (interactive-form f)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 230d5bfbdaf..82a30424d09 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -328,10 +328,18 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." (defun comp-tests-free-fun-f () + "Some doc." + (interactive) 3) (load (native-compile #'comp-tests-free-fun-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) - (should (= (comp-tests-free-fun-f) 3))) + (should (= (comp-tests-free-fun-f) 3)) + (should (string= (documentation #'comp-tests-free-fun-f) + "Some doc.")) + (should (commandp #'comp-tests-free-fun-f)) + (should (equal (interactive-form #'comp-tests-free-fun-f) + '(interactive)))) ;;;;;;;;;;;;;;;;;;;; From 54e0b112d3a91c86230bc4329e00ae8f2faa05e8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Dec 2019 08:57:17 +0100 Subject: [PATCH 0626/1452] style nit --- src/comp.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index a15bedf41aa..6722d7fb80e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3302,8 +3302,7 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) return; } -DEFUN ("comp--register-subr", Fcomp__register_subr, - Scomp__register_subr, +DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 6, 6, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) From 26ce5664ae431ec141e852a4183844d83c3f8856 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 08:58:17 +0100 Subject: [PATCH 0627/1452] use safe alloca in declare_imported_func --- src/comp.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6722d7fb80e..42f3b5d04f9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -330,6 +330,7 @@ static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { + USE_SAFE_ALLOCA; /* Don't want to declare the same function two times. */ if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil))) xsignal2 (Qnative_ice, @@ -339,19 +340,19 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, if (nargs == MANY) { nargs = 2; - types = alloca (nargs * sizeof (* types)); + types = SAFE_ALLOCA (nargs * sizeof (* types)); types[0] = comp.ptrdiff_type; types[1] = comp.lisp_obj_ptr_type; } else if (nargs == UNEVALLED) { nargs = 1; - types = alloca (nargs * sizeof (* types)); + types = SAFE_ALLOCA (nargs * sizeof (* types)); types[0] = comp.lisp_obj_type; } else if (!types) { - types = alloca (nargs * sizeof (* types)); + types = SAFE_ALLOCA (nargs * sizeof (* types)); for (ptrdiff_t i = 0; i < nargs; i++) types[i] = comp.lisp_obj_type; } @@ -375,6 +376,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, SSDATA (f_ptr_name)); Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h); + SAFE_FREE (); return field; } From 8234a62e6fb9f706f410a96e2ce9877c19e44a20 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 09:35:50 +0100 Subject: [PATCH 0628/1452] stringify within macro ADD_IMPORTED --- src/comp.c | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index 42f3b5d04f9..70b423aa97a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -68,7 +68,7 @@ along with GNU Emacs. If not, see . */ #else #define SETJMP setjmp #endif -#define SETJMP_NAME STR (SETJMP) +#define SETJMP_NAME SETJMP /* C side of the compiler context. */ @@ -1199,7 +1199,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue *res; res = - emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); + emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, false); emit_cond_jump (res, handler_bb, guarded_bb); } @@ -1713,7 +1713,7 @@ declare_runtime_imported_funcs (void) Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ { \ - Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object name = intern_c_string (STR (f_name)); \ Lisp_Object field = \ make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ Lisp_Object el = Fcons (name, field); \ @@ -1722,39 +1722,39 @@ declare_runtime_imported_funcs (void) gcc_jit_type *args[4]; - ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); + ADD_IMPORTED (wrong_type_argument, comp.void_type, 2, NULL); args[0] = comp.lisp_obj_type; args[1] = comp.int_type; - ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + ADD_IMPORTED (helper_PSEUDOVECTOR_TYPEP_XUNTAG, comp.bool_type, 2, args); - ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); + ADD_IMPORTED (pure_write_error, comp.void_type, 1, NULL); args[0] = comp.lisp_obj_type; args[1] = comp.int_type; - ADD_IMPORTED ("push_handler", comp.handler_ptr_type, 2, args); + ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); - ADD_IMPORTED ("record_unwind_protect_excursion", comp.void_type, 0, NULL); + ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); args[0] = comp.lisp_obj_type; - ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + ADD_IMPORTED (helper_unbind_n, comp.lisp_obj_type, 1, args); - ADD_IMPORTED ("helper_save_restriction", comp.void_type, 0, NULL); + ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL); - ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; args[3] = comp.int_type; - ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + ADD_IMPORTED (set_internal, comp.void_type, 4, args); args[0] = comp.lisp_obj_type; - ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + ADD_IMPORTED (helper_unwind_protect, comp.void_type, 1, args); args[0] = args[1] = comp.lisp_obj_type; - ADD_IMPORTED ("specbind", comp.void_type, 2, args); + ADD_IMPORTED (specbind, comp.void_type, 2, args); #undef ADD_IMPORTED @@ -3278,7 +3278,7 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) f_relocs[i] = (void *) pure_write_error; else if (!strcmp (f_str, "push_handler")) f_relocs[i] = (void *) push_handler; - else if (!strcmp (f_str, SETJMP_NAME)) + else if (!strcmp (f_str, STR (SETJMP_NAME))) f_relocs[i] = (void *) SETJMP; else if (!strcmp (f_str, "record_unwind_protect_excursion")) f_relocs[i] = (void *) record_unwind_protect_excursion; From 740462da6153b111a8196b003791a55c7f7fa878 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 15:06:07 +0100 Subject: [PATCH 0629/1452] remove ifdef where unnecessary and add where they are --- src/lisp.h | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/lisp.h b/src/lisp.h index 56aa7b151e6..25319047a69 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2088,17 +2088,15 @@ struct Lisp_Subr const char *symbol_name; union { const char *intspec; -#ifdef HAVE_NATIVE_COMP Lisp_Object native_intspec; -#endif }; union { EMACS_INT doc; -#ifdef HAVE_NATIVE_COMP Lisp_Object native_doc; -#endif }; +#ifdef HAVE_NATIVE_COMP bool native_elisp; +#endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { From 694ece772220346aef12520bc66ca401d08809bb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Dec 2019 09:28:12 +0100 Subject: [PATCH 0630/1452] reworking relocation mechanism to use one single table --- src/comp.c | 116 ++++++++++++++++++++++++++++++++-------------------- src/emacs.c | 4 ++ src/lisp.h | 3 +- src/lread.c | 3 ++ 4 files changed, 81 insertions(+), 45 deletions(-) diff --git a/src/comp.c b/src/comp.c index 70b423aa97a..a233187ccdf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,6 +70,16 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME SETJMP +/* Max number function importable by native compiled code. */ +#define F_RELOC_MAX_SIZE 1500 + +typedef struct { + void *link_table[F_RELOC_MAX_SIZE]; + ptrdiff_t size; +} f_reloc_t; + +static f_reloc_t freloc; + /* C side of the compiler context. */ typedef struct { @@ -157,7 +167,7 @@ typedef struct { gcc_jit_function *check_impure; Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ - Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ + Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -184,6 +194,20 @@ Lisp_Object helper_unbind_n (Lisp_Object n); void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); +void *helper_link_table[] = + { wrong_type_argument, + helper_PSEUDOVECTOR_TYPEP_XUNTAG, + pure_write_error, + push_handler, + SETJMP_NAME, + record_unwind_protect_excursion, + helper_unbind_n, + helper_save_restriction, + record_unwind_current_buffer, + set_internal, + helper_unwind_protect, + specbind }; + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) @@ -1758,7 +1782,7 @@ declare_runtime_imported_funcs (void) #undef ADD_IMPORTED - return field_list; + return Freverse (field_list); } /* @@ -1767,7 +1791,6 @@ declare_runtime_imported_funcs (void) static void emit_ctxt_code (void) { - USE_SAFE_ALLOCA; comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( @@ -1809,56 +1832,32 @@ emit_ctxt_code (void) emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); - /* Imported functions from non Lisp code. */ + /* Functions imported from Lisp code. */ + + static gcc_jit_field *fields[F_RELOC_MAX_SIZE]; + ptrdiff_t n_frelocs = 0; Lisp_Object f_runtime = declare_runtime_imported_funcs (); - EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); - - /* Imported subrs. */ - Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); - f_reloc_len += XFIXNUM (Flength (f_subr)); - - gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); - Lisp_Object f_reloc_list = Qnil; - int n_frelocs = 0; - FOR_EACH_TAIL (f_runtime) { Lisp_Object el = XCAR (f_runtime); + eassert (n_frelocs < ARRAYELTS (fields)); fields[n_frelocs++] = xmint_pointer (XCDR (el)); - f_reloc_list = Fcons (XCAR (el), f_reloc_list); } - FOR_EACH_TAIL (f_subr) + Lisp_Object subr_l = Vsubr_list; + FOR_EACH_TAIL (subr_l) { - Lisp_Object subr_sym = XCAR (f_subr); - Lisp_Object subr = symbol_subr (subr_sym); - /* Ignore inliners. This are not real functions to be imported. */ - if (SUBRP (subr)) - { - Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); - gcc_jit_field *field = - declare_imported_func (subr_sym, comp.lisp_obj_type, - FIXNUMP (maxarg) ? XFIXNUM (maxarg) : - EQ (maxarg, Qmany) ? MANY : UNEVALLED, - NULL); - fields[n_frelocs++] = field; - f_reloc_list = Fcons (subr_sym, f_reloc_list); - } + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + Lisp_Object subr_sym = intern_c_string (subr->symbol_name); + eassert (n_frelocs < ARRAYELTS (fields)); + fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type, + subr->max_args, NULL); } - Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); - f_reloc_list = Fnreverse (f_reloc_list); - ptrdiff_t i = 0; - FOR_EACH_TAIL (f_reloc_list) - { - ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); - } - emit_static_object (TEXT_IMPORTED_FUNC_RELOC_SYM, f_reloc_vec); - gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, NULL, - "function_reloc_struct", + "freloc_link_table", n_frelocs, fields); comp.func_relocs = gcc_jit_context_new_global ( @@ -1867,8 +1866,6 @@ emit_ctxt_code (void) GCC_JIT_GLOBAL_EXPORTED, gcc_jit_struct_as_type (f_reloc_struct), IMPORTED_FUNC_RELOC_SYM); - - SAFE_FREE (); } @@ -3038,8 +3035,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.exported_funcs_h = CALLN (Fmake_hash_table); /* - Always reinitialize this cause old function definitions are garbage collected - by libgccjit when the ctxt is released. + Always reinitialize this cause old function definitions are garbage + collected by libgccjit when the ctxt is released. */ comp.imported_funcs_h = CALLN (Fmake_hash_table); @@ -3140,6 +3137,29 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, } +void +fill_freloc (void) +{ + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) + goto overflow; + memcpy (freloc.link_table, helper_link_table, sizeof (freloc.link_table)); + freloc.size = ARRAYELTS (helper_link_table); + + Lisp_Object subr_l = Vsubr_list; + FOR_EACH_TAIL (subr_l) + { + if (freloc.size == F_RELOC_MAX_SIZE) + goto overflow; + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + freloc.link_table[freloc.size] = subr->function.a0; + freloc.size++; + } + return; + + overflow: + fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); +} + /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ @@ -3343,6 +3363,10 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); + if (!freloc.link_table[0]) + xsignal2 (Qnative_lisp_load_failed, file, + build_string ("Empty relocation table")); + Frequire (Qadvice, Qnil, Qnil); dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); @@ -3472,6 +3496,10 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; + /* FIXME should be initialized but not here... */ + DEFVAR_LISP ("comp-subr-list", Vsubr_list, + doc: /* List of all defined subrs. */); + /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); Vnative_elisp_refs_hash diff --git a/src/emacs.c b/src/emacs.c index 90ab7ac1e8e..0798e0702f2 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2050,6 +2050,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem moncontrol (0); #endif +#ifdef HAVE_NATIVE_COMP + fill_freloc (); +#endif + initialized = true; if (dump_mode) diff --git a/src/lisp.h b/src/lisp.h index 25319047a69..d0f7a9720c0 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4750,9 +4750,10 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); -/* Defined in comp.c. */ #ifdef HAVE_NATIVE_COMP +/* Defined in comp.c. */ extern void syms_of_comp (void); +extern void fill_freloc (void); #endif /* HAVE_NATIVE_COMP */ #ifdef DOS_NT diff --git a/src/lread.c b/src/lread.c index f280dad97c0..1ba04835aa1 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4465,6 +4465,9 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); +#ifdef HAVE_NATIVE_COMP + Vsubr_list = Fcons (tem, Vsubr_list); +#endif /* HAVE_NATIVE_COMP */ } #ifdef NOTDEF /* Use fset in subr.el now! */ From ac08a7f26c53d65df7d9c2a5d76300a6a1a8106b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 15:31:03 +0100 Subject: [PATCH 0631/1452] clean-up old function relocation code --- lisp/emacs-lisp/comp.el | 20 +-------- src/comp.c | 89 ++++++----------------------------------- 2 files changed, 14 insertions(+), 95 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0f0a90c82fb..7c4cfc95bff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -153,11 +153,7 @@ This is to build the prev field.") (data-relocs-l () :type list :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table - :documentation "Obj -> position into data-relocs.") - (func-relocs-l () :type list - :documentation "Native functions imported.") - (func-relocs-idx (make-hash-table :test #'equal) :type hash-table - :documentation "Obj -> position into func-relocs.")) + :documentation "Obj -> position into data-relocs.")) (cl-defstruct comp-args-base (min nil :type number @@ -309,15 +305,6 @@ The corresponding index is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) -(defun comp-add-subr-to-relocs (subr-name) - "Keep track of SUBR-NAME into the ctxt relocations. -The corresponding index is returned." - (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) - (if-let ((idx (gethash subr-name func-relocs-idx))) - idx - (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) - (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) - (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-verbose' is > 0." @@ -569,16 +556,14 @@ The basic block is returned regardless it was already declared or not." (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) -(defun comp-call (func &rest args) +(defsubst comp-call (func &rest args) "Emit a call for function FUNC with ARGS." - (comp-add-subr-to-relocs func) `(call ,func ,@args)) (defun comp-callref (func nargs stack-off) "Emit a call using narg abi for FUNC. NARGS is the number of arguments. STACK-OFF is the index of the first slot frame involved." - (comp-add-subr-to-relocs func) `(callref ,func ,@(cl-loop repeat nargs for sp from stack-off collect (comp-slot-n sp)))) @@ -1644,7 +1629,6 @@ Return t if something was changed." (args (if (eq call-type 'callref) args (fill-args args maxarg)))) - (comp-add-subr-to-relocs callee) `(,call-type ,callee ,@(clean-args-ref args)))) ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers that for non self calls too!! diff --git a/src/comp.c b/src/comp.c index a233187ccdf..ea37b89f847 100644 --- a/src/comp.c +++ b/src/comp.c @@ -38,9 +38,8 @@ along with GNU Emacs. If not, see . */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" -#define IMPORTED_FUNC_RELOC_SYM "f_reloc" +#define IMPORTED_FUNC_LINK_TABLE "freloc_link_table" #define TEXT_DATA_RELOC_SYM "text_data_reloc" -#define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -232,21 +231,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Try to return the original subr from `symbol' even if this was advised. */ -static Lisp_Object -symbol_subr (Lisp_Object symbol) -{ - Lisp_Object maybe_subr = Fsymbol_function (symbol); - - if (SUBRP (maybe_subr)) - return maybe_subr; - - if (!NILP (CALL1I (advice--p, maybe_subr))) - maybe_subr = CALL1I (ad-get-orig-definition, symbol); - - return SUBRP (maybe_subr) ? maybe_subr : Qnil; -} - static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -430,9 +414,11 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, else { gcc_jit_lvalue *f_ptr = - gcc_jit_lvalue_access_field (comp.func_relocs, - NULL, - (gcc_jit_field *) xmint_pointer (func)); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.func_relocs), + NULL, + (gcc_jit_field *) xmint_pointer (func)); + if (!f_ptr) xsignal2 (Qnative_ice, build_string ("missing function relocation"), @@ -1726,15 +1712,8 @@ declare_runtime_imported_data (void) static Lisp_Object declare_runtime_imported_funcs (void) { - /* For subr imported by the runtime we rely on the standard mechanism in place - for functions imported by lisp code. */ - CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); - CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); - CALL1I (comp-add-subr-to-relocs, Qplus); - CALL1I (comp-add-subr-to-relocs, Qminus); - CALL1I (comp-add-subr-to-relocs, Qlist); - Lisp_Object field_list = Qnil; + #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ { \ Lisp_Object name = intern_c_string (STR (f_name)); \ @@ -1864,8 +1843,8 @@ emit_ctxt_code (void) comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_struct_as_type (f_reloc_struct), - IMPORTED_FUNC_RELOC_SYM); + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), + IMPORTED_FUNC_LINK_TABLE); } @@ -3248,13 +3227,13 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + void **freloc_link_table = dynlib_sym (handle, IMPORTED_FUNC_LINK_TABLE); void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc && pure_reloc && data_relocs - && f_relocs + && freloc_link_table && top_level_run)) xsignal1 (Qnative_lisp_file_inconsistent, file); @@ -3272,51 +3251,7 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) } /* Imported functions. */ - Lisp_Object f_vec = - load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); - EMACS_INT f_vec_len = XFIXNUM (Flength (f_vec)); - for (EMACS_INT i = 0; i < f_vec_len; i++) - { - Lisp_Object f_sym = AREF (f_vec, i); - char *f_str = SSDATA (SYMBOL_NAME (f_sym)); - Lisp_Object subr = Fsymbol_function (f_sym); - if (!NILP (subr)) - { - subr = symbol_subr (f_sym); - if (NILP (subr)) - /* FIXME: This is not robust in case of primitive - redefinition. */ - xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); - - f_relocs[i] = XSUBR (subr)->function.a0; - } - else if (!strcmp (f_str, "wrong_type_argument")) - f_relocs[i] = (void *) wrong_type_argument; - else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) - f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; - else if (!strcmp (f_str, "pure_write_error")) - f_relocs[i] = (void *) pure_write_error; - else if (!strcmp (f_str, "push_handler")) - f_relocs[i] = (void *) push_handler; - else if (!strcmp (f_str, STR (SETJMP_NAME))) - f_relocs[i] = (void *) SETJMP; - else if (!strcmp (f_str, "record_unwind_protect_excursion")) - f_relocs[i] = (void *) record_unwind_protect_excursion; - else if (!strcmp (f_str, "helper_unbind_n")) - f_relocs[i] = (void *) helper_unbind_n; - else if (!strcmp (f_str, "helper_save_restriction")) - f_relocs[i] = (void *) helper_save_restriction; - else if (!strcmp (f_str, "record_unwind_current_buffer")) - f_relocs[i] = (void *) record_unwind_current_buffer; - else if (!strcmp (f_str, "set_internal")) - f_relocs[i] = (void *) set_internal; - else if (!strcmp (f_str, "helper_unwind_protect")) - f_relocs[i] = (void *) helper_unwind_protect; - else if (!strcmp (f_str, "specbind")) - f_relocs[i] = (void *) specbind; - else - xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); - } + *freloc_link_table = freloc.link_table; /* Executing this will perform all the expected environment modification. */ top_level_run (); From d0173ecd0ce8c2ac458cd84c25216f59f3fc9889 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 15:43:04 +0100 Subject: [PATCH 0632/1452] remove advice dependency --- src/comp.c | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index ea37b89f847..5a001396682 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3053,8 +3053,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, { CHECK_STRING (ctxtname); - Frequire (Qadvice, Qnil, Qnil); - gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); @@ -3302,8 +3300,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - Frequire (Qadvice, Qnil, Qnil); - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) @@ -3370,11 +3366,8 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qfixnum, "fixnum"); - DEFSYM (Qadvice, "advice"); - /* To be signaled. */ - - /* By the compiler. */ + /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); Fput (Qnative_compiler_error, Qerror_conditions, pure_list (Qnative_compiler_error, Qerror)); From d0fcb15fa9858eb600b0a8f35ebbdf5aadc2cd7c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 16:50:37 +0100 Subject: [PATCH 0633/1452] fix comp--register-subr --- src/comp.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 5a001396682..288aa6ccc41 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3282,7 +3282,10 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.native_intspec = intspec; x->s.native_doc = doc; x->s.native_elisp = true; - defsubr (x); + XSETPVECTYPE (&x->s, PVEC_SUBR); + Lisp_Object tem; + XSETSUBR (tem, &x->s); + set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); From a10405386f83333184c94a0a194b404e4273e2d0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Dec 2019 18:26:25 +0100 Subject: [PATCH 0634/1452] malloc instead of static alloc into emit_ctxt_code make it good to be reentrant --- src/comp.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 288aa6ccc41..3324d9f9217 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1813,13 +1813,13 @@ emit_ctxt_code (void) /* Functions imported from Lisp code. */ - static gcc_jit_field *fields[F_RELOC_MAX_SIZE]; + gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); ptrdiff_t n_frelocs = 0; Lisp_Object f_runtime = declare_runtime_imported_funcs (); FOR_EACH_TAIL (f_runtime) { Lisp_Object el = XCAR (f_runtime); - eassert (n_frelocs < ARRAYELTS (fields)); + eassert (n_frelocs < freloc.size); fields[n_frelocs++] = xmint_pointer (XCDR (el)); } @@ -1828,7 +1828,7 @@ emit_ctxt_code (void) { struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); Lisp_Object subr_sym = intern_c_string (subr->symbol_name); - eassert (n_frelocs < ARRAYELTS (fields)); + eassert (n_frelocs < freloc.size); fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type, subr->max_args, NULL); } @@ -1845,6 +1845,8 @@ emit_ctxt_code (void) GCC_JIT_GLOBAL_EXPORTED, gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), IMPORTED_FUNC_LINK_TABLE); + + xfree (fields); } From 88671e638b308886a9d6b5a590ee1aee56746d7b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 16 Dec 2019 23:33:45 +0100 Subject: [PATCH 0635/1452] make use of ARRAYELTS macro where possible --- src/comp.c | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3324d9f9217..5f8fd35c64e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1910,8 +1910,7 @@ define_lisp_cons (void) gcc_jit_context_new_union_type (comp.ctxt, NULL, "comp_cdr_u", - sizeof (cdr_u_fields) - / sizeof (*cdr_u_fields), + ARRAYELTS (cdr_u_fields), cdr_u_fields); comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt, @@ -1930,8 +1929,7 @@ define_lisp_cons (void) gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_cons_s", - sizeof (cons_s_fields) - / sizeof (*cons_s_fields), + ARRAYELTS (cons_s_fields), cons_s_fields); comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt, @@ -1954,8 +1952,7 @@ define_lisp_cons (void) gcc_jit_context_new_union_type (comp.ctxt, NULL, "comp_cons_u", - sizeof (cons_u_fields) - / sizeof (*cons_u_fields), + ARRAYELTS (cons_u_fields), cons_u_fields); comp.lisp_cons_u = @@ -2046,7 +2043,7 @@ define_handler_struct (void) "pad2") }; gcc_jit_struct_set_fields (comp.handler_s, NULL, - sizeof (fields) / sizeof (*fields), + ARRAYELTS (fields), fields); } @@ -2090,7 +2087,7 @@ define_thread_state_struct (void) gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_thread_state", - sizeof (fields) / sizeof (*fields), + ARRAYELTS (fields), fields); comp.thread_state_ptr_type = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); @@ -2191,8 +2188,7 @@ define_cast_union (void) gcc_jit_context_new_union_type (comp.ctxt, NULL, "cast_union", - sizeof (cast_union_fields) - / sizeof (*cast_union_fields), + ARRAYELTS (cast_union_fields), cast_union_fields); } @@ -2976,12 +2972,12 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; - comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "comp_Lisp_Object", - sizeof (lisp_obj_fields) - / sizeof (*lisp_obj_fields), - lisp_obj_fields); + comp.lisp_obj_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_Lisp_Object", + ARRAYELTS (lisp_obj_fields), + lisp_obj_fields); comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.most_positive_fixnum = @@ -3274,7 +3270,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, eassert (func); /* FIXME add gc support, now just leaking. */ - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + union Aligned_Lisp_Subr *x = xmalloc (sizeof (*x)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = func; From ee4feb005ffe1d35ffc4d390d18b88ecfdebe2c2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Dec 2019 10:34:21 +0100 Subject: [PATCH 0636/1452] fix some nits --- src/comp.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5f8fd35c64e..63c99b98334 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1770,7 +1770,6 @@ declare_runtime_imported_funcs (void) static void emit_ctxt_code (void) { - comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -1804,9 +1803,9 @@ emit_ctxt_code (void) NULL, GCC_JIT_GLOBAL_EXPORTED, gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - d_reloc_len), + NULL, + comp.lisp_obj_type, + d_reloc_len), DATA_RELOC_SYM)); emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); @@ -2726,8 +2725,8 @@ declare_function (Lisp_Object func) for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; - gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); - for (int i = max_args - 1; i >= 0; i--) + gcc_jit_param **param = SAFE_ALLOCA (max_args * sizeof (*param)); + for (int i = 0; i < max_args; ++i) param[i] = gcc_jit_context_new_param (comp.ctxt, NULL, type[i], From a647a97320e72db275a05961ae09e487ee3063e2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Dec 2019 10:46:45 +0100 Subject: [PATCH 0637/1452] better scratch slot support --- lisp/emacs-lisp/comp.el | 13 ++++++------- src/comp.c | 7 +++++-- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7c4cfc95bff..60eb9420662 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -257,9 +257,8 @@ structure.") (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (slot nil :type fixnum - :documentation "Slot number. --1 is a special value and indicates the scratch slot.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number if a number or 'scratch' for scratch slot.") (id nil :type (or null number) :documentation "SSA number when in SSA form.") (const-vld nil :type boolean @@ -732,10 +731,10 @@ Return value is the fall through block name." else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. - do (comp-emit (list 'set (make-comp-mvar :slot -1) + do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) (comp-call test-func var m-test))) (comp-emit (list 'cond-jump - (make-comp-mvar :slot -1) + (make-comp-mvar :slot 'scratch) (make-comp-mvar :constant nil) target-name ff-bb-name)) do (unless last @@ -1180,7 +1179,7 @@ This will be called at load-time." (defun comp-limplify (lap-funcs) "Compute the LIMPLE ir for LAP-FUNCS. -Top level forms for the current context are rendered too." +Top-level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) (comp-add-func-to-ctxt (comp-limplify-top-level))) @@ -1342,7 +1341,7 @@ Top level forms for the current context are rendered too." ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) - (= slot-n (comp-mvar-slot (cadr insn)))) + (eql slot-n (comp-mvar-slot (cadr insn)))) return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) diff --git a/src/comp.c b/src/comp.c index 63c99b98334..ce2a542e7cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -297,8 +297,9 @@ declare_block (Lisp_Object block_name) static gcc_jit_lvalue * get_slot (Lisp_Object mvar) { - EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); - if (slot_n == -1) + Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); + + if (EQ (mvar_slot, Qscratch)) { if (!comp.scratch) comp.scratch = gcc_jit_function_new_local (comp.func, @@ -307,6 +308,7 @@ get_slot (Lisp_Object mvar) "scratch"); return comp.scratch; } + EMACS_INT slot_n = XFIXNUM (mvar_slot); gcc_jit_lvalue **frame = (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; @@ -3366,6 +3368,7 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qfixnum, "fixnum"); + DEFSYM (Qscratch, "scratch"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); From b3cbdfc86474932e4ef8d1237ed100a6f4f4c854 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Dec 2019 11:06:38 +0100 Subject: [PATCH 0638/1452] add basic compilation unit into structure --- src/comp.c | 1 - src/data.c | 4 ++-- src/lisp.h | 11 ++++++++++- src/pdumper.c | 2 +- 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index ce2a542e7cf..79ece461a54 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3280,7 +3280,6 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - x->s.native_elisp = true; XSETPVECTYPE (&x->s, PVEC_SUBR); Lisp_Object tem; XSETSUBR (tem, &x->s); diff --git a/src/data.c b/src/data.c index 67613881d67..0a13569bc6d 100644 --- a/src/data.c +++ b/src/data.c @@ -870,7 +870,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; + return (SUBRP (object) && XSUBR (object)->native_comp_u) ? Qt : Qnil; } #endif @@ -900,7 +900,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { #ifdef HAVE_NATIVE_COMP - if (XSUBR (fun)->native_elisp && XSUBR (fun)->native_intspec) + if (XSUBR (fun)->native_comp_u && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; #endif const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index d0f7a9720c0..04f729f182a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,6 +34,10 @@ along with GNU Emacs. If not, see . */ #include #include +#ifdef HAVE_NATIVE_COMP +#include +#endif + INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -2064,6 +2068,11 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) char_table_set (ct, idx, val); } +struct Native_Compilation_Unit +{ + dynlib_handle_ptr handle; +}; + /* This structure describes a built-in function. It is generated by the DEFUN macro only. defsubr makes it into a Lisp object. */ @@ -2095,7 +2104,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - bool native_elisp; + struct Native_Compilation_Unit *native_comp_u;; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr diff --git a/src/pdumper.c b/src/pdumper.c index 38b70146b4f..24698d48b57 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2938,7 +2938,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); #ifdef HAVE_NATIVE_COMP - DUMP_FIELD_COPY (&out, subr, native_elisp); + dump_field_emacs_ptr (ctx, &out, subr, &subr->native_comp_u); #endif return dump_object_finish (ctx, &out, sizeof (out)); } From 4496a3f5ba899c89e45cd478a22b25ddf77869ec Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Dec 2019 05:22:09 +0100 Subject: [PATCH 0639/1452] initial compilation unit as object add --- src/alloc.c | 19 +++++++++++++++++++ src/comp.h | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp.h | 18 +++--------------- src/print.c | 11 ++++++++++- 4 files changed, 84 insertions(+), 16 deletions(-) create mode 100644 src/comp.h diff --git a/src/alloc.c b/src/alloc.c index 5ff0d907915..d990f53f7a0 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3023,6 +3023,15 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } +#ifdef HAVE_NATIVE_COMP + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + { + struct Lisp_Native_Compilation_Unit *cu = + PSEUDOVEC_STRUCT (vector, Lisp_Native_Compilation_Unit); + eassert (cu->handle); + dynlib_close (cu->handle); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -6556,6 +6565,10 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: +#ifdef HAVE_NATIVE_COMP + if (XSUBR (obj)->native_comp_u) + set_vector_marked (ptr); +#endif break; case PVEC_FREE: @@ -6700,7 +6713,13 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: +#ifdef HAVE_NATIVE_COMP + survives_p = + (SUBRP (obj) && !XSUBR (obj)->native_comp_u) || + vector_marked_p (XVECTOR (obj)); +#else survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); +#endif break; case Lisp_Cons: diff --git a/src/comp.h b/src/comp.h new file mode 100644 index 00000000000..457b678699c --- /dev/null +++ b/src/comp.h @@ -0,0 +1,52 @@ +/* Elisp native compiler definitions +Copyright (C) 2012-2019 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 . */ + +#ifndef COMP_H +#define COMP_H + +#ifdef HAVE_NATIVE_COMP + +#include + +struct Lisp_Native_Compilation_Unit +{ + union vectorlike_header header; + /* Compilation unit file descriptor and handle. */ + int fd; + dynlib_handle_ptr handle; +}; + +INLINE bool +COMPILATIONP_UNITP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT); +} + +INLINE struct Lisp_Native_Compilation_Unit * +XCOMPILATION_UNIT (Lisp_Object a) +{ + eassert (COMPILATIONP_UNITP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Compilation_Unit); +} + +/* Defined in comp.c. */ +extern void syms_of_comp (void); +extern void fill_freloc (void); + +#endif +#endif diff --git a/src/lisp.h b/src/lisp.h index 04f729f182a..bb441b181a1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,10 +34,6 @@ along with GNU Emacs. If not, see . */ #include #include -#ifdef HAVE_NATIVE_COMP -#include -#endif - INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -1097,6 +1093,7 @@ enum pvec_type PVEC_MUTEX, PVEC_CONDVAR, PVEC_MODULE_FUNCTION, + PVEC_NATIVE_COMP_UNIT, /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, @@ -2068,10 +2065,7 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) char_table_set (ct, idx, val); } -struct Native_Compilation_Unit -{ - dynlib_handle_ptr handle; -}; +#include "comp.h" /* This structure describes a built-in function. It is generated by the DEFUN macro only. @@ -2104,7 +2098,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - struct Native_Compilation_Unit *native_comp_u;; + Lisp_Object native_comp_u;; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr @@ -4759,12 +4753,6 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); -#ifdef HAVE_NATIVE_COMP -/* Defined in comp.c. */ -extern void syms_of_comp (void); -extern void fill_freloc (void); -#endif /* HAVE_NATIVE_COMP */ - #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ extern char *emacs_root_dir (void); diff --git a/src/print.c b/src/print.c index 425b0dc4ee3..2e2c863ece8 100644 --- a/src/print.c +++ b/src/print.c @@ -1825,7 +1825,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } break; #endif - +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + { + print_c_string ("#", printcharfun); + int len = sprintf (buf, "%d", XCOMPILATION_UNIT (obj)->fd); + strout (buf, len, len, printcharfun); + printchar ('>', printcharfun); + } + break; +#endif default: emacs_abort (); } From f0671c60637e218a54f9f3ac8e5950d17884f50b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Dec 2019 05:23:02 +0100 Subject: [PATCH 0640/1452] make dynlib_close active code --- src/dynlib.c | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/dynlib.c b/src/dynlib.c index 4919d5cc726..b3fd815e68c 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -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 From 9a8f33f285295daff8ed02d35ece5e8fe11ac887 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Dec 2019 05:53:28 +0100 Subject: [PATCH 0641/1452] introduce SUBRP_NATIVE_COMPILEDP --- src/alloc.c | 4 ++-- src/data.c | 4 ++-- src/lisp.h | 8 ++++++++ 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index d990f53f7a0..dba2c2df881 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6566,7 +6566,7 @@ mark_object (Lisp_Object arg) case PVEC_SUBR: #ifdef HAVE_NATIVE_COMP - if (XSUBR (obj)->native_comp_u) + if (SUBRP_NATIVE_COMPILEDP (obj)) set_vector_marked (ptr); #endif break; @@ -6715,7 +6715,7 @@ survives_gc_p (Lisp_Object obj) case Lisp_Vectorlike: #ifdef HAVE_NATIVE_COMP survives_p = - (SUBRP (obj) && !XSUBR (obj)->native_comp_u) || + (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); #else survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); diff --git a/src/data.c b/src/data.c index 0a13569bc6d..fd20ecce696 100644 --- a/src/data.c +++ b/src/data.c @@ -870,7 +870,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return (SUBRP (object) && XSUBR (object)->native_comp_u) ? Qt : Qnil; + return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; } #endif @@ -900,7 +900,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { #ifdef HAVE_NATIVE_COMP - if (XSUBR (fun)->native_comp_u && XSUBR (fun)->native_intspec) + if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; #endif const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index bb441b181a1..05d6ef0d22a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2136,6 +2136,14 @@ enum char_table_specials = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) - 1 }; +#ifdef HAVE_NATIVE_COMP +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return SUBRP (a) && XSUBR (a)->native_comp_u; +} +#endif + /* Sanity-check pseudovector layout. */ verify (offsetof (struct Lisp_Char_Table, defalt) == header_size); verify (offsetof (struct Lisp_Char_Table, extras) From 54677f96f3ad8e489e04c8bc7875e1ec4d6b9a79 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Dec 2019 21:04:59 +0100 Subject: [PATCH 0642/1452] split out copy_file_fd --- src/fileio.c | 89 +++++++++++++++++++++++++++++----------------------- src/lisp.h | 3 ++ 2 files changed, 53 insertions(+), 39 deletions(-) diff --git a/src/fileio.c b/src/fileio.c index 6e2fe2f0b82..91e0efc0a83 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -1989,6 +1989,55 @@ clone_file (int dest, int source) } #endif +/* Copy data to OFD from IFD if possible. Return NEWSIZE. */ +off_t +copy_file_fd (int ofd, int ifd, struct stat *st, Lisp_Object newname, + Lisp_Object file) +{ + off_t newsize; + + if (clone_file (ofd, ifd)) + newsize = st->st_size; + else + { + off_t insize = st->st_size; + ssize_t copied; + + for (newsize = 0; newsize < insize; newsize += copied) + { + /* Copy at most COPY_MAX bytes at a time; this is min + (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is + surely aligned well. */ + ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); + ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; + off_t intail = insize - newsize; + ptrdiff_t len = min (intail, copy_max); + copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); + if (copied <= 0) + break; + maybe_quit (); + } + + /* Fall back on read+write if copy_file_range failed, or if the + input is empty and so could be a /proc file. read+write will + either succeed, or report an error more precisely than + copy_file_range would. */ + if (newsize != insize || insize == 0) + { + char buf[MAX_ALLOCA]; + for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); + newsize += copied) + { + if (copied < 0) + report_file_error ("Read error", file); + if (emacs_write_quit (ofd, buf, copied) != copied) + report_file_error ("Write error", newname); + } + } + } + return newsize; +} + DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6, "fCopy file: \nGCopy %s to file: \np\nP", doc: /* Copy FILE to NEWNAME. Both args must be strings. @@ -2143,45 +2192,7 @@ permissions. */) maybe_quit (); - if (clone_file (ofd, ifd)) - newsize = st.st_size; - else - { - off_t insize = st.st_size; - ssize_t copied; - - for (newsize = 0; newsize < insize; newsize += copied) - { - /* Copy at most COPY_MAX bytes at a time; this is min - (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is - surely aligned well. */ - ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); - ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; - off_t intail = insize - newsize; - ptrdiff_t len = min (intail, copy_max); - copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); - if (copied <= 0) - break; - maybe_quit (); - } - - /* Fall back on read+write if copy_file_range failed, or if the - input is empty and so could be a /proc file. read+write will - either succeed, or report an error more precisely than - copy_file_range would. */ - if (newsize != insize || insize == 0) - { - char buf[MAX_ALLOCA]; - for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); - newsize += copied) - { - if (copied < 0) - report_file_error ("Read error", file); - if (emacs_write_quit (ofd, buf, copied) != copied) - report_file_error ("Write error", newname); - } - } - } + newsize = copy_file_fd (ofd, ifd, &st, newname, file); /* Truncate any existing output file after writing the data. This is more likely to work than truncation before writing, if the diff --git a/src/lisp.h b/src/lisp.h index 05d6ef0d22a..7a4b3517574 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,6 +34,8 @@ along with GNU Emacs. If not, see . */ #include #include +#include + INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -4325,6 +4327,7 @@ extern char *splice_dir_file (char *, char const *, char const *); extern bool file_name_absolute_p (const char *); extern char const *get_homedir (void); extern Lisp_Object expand_and_dir_to_file (Lisp_Object); +extern off_t copy_file_fd (int, int, struct stat *, Lisp_Object, Lisp_Object); extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, int); From 79436f0c744a65ed2757f0119f5bd13e2fbef995 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Dec 2019 22:32:19 +0100 Subject: [PATCH 0643/1452] use memory mapped file for loading elns --- src/comp.c | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 79ece461a54..ea5d3238d2c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -27,6 +27,13 @@ along with GNU Emacs. If not, see . */ #include #include +#include /* For getpid. */ +#include +#include /* For O_RDONLY. */ +#include +/* FIXME non portable. */ +#include /* For memfd_create. */ + #include "lisp.h" #include "puresize.h" #include "window.h" @@ -3301,7 +3308,22 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + /* FIXME non portable. */ + /* We copy the content of the file to be loaded in a memory mapped + file. We then keep track of this in the struct + Lisp_Native_Compilation_Unit. In case this will be overwritten + or delete we'll dump the right data. */ + int fd_in = emacs_open (SSDATA (file), O_RDONLY, 0); + int fd_out = memfd_create (SSDATA (file), 0); + if (fd_in < 0 || fd_out < 0) + xsignal2 (Qnative_lisp_load_failed, file, + build_string ("Failing to get file descriptor")); + struct stat st; + if (fstat (fd_in, &st) != 0) + report_file_error ("Input file status", file); + copy_file_fd (fd_out, fd_in, &st, Qnil, file); + dynlib_handle_ptr handle = + dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); From c5bb62f99db4b1c70e68e7c7a30ede8227f199a3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Dec 2019 18:57:56 +0100 Subject: [PATCH 0644/1452] initial gc support --- src/alloc.c | 12 ++++++++++-- src/comp.c | 27 +++++++++++++++------------ src/comp.h | 1 + src/lisp.h | 34 +++++++++++++++++++++++++--------- src/print.c | 2 +- 5 files changed, 52 insertions(+), 24 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index dba2c2df881..547990c7a9e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6567,10 +6567,18 @@ mark_object (Lisp_Object arg) case PVEC_SUBR: #ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (obj)) - set_vector_marked (ptr); + { + set_vector_marked (ptr); + struct Lisp_Subr *subr = XSUBR (obj); + mark_object (subr->native_comp_u); + } + break; + case PVEC_NATIVE_COMP_UNIT: + set_vector_marked (ptr); + /* FIXME see comp.h. */ + mark_object (XCOMPILATION_UNIT (obj)->data_vec); #endif break; - case PVEC_FREE: emacs_abort (); diff --git a/src/comp.c b/src/comp.c index ea5d3238d2c..71d4d79f9e7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3225,8 +3225,10 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } static void -load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) +load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) { + struct Lisp_Native_Compilation_Unit *comp_u = XCOMPILATION_UNIT (comp_u_obj); + dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); @@ -3249,11 +3251,9 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) - { data_relocs[i] = AREF (d_vec, i); - prevent_gc (data_relocs[i]); - } + comp_u->data_vec = d_vec; /* Imported functions. */ *freloc_link_table = freloc.link_table; @@ -3270,24 +3270,26 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { - dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); + Lisp_Object comp_u = XCAR (load_handle_stack); + dynlib_handle_ptr handle = XCOMPILATION_UNIT (comp_u)->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); - /* FIXME add gc support, now just leaking. */ - union Aligned_Lisp_Subr *x = xmalloc (sizeof (*x)); - - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + union Aligned_Lisp_Subr *x = + (union Aligned_Lisp_Subr *) allocate_pseudovector ( + VECSIZE (union Aligned_Lisp_Subr), + 0, VECSIZE (union Aligned_Lisp_Subr), + PVEC_SUBR); x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - XSETPVECTYPE (&x->s, PVEC_SUBR); + x->s.native_comp_u = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); set_symbol_function (name, tem); @@ -3324,11 +3326,12 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, copy_file_fd (fd_out, fd_in, &st, Qnil, file); dynlib_handle_ptr handle = dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); - load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); + Lisp_Object comp_u = make_native_comp_u (fd_in, handle); + load_handle_stack = Fcons (comp_u, load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - load_comp_unit (handle, file); + load_comp_unit (comp_u, file); load_handle_stack = XCDR (load_handle_stack); diff --git a/src/comp.h b/src/comp.h index 457b678699c..876615e8dd4 100644 --- a/src/comp.h +++ b/src/comp.h @@ -29,6 +29,7 @@ struct Lisp_Native_Compilation_Unit /* Compilation unit file descriptor and handle. */ int fd; dynlib_handle_ptr handle; + Lisp_Object data_vec; /* FIXME this should be in the normal lisp slot. */ }; INLINE bool diff --git a/src/lisp.h b/src/lisp.h index 7a4b3517574..3d467a84d18 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1342,6 +1342,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 @@ -2100,7 +2101,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - Lisp_Object native_comp_u;; + Lisp_Object native_comp_u; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr @@ -2138,14 +2139,6 @@ enum char_table_specials = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) - 1 }; -#ifdef HAVE_NATIVE_COMP -INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) -{ - return SUBRP (a) && XSUBR (a)->native_comp_u; -} -#endif - /* Sanity-check pseudovector layout. */ verify (offsetof (struct Lisp_Char_Table, defalt) == header_size); verify (offsetof (struct Lisp_Char_Table, extras) @@ -4769,6 +4762,29 @@ extern void syms_of_profiler (void); extern char *emacs_root_dir (void); #endif /* DOS_NT */ +#ifdef HAVE_NATIVE_COMP +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return SUBRP (a) && XSUBR (a)->native_comp_u; +} + +INLINE Lisp_Object +make_native_comp_u (int fd, dynlib_handle_ptr handle) +{ + struct Lisp_Native_Compilation_Unit *x = + (struct Lisp_Native_Compilation_Unit *) allocate_pseudovector ( + VECSIZE (struct Lisp_Native_Compilation_Unit), + 0, VECSIZE (struct Lisp_Native_Compilation_Unit), + PVEC_NATIVE_COMP_UNIT); + x->fd = fd; + x->handle = handle; + Lisp_Object cu; + XSETNATIVE_COMP_UNIT (cu, x); + return cu; +} +#endif + /* Defined in lastfile.c. */ extern char my_edata[]; extern char my_endbss[]; diff --git a/src/print.c b/src/print.c index 2e2c863ece8..e7ddafbbbbd 100644 --- a/src/print.c +++ b/src/print.c @@ -1828,7 +1828,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, #ifdef HAVE_NATIVE_COMP case PVEC_NATIVE_COMP_UNIT: { - print_c_string ("#", printcharfun); + print_c_string ("#fd); strout (buf, len, len, printcharfun); printchar ('>', printcharfun); From 4c8b46514d87856e5e2044bce804ad0156097d04 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 08:12:27 +0100 Subject: [PATCH 0645/1452] some rename on compilation unit struct --- src/alloc.c | 6 +++--- src/comp.c | 6 +++--- src/comp.h | 12 ++++++------ src/lisp.h | 10 +++++----- src/print.c | 2 +- 5 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 547990c7a9e..d47f9c8a574 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3026,8 +3026,8 @@ cleanup_vector (struct Lisp_Vector *vector) #ifdef HAVE_NATIVE_COMP else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) { - struct Lisp_Native_Compilation_Unit *cu = - PSEUDOVEC_STRUCT (vector, Lisp_Native_Compilation_Unit); + struct Lisp_Native_Comp_Unit *cu = + PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); } @@ -6576,7 +6576,7 @@ mark_object (Lisp_Object arg) case PVEC_NATIVE_COMP_UNIT: set_vector_marked (ptr); /* FIXME see comp.h. */ - mark_object (XCOMPILATION_UNIT (obj)->data_vec); + mark_object (XNATIVE_COMP_UNIT (obj)->data_vec); #endif break; case PVEC_FREE: diff --git a/src/comp.c b/src/comp.c index 71d4d79f9e7..c74e5cf2e6c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3227,7 +3227,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) static void load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) { - struct Lisp_Native_Compilation_Unit *comp_u = XCOMPILATION_UNIT (comp_u_obj); + struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (comp_u_obj); dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); @@ -3271,7 +3271,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { Lisp_Object comp_u = XCAR (load_handle_stack); - dynlib_handle_ptr handle = XCOMPILATION_UNIT (comp_u)->handle; + dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); @@ -3313,7 +3313,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, /* FIXME non portable. */ /* We copy the content of the file to be loaded in a memory mapped file. We then keep track of this in the struct - Lisp_Native_Compilation_Unit. In case this will be overwritten + Lisp_Native_Comp_Unit. In case this will be overwritten or delete we'll dump the right data. */ int fd_in = emacs_open (SSDATA (file), O_RDONLY, 0); int fd_out = memfd_create (SSDATA (file), 0); diff --git a/src/comp.h b/src/comp.h index 876615e8dd4..04c57278667 100644 --- a/src/comp.h +++ b/src/comp.h @@ -23,7 +23,7 @@ along with GNU Emacs. If not, see . */ #include -struct Lisp_Native_Compilation_Unit +struct Lisp_Native_Comp_Unit { union vectorlike_header header; /* Compilation unit file descriptor and handle. */ @@ -33,16 +33,16 @@ struct Lisp_Native_Compilation_Unit }; INLINE bool -COMPILATIONP_UNITP (Lisp_Object a) +NATIVE_COMP_UNITP (Lisp_Object a) { return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT); } -INLINE struct Lisp_Native_Compilation_Unit * -XCOMPILATION_UNIT (Lisp_Object a) +INLINE struct Lisp_Native_Comp_Unit * +XNATIVE_COMP_UNIT (Lisp_Object a) { - eassert (COMPILATIONP_UNITP (a)); - return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Compilation_Unit); + eassert (NATIVE_COMP_UNITP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Comp_Unit); } /* Defined in comp.c. */ diff --git a/src/lisp.h b/src/lisp.h index 3d467a84d18..2e4a6c89846 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4772,11 +4772,11 @@ SUBRP_NATIVE_COMPILEDP (Lisp_Object a) INLINE Lisp_Object make_native_comp_u (int fd, dynlib_handle_ptr handle) { - struct Lisp_Native_Compilation_Unit *x = - (struct Lisp_Native_Compilation_Unit *) allocate_pseudovector ( - VECSIZE (struct Lisp_Native_Compilation_Unit), - 0, VECSIZE (struct Lisp_Native_Compilation_Unit), - PVEC_NATIVE_COMP_UNIT); + struct Lisp_Native_Comp_Unit *x = + (struct Lisp_Native_Comp_Unit *) allocate_pseudovector ( + VECSIZE (struct Lisp_Native_Comp_Unit), + 0, VECSIZE (struct Lisp_Native_Comp_Unit), + PVEC_NATIVE_COMP_UNIT); x->fd = fd; x->handle = handle; Lisp_Object cu; diff --git a/src/print.c b/src/print.c index e7ddafbbbbd..4d7932a81d7 100644 --- a/src/print.c +++ b/src/print.c @@ -1829,7 +1829,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_NATIVE_COMP_UNIT: { print_c_string ("#fd); + int len = sprintf (buf, "%d", XNATIVE_COMP_UNIT (obj)->fd); strout (buf, len, len, printcharfun); printchar ('>', printcharfun); } From a88e5f0f199ad018d57d07016dce20e5462dbbca Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 08:31:02 +0100 Subject: [PATCH 0646/1452] better compilation unit definition --- src/alloc.c | 6 +----- src/comp.h | 3 ++- src/lisp.h | 6 ++---- 3 files changed, 5 insertions(+), 10 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index d47f9c8a574..5e0b04b1cc7 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6572,13 +6572,9 @@ mark_object (Lisp_Object arg) struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_comp_u); } - break; - case PVEC_NATIVE_COMP_UNIT: - set_vector_marked (ptr); - /* FIXME see comp.h. */ - mark_object (XNATIVE_COMP_UNIT (obj)->data_vec); #endif break; + case PVEC_FREE: emacs_abort (); diff --git a/src/comp.h b/src/comp.h index 04c57278667..8b83911f53c 100644 --- a/src/comp.h +++ b/src/comp.h @@ -26,10 +26,11 @@ along with GNU Emacs. If not, see . */ struct Lisp_Native_Comp_Unit { union vectorlike_header header; + /* Analogous to the constant vector but per compilation unit. */ + Lisp_Object data_vec; /* Compilation unit file descriptor and handle. */ int fd; dynlib_handle_ptr handle; - Lisp_Object data_vec; /* FIXME this should be in the normal lisp slot. */ }; INLINE bool diff --git a/src/lisp.h b/src/lisp.h index 2e4a6c89846..81ccae5683f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4773,10 +4773,8 @@ INLINE Lisp_Object make_native_comp_u (int fd, dynlib_handle_ptr handle) { struct Lisp_Native_Comp_Unit *x = - (struct Lisp_Native_Comp_Unit *) allocate_pseudovector ( - VECSIZE (struct Lisp_Native_Comp_Unit), - 0, VECSIZE (struct Lisp_Native_Comp_Unit), - PVEC_NATIVE_COMP_UNIT); + ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, + PVEC_NATIVE_COMP_UNIT); x->fd = fd; x->handle = handle; Lisp_Object cu; From 42362d991443689162c3e0bf1eb683a85481a391 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 09:13:46 +0100 Subject: [PATCH 0647/1452] remove load_handle_stack and use the implementation one --- lisp/emacs-lisp/comp.el | 20 +++++++++++++++----- src/comp.c | 17 +++++------------ 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60eb9420662..49f25d85c0e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1073,7 +1073,10 @@ the annotation emission." (make-comp-mvar :constant (comp-func-c-name f)) (make-comp-mvar :constant (comp-func-doc f)) (make-comp-mvar :constant - (comp-func-int-spec f)))))) + (comp-func-int-spec f)) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) @@ -1083,17 +1086,24 @@ the annotation emission." (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. -This will be called at load-time." +This will be called at load-time. + +Synthesize a function called 'top_level_run' that gets one single +parameter (the compilation unit it-self). To define native +functions 'top_level_run' will call back `comp--register-subr' +into the C code forwarding the compilation unit." (let* ((func (make-comp-func :name 'top-level-run :c-name "top_level_run" - :args (make-comp-args :min 0 :max 0) - :frame-size 0)) + :args (make-comp-args :min 1 :max 1) + :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block -1 0 'top-level) - :frame (comp-new-frame 0)))) + :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") + ;; Assign the compilation unit incoming as parameter to the slot frame 0. + (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) (comp-limplify-finalize-function func))) diff --git a/src/comp.c b/src/comp.c index c74e5cf2e6c..0ec0edd27ea 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3204,8 +3204,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; -static Lisp_Object load_handle_stack; - static void prevent_gc (Lisp_Object obj) { @@ -3234,7 +3232,7 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); void **freloc_link_table = dynlib_sym (handle, IMPORTED_FUNC_LINK_TABLE); - void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc && pure_reloc @@ -3258,19 +3256,19 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) *freloc_link_table = freloc.link_table; /* Executing this will perform all the expected environment modification. */ - top_level_run (); + top_level_run (comp_u_obj); return; } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 6, 6, 0, + 7, 7, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) { - Lisp_Object comp_u = XCAR (load_handle_stack); dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); @@ -3327,14 +3325,11 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, dynlib_handle_ptr handle = dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); Lisp_Object comp_u = make_native_comp_u (fd_in, handle); - load_handle_stack = Fcons (comp_u, load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); load_comp_unit (comp_u, file); - load_handle_stack = XCDR (load_handle_stack); - return Qt; } @@ -3461,8 +3456,6 @@ syms_of_comp (void) = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, Qnil, false); - staticpro (&load_handle_stack); - load_handle_stack = Qnil; } #endif /* HAVE_NATIVE_COMP */ From 5ecb71c1e65038b79933c06e1c0303b3e58ef4b5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 09:14:07 +0100 Subject: [PATCH 0648/1452] clean-up unnecessary function prevent_gc --- src/comp.c | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0ec0edd27ea..9f8c24f3cf0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3204,11 +3204,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; -static void -prevent_gc (Lisp_Object obj) -{ - Fputhash (obj, Qt, Vnative_elisp_refs_hash); -} typedef char *(*comp_lit_str_func) (void); From b275ddd63a24b15dd8f90ea0c4f27341a8dfa977 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 09:28:39 +0100 Subject: [PATCH 0649/1452] rationalize load functions --- src/comp.c | 16 ++++++++++------ src/comp.h | 2 ++ src/lisp.h | 14 ++++---------- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9f8c24f3cf0..6d496e89bf7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3218,9 +3218,8 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } static void -load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) { - struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (comp_u_obj); dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); @@ -3234,7 +3233,7 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) && data_relocs && freloc_link_table && top_level_run)) - xsignal1 (Qnative_lisp_file_inconsistent, file); + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; @@ -3250,6 +3249,9 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) /* Imported functions. */ *freloc_link_table = freloc.link_table; + Lisp_Object comp_u_obj; + XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + /* Executing this will perform all the expected environment modification. */ top_level_run (comp_u_obj); @@ -3319,11 +3321,13 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, copy_file_fd (fd_out, fd_in, &st, Qnil, file); dynlib_handle_ptr handle = dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); - Lisp_Object comp_u = make_native_comp_u (fd_in, handle); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - - load_comp_unit (comp_u, file); + struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); + comp_u->file = file; + comp_u->fd = fd_out; + comp_u->handle = handle; + load_comp_unit (comp_u); return Qt; } diff --git a/src/comp.h b/src/comp.h index 8b83911f53c..677ffdc4d7f 100644 --- a/src/comp.h +++ b/src/comp.h @@ -26,6 +26,8 @@ along with GNU Emacs. If not, see . */ struct Lisp_Native_Comp_Unit { union vectorlike_header header; + /* Original eln file loaded (just for debug purpose). */ + Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Compilation unit file descriptor and handle. */ diff --git a/src/lisp.h b/src/lisp.h index 81ccae5683f..3c3a9e22cf3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4769,17 +4769,11 @@ SUBRP_NATIVE_COMPILEDP (Lisp_Object a) return SUBRP (a) && XSUBR (a)->native_comp_u; } -INLINE Lisp_Object -make_native_comp_u (int fd, dynlib_handle_ptr handle) +INLINE struct Lisp_Native_Comp_Unit * +allocate_native_comp_unit (void) { - struct Lisp_Native_Comp_Unit *x = - ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, - PVEC_NATIVE_COMP_UNIT); - x->fd = fd; - x->handle = handle; - Lisp_Object cu; - XSETNATIVE_COMP_UNIT (cu, x); - return cu; + return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, + PVEC_NATIVE_COMP_UNIT); } #endif From 5dae0a9a55101aeb668f90e1fece1ffbab5e7ee2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 09:52:46 +0100 Subject: [PATCH 0650/1452] add support for native comp unit to type-of --- src/data.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/data.c b/src/data.c index fd20ecce696..73ddb021e23 100644 --- a/src/data.c +++ b/src/data.c @@ -265,6 +265,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: @@ -3876,6 +3878,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"); From 0a74771ee9c406cf98d391378340c79645c88d52 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 09:58:33 +0100 Subject: [PATCH 0651/1452] fix invalid read in fill_freloc --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 6d496e89bf7..75b41e2af8f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3125,7 +3125,7 @@ fill_freloc (void) { if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) goto overflow; - memcpy (freloc.link_table, helper_link_table, sizeof (freloc.link_table)); + memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); freloc.size = ARRAYELTS (helper_link_table); Lisp_Object subr_l = Vsubr_list; From fd3c00ff92826b466a3292a05072eb5b4f23a701 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 09:04:24 +0100 Subject: [PATCH 0652/1452] add subr-native-compilation-unit primitive --- src/data.c | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/data.c b/src/data.c index 73ddb021e23..70f8a8f2c1a 100644 --- a/src/data.c +++ b/src/data.c @@ -867,13 +867,22 @@ SUBR must be a built-in function. */) } #ifdef HAVE_NATIVE_COMP -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, +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 SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; } + +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; +} #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, @@ -4002,6 +4011,7 @@ syms_of_data (void) defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); + defsubr (&Ssubr_native_compilation_unit); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); From 12639610f78f9006b70933bfc6898c1312f95290 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 09:24:51 +0100 Subject: [PATCH 0653/1452] better printing for native compilation unit --- src/comp.h | 2 +- src/print.c | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/comp.h b/src/comp.h index 677ffdc4d7f..36ee5d10e45 100644 --- a/src/comp.h +++ b/src/comp.h @@ -26,7 +26,7 @@ along with GNU Emacs. If not, see . */ struct Lisp_Native_Comp_Unit { union vectorlike_header header; - /* Original eln file loaded (just for debug purpose). */ + /* Original eln file loaded. */ Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; diff --git a/src/print.c b/src/print.c index 4d7932a81d7..9013ccc8ccd 100644 --- a/src/print.c +++ b/src/print.c @@ -1829,8 +1829,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_NATIVE_COMP_UNIT: { print_c_string ("#fd); - strout (buf, len, len, printcharfun); + print_string (XNATIVE_COMP_UNIT (obj)->file, printcharfun); printchar ('>', printcharfun); } break; From df0a7547cbaf19152a74b5dda760e5d1f6c92ecc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 09:40:41 +0100 Subject: [PATCH 0654/1452] add native-comp-unit-file primitive --- src/data.c | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/data.c b/src/data.c index 70f8a8f2c1a..3fb0fc0a190 100644 --- a/src/data.c +++ b/src/data.c @@ -883,6 +883,15 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, CHECK_SUBR (subr); return XSUBR (subr)->native_comp_u; } + +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 object) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (object), Qnative_comp_unit, object); + return XNATIVE_COMP_UNIT (object)->file; +} #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, @@ -4011,7 +4020,8 @@ syms_of_data (void) defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); - defsubr (&Ssubr_native_compilation_unit); + defsubr (&Ssubr_native_comp_unit); + defsubr (&Snative_comp_unit_file); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); From ca8d5ed6ecd5ca3eafa2923ee04e56dc474bd964 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 11:51:33 +0100 Subject: [PATCH 0655/1452] add disassemble support for native compiled functions --- lisp/emacs-lisp/comp.el | 6 +++--- lisp/emacs-lisp/disass.el | 25 +++++++++++++++++++++++-- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 49f25d85c0e..e8a9b6c2b69 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -360,12 +360,12 @@ VERBOSITY is a number between 0 and 3." ;;; spill-lap pass specific code. -(defun comp-c-func-name (symbol prefix) - "Given SYMBOL return a name suitable for the native code. +(defun comp-c-func-name (name prefix) + "Given NAME return a name suitable for the native code. Put PREFIX in front of it." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: - (let* ((orig-name (symbol-name symbol)) + (let* ((orig-name (if (symbolp name) (symbol-name name) name)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 for i across orig-name diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 51b7db24f3c..c23dbe1e068 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -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 "*") @@ -75,7 +77,7 @@ redefine OBJECT if it is a symbol." nil) -(defun disassemble-internal (obj indent interactive-p) +(cl-defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) (name (when (symbolp obj) (prog1 obj @@ -83,7 +85,26 @@ redefine OBJECT if it is a symbol." args) (setq obj (autoload-do-load obj name)) (if (subrp obj) - (error "Can't disassemble #" 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") + ">:")))) + (beginning-of-line) + (delete-region (point-min) (point)) + (when (re-search-forward "^.*<.*>:" nil t 2) + (delete-region (match-beginning 0) (point-max))) + (asm-mode) + (cl-return-from disassemble-internal)) + (error "Can't disassemble #" name))) (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) From 8b1d9b8e5ed8035bd2f42517bb6bc3c8a6d6f0ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 14:27:55 +0100 Subject: [PATCH 0656/1452] add initial native compiler pdumper support --- src/doc.c | 10 ++++++---- src/pdumper.c | 40 ++++++++++++++++++++++++++++++++++++++-- 2 files changed, 44 insertions(+), 6 deletions(-) diff --git a/src/doc.c b/src/doc.c index 369997a3db4..9e1d8392787 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,13 +510,15 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - +#ifdef HAVE_NATIVE_COMP + else if (SUBRP_NATIVE_COMPILEDP (fun)) + { + XSUBR (fun)->native_doc = Qnil; + } +#endif /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) { -#ifdef HAVE_NATIVE_COMP - eassert (NILP (Fsubr_native_elisp_p (fun))); -#endif XSUBR (fun)->doc = offset; } diff --git a/src/pdumper.c b/src/pdumper.c index 24698d48b57..775f6c3e60b 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2931,18 +2931,49 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); +#ifdef HAVE_NATIVE_COMP + if (subr->native_comp_u) + out.function.a0 = NULL; + else + dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); +#else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); +#endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); +#ifdef HAVE_NATIVE_COMP + if (subr->native_comp_u) + { + dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); + dump_field_lv (ctx, &out, subr, &subr->native_doc, WEIGHT_NORMAL); + } + else + { + dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + DUMP_FIELD_COPY (&out, subr, doc); + } + dump_field_lv (ctx, &out, subr, &subr->native_comp_u, WEIGHT_NORMAL); +#else dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); -#ifdef HAVE_NATIVE_COMP - dump_field_emacs_ptr (ctx, &out, subr, &subr->native_comp_u); #endif return dump_object_finish (ctx, &out, sizeof (out)); } +#ifdef HAVE_NATIVE_COMP +static dump_off +dump_native_comp_unit (struct dump_context *ctx, + const struct Lisp_Native_Comp_Unit *comp_u) +{ + START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); + dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); + out->fd = 0; + out->handle = 0; + return finish_dump_pvec (ctx, &out->header); +} +#endif + static void fill_pseudovec (union vectorlike_header *header, Lisp_Object item) { @@ -3044,6 +3075,11 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "condvar"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); + break; +#endif default: error_unsupported_dump_object(ctx, lv, "weird pseudovector"); } From df62baa7d4e8ce0760f32122899ae3c803180907 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 08:17:40 +0100 Subject: [PATCH 0657/1452] Revert "use memory mapped file for loading elns" This reverts commit 5e07231151ef60a5066617ef6cec7c0077825b1c. --- src/comp.c | 25 ++----------------------- 1 file changed, 2 insertions(+), 23 deletions(-) diff --git a/src/comp.c b/src/comp.c index 75b41e2af8f..68b1cdf7449 100644 --- a/src/comp.c +++ b/src/comp.c @@ -27,13 +27,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include /* For getpid. */ -#include -#include /* For O_RDONLY. */ -#include -/* FIXME non portable. */ -#include /* For memfd_create. */ - #include "lisp.h" #include "puresize.h" #include "window.h" @@ -3305,22 +3298,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - /* FIXME non portable. */ - /* We copy the content of the file to be loaded in a memory mapped - file. We then keep track of this in the struct - Lisp_Native_Comp_Unit. In case this will be overwritten - or delete we'll dump the right data. */ - int fd_in = emacs_open (SSDATA (file), O_RDONLY, 0); - int fd_out = memfd_create (SSDATA (file), 0); - if (fd_in < 0 || fd_out < 0) - xsignal2 (Qnative_lisp_load_failed, file, - build_string ("Failing to get file descriptor")); - struct stat st; - if (fstat (fd_in, &st) != 0) - report_file_error ("Input file status", file); - copy_file_fd (fd_out, fd_in, &st, Qnil, file); - dynlib_handle_ptr handle = - dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); From 080dacda7896e0eb5ee54b1550097e45a4f423de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 08:18:08 +0100 Subject: [PATCH 0658/1452] Revert "split out copy_file_fd" This reverts commit 41203ad6abceb6dca39b2dab0adbd8fa711e1f89. --- src/fileio.c | 89 +++++++++++++++++++++++----------------------------- src/lisp.h | 3 -- 2 files changed, 39 insertions(+), 53 deletions(-) diff --git a/src/fileio.c b/src/fileio.c index 91e0efc0a83..6e2fe2f0b82 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -1989,55 +1989,6 @@ clone_file (int dest, int source) } #endif -/* Copy data to OFD from IFD if possible. Return NEWSIZE. */ -off_t -copy_file_fd (int ofd, int ifd, struct stat *st, Lisp_Object newname, - Lisp_Object file) -{ - off_t newsize; - - if (clone_file (ofd, ifd)) - newsize = st->st_size; - else - { - off_t insize = st->st_size; - ssize_t copied; - - for (newsize = 0; newsize < insize; newsize += copied) - { - /* Copy at most COPY_MAX bytes at a time; this is min - (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is - surely aligned well. */ - ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); - ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; - off_t intail = insize - newsize; - ptrdiff_t len = min (intail, copy_max); - copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); - if (copied <= 0) - break; - maybe_quit (); - } - - /* Fall back on read+write if copy_file_range failed, or if the - input is empty and so could be a /proc file. read+write will - either succeed, or report an error more precisely than - copy_file_range would. */ - if (newsize != insize || insize == 0) - { - char buf[MAX_ALLOCA]; - for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); - newsize += copied) - { - if (copied < 0) - report_file_error ("Read error", file); - if (emacs_write_quit (ofd, buf, copied) != copied) - report_file_error ("Write error", newname); - } - } - } - return newsize; -} - DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6, "fCopy file: \nGCopy %s to file: \np\nP", doc: /* Copy FILE to NEWNAME. Both args must be strings. @@ -2192,7 +2143,45 @@ permissions. */) maybe_quit (); - newsize = copy_file_fd (ofd, ifd, &st, newname, file); + if (clone_file (ofd, ifd)) + newsize = st.st_size; + else + { + off_t insize = st.st_size; + ssize_t copied; + + for (newsize = 0; newsize < insize; newsize += copied) + { + /* Copy at most COPY_MAX bytes at a time; this is min + (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is + surely aligned well. */ + ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); + ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; + off_t intail = insize - newsize; + ptrdiff_t len = min (intail, copy_max); + copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); + if (copied <= 0) + break; + maybe_quit (); + } + + /* Fall back on read+write if copy_file_range failed, or if the + input is empty and so could be a /proc file. read+write will + either succeed, or report an error more precisely than + copy_file_range would. */ + if (newsize != insize || insize == 0) + { + char buf[MAX_ALLOCA]; + for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); + newsize += copied) + { + if (copied < 0) + report_file_error ("Read error", file); + if (emacs_write_quit (ofd, buf, copied) != copied) + report_file_error ("Write error", newname); + } + } + } /* Truncate any existing output file after writing the data. This is more likely to work than truncation before writing, if the diff --git a/src/lisp.h b/src/lisp.h index 3c3a9e22cf3..c7e55057ad3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,8 +34,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include - INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -4320,7 +4318,6 @@ extern char *splice_dir_file (char *, char const *, char const *); extern bool file_name_absolute_p (const char *); extern char const *get_homedir (void); extern Lisp_Object expand_and_dir_to_file (Lisp_Object); -extern off_t copy_file_fd (int, int, struct stat *, Lisp_Object, Lisp_Object); extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, int); From 36ab5c6d49f8fbfb858844743223414e6f2f2564 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 08:09:21 +0100 Subject: [PATCH 0659/1452] some more pdumper integration support --- src/comp.c | 18 ++++++++++-------- src/comp.h | 6 ++++-- src/pdumper.c | 48 +++++++++++++++++++++++++++++++++++++----------- 3 files changed, 51 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index 68b1cdf7449..003d3d7ca44 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3136,6 +3136,12 @@ fill_freloc (void) fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); } +int +filled_freloc (void) +{ + return freloc.link_table[0] ? 1 : 0; +} + /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ @@ -3210,7 +3216,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) return Fread (make_string (res->data, res->len)); } -static void +void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) { dynlib_handle_ptr handle = comp_u->handle; @@ -3297,15 +3303,11 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, if (!freloc.link_table[0]) xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); - load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); - if (!handle) - xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); + comp_u->handle = dynlib_open (SSDATA (file)); + if (!comp_u->handle) + xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; - comp_u->fd = fd_out; - comp_u->handle = handle; load_comp_unit (comp_u); return Qt; diff --git a/src/comp.h b/src/comp.h index 36ee5d10e45..c4849ba13d1 100644 --- a/src/comp.h +++ b/src/comp.h @@ -30,8 +30,6 @@ struct Lisp_Native_Comp_Unit Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; - /* Compilation unit file descriptor and handle. */ - int fd; dynlib_handle_ptr handle; }; @@ -49,8 +47,12 @@ XNATIVE_COMP_UNIT (Lisp_Object a) } /* Defined in comp.c. */ +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *); extern void syms_of_comp (void); +/* Fill the freloc structure. Must be called before any eln is loaded. */ extern void fill_freloc (void); +/* Return 1 if freloc is filled or 0 otherwise. */ +extern int filled_freloc (void); #endif #endif diff --git a/src/pdumper.c b/src/pdumper.c index 775f6c3e60b..157457d30d7 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -446,6 +446,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 @@ -939,7 +940,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) && !SUBRP_NATIVE_COMPILEDP (lv)) return XSUBR (lv); if (dump_builtin_symbol_p (lv)) return XSYMBOL (lv); @@ -2941,20 +2942,25 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) #endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); - dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); #ifdef HAVE_NATIVE_COMP if (subr->native_comp_u) { + 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); dump_field_lv (ctx, &out, subr, &subr->native_doc, 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); } dump_field_lv (ctx, &out, subr, &subr->native_comp_u, 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); #endif @@ -2968,9 +2974,10 @@ dump_native_comp_unit (struct dump_context *ctx, { START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); - out->fd = 0; - out->handle = 0; - return finish_dump_pvec (ctx, &out->header); + out->handle = NULL; + + dump_off comp_u_off = finish_dump_pvec (ctx, &out->header); + return comp_u_off; } #endif @@ -3051,6 +3058,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: @@ -3075,11 +3087,6 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "condvar"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); -#ifdef HAVE_NATIVE_COMP - case PVEC_NATIVE_COMP_UNIT: - offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); - break; -#endif default: error_unsupported_dump_object(ctx, lv, "weird pseudovector"); } @@ -3454,6 +3461,22 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object object) } } +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; + ALLOW_IMPLICIT_CONVERSION; + dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); + DISALLOW_IMPLICIT_CONVERSION; +} + static void dump_drain_cold_data (struct dump_context *ctx) { @@ -3497,6 +3520,9 @@ dump_drain_cold_data (struct dump_context *ctx) case COLD_OP_BIGNUM: dump_cold_bignum (ctx, data); break; + case COLD_OP_NATIVE_SUBR: + dump_cold_native_subr (ctx, data); + break; default: emacs_abort (); } @@ -3916,7 +3942,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) && !SUBRP_NATIVE_COMPILEDP(arg)) { dump_value = emacs_offset (XSUBR (arg)); if (type == DUMP_FIXUP_LISP_OBJECT) From 15ac087712250b5ffeb4d162761b2495a5e572a3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 14:12:40 +0100 Subject: [PATCH 0660/1452] add pdump relocation phases --- src/pdumper.c | 52 +++++++++++++++++++++++++++++++++++---------------- 1 file changed, 36 insertions(+), 16 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 157457d30d7..4e770f79af5 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -341,6 +341,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 here every relocation with no dependecy. */ + EARLY_RELOCS, + /* Run just after EARLY_RELOCS. */ + LATE_RELOCS, + /* Relocated at the very last after all hooks has been run. All + lisp machinery (allocation included) is at disposal. */ + 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 @@ -368,7 +382,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 @@ -546,7 +560,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; @@ -1430,7 +1444,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))); } @@ -1463,7 +1477,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))); } @@ -1479,7 +1493,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))); } @@ -1512,7 +1526,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))); } @@ -2229,7 +2243,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))); } @@ -4123,7 +4137,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 (); @@ -4278,8 +4293,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]); unsigned number_hot_relocations = ctx->number_hot_relocations; ctx->number_hot_relocations = 0; unsigned number_discardable_relocations = ctx->number_discardable_relocations; @@ -4297,7 +4313,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 @@ -5295,11 +5312,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]); } @@ -5511,7 +5529,8 @@ 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_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_emacs_relocations (header, dump_base); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); @@ -5522,6 +5541,7 @@ pdumper_load (const char *dump_filename) initialization. */ for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; struct timespec load_timespec = From b6d6e7feb75b792c74fe3e1d036b9edf540d771e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 14:51:18 +0100 Subject: [PATCH 0661/1452] add native compilation unit pdumper support --- src/comp.c | 33 +++++++++++++++++++-------------- src/comp.h | 3 ++- src/pdumper.c | 16 ++++++++++++++++ 3 files changed, 37 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index 003d3d7ca44..43b22a86805 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3217,7 +3217,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } void -load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = @@ -3237,22 +3237,26 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; - /* Imported data. */ - Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); - EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); - - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (d_vec, i); - - comp_u->data_vec = d_vec; /* Imported functions. */ *freloc_link_table = freloc.link_table; - Lisp_Object comp_u_obj; - XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + /* Imported data. */ + if (!loading_dump) + comp_u->data_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); - /* Executing this will perform all the expected environment modification. */ - top_level_run (comp_u_obj); + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); + + if (!loading_dump) + { + Lisp_Object comp_u_obj; + XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + /* Executing this will perform all the expected environment + modification. */ + top_level_run (comp_u_obj); + } return; } @@ -3308,7 +3312,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; - load_comp_unit (comp_u); + comp_u->data_vec = Qnil; + load_comp_unit (comp_u, false); return Qt; } diff --git a/src/comp.h b/src/comp.h index c4849ba13d1..90b4f40426b 100644 --- a/src/comp.h +++ b/src/comp.h @@ -47,7 +47,8 @@ XNATIVE_COMP_UNIT (Lisp_Object a) } /* Defined in comp.c. */ -extern void load_comp_unit (struct Lisp_Native_Comp_Unit *); +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump); extern void syms_of_comp (void); /* Fill the freloc structure. Must be called before any eln is loaded. */ extern void fill_freloc (void); diff --git a/src/pdumper.c b/src/pdumper.c index 4e770f79af5..2dbe6c73fb4 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -197,6 +197,7 @@ 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_BIGNUM, /* dump_lv = make_lisp_ptr (dump_lv + dump_base, type - RELOC_DUMP_TO_DUMP_LV) @@ -2991,6 +2992,11 @@ dump_native_comp_unit (struct dump_context *ctx, 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 the LATE_RELOCS_1 relocation time. */ + dump_push (&ctx->dump_relocs[LATE_RELOCS_1], + list2 (make_fixnum (RELOC_NATIVE_COMP_UNIT), + dump_off_to_lisp (comp_u_off))); return comp_u_off; } #endif @@ -5290,6 +5296,16 @@ dump_do_dump_relocation (const uintptr_t dump_base, dump_write_word_to_dump (dump_base, reloc_offset, value); break; } + case RELOC_NATIVE_COMP_UNIT: + { + struct Lisp_Native_Comp_Unit *comp_u = + dump_ptr (dump_base, reloc_offset); + comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + if (!comp_u->handle) + error ("%s", dynlib_error ()); + load_comp_unit (comp_u, true); + } + break; case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); From 568883c9be8bfbb15ea48ae0de2c117894e8db4e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 16:52:40 +0100 Subject: [PATCH 0662/1452] add native elisp subr pdumper support --- src/comp.c | 14 +++++--------- src/pdumper.c | 34 ++++++++++++++++++++++++++++++---- 2 files changed, 35 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index 43b22a86805..7e25bdc9256 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3202,8 +3202,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /* Functions used to load eln files. */ /**************************************/ -static Lisp_Object Vnative_elisp_refs_hash; - typedef char *(*comp_lit_str_func) (void); /* Deserialize read and return static object. */ @@ -3292,6 +3290,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, XSETSUBR (tem, &x->s); set_symbol_function (name, tem); + Fputhash (name, c_name, Vsym_subr_c_name_h); LOADHIST_ATTACH (Fcons (Qdefun, name)); return Qnil; @@ -3434,13 +3433,10 @@ syms_of_comp (void) /* FIXME should be initialized but not here... */ DEFVAR_LISP ("comp-subr-list", Vsubr_list, doc: /* List of all defined subrs. */); - - /* Load mechanism. */ - staticpro (&Vnative_elisp_refs_hash); - Vnative_elisp_refs_hash - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, - DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, - Qnil, false); + DEFVAR_LISP ("comp-sym-subr-c-name-h", Vsym_subr_c_name_h, + doc: /* Hash table symbol-function -> function-c-name. For + internal use during */); + Vsym_subr_c_name_h = CALLN (Fmake_hash_table); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/pdumper.c b/src/pdumper.c index 2dbe6c73fb4..5bfccb8ac90 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -198,6 +198,7 @@ enum dump_reloc_type 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) @@ -2979,7 +2980,15 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); #endif - return dump_object_finish (ctx, &out, sizeof (out)); + + dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); + if (ctx->flags.dump_object_contents && subr->native_comp_u) + /* 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 @@ -2993,8 +3002,8 @@ dump_native_comp_unit (struct dump_context *ctx, 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 the LATE_RELOCS_1 relocation time. */ - dump_push (&ctx->dump_relocs[LATE_RELOCS_1], + /* 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; @@ -5304,8 +5313,25 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true); + break; + } + case RELOC_NATIVE_SUBR: + { + struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); + Lisp_Object name = intern (subr->symbol_name); + struct Lisp_Native_Comp_Unit *comp_u = + XNATIVE_COMP_UNIT (subr->native_comp_u); + if (!comp_u->handle) + error ("can't relocate native subr with not loaded compilation unit"); + Lisp_Object c_name = Fgethash (name, Vsym_subr_c_name_h, Qnil); + if (NILP (c_name)) + error ("missing label name"); + void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); + if (!func) + error ("can't function in compilation unit"); + subr->function.a0 = func; + break; } - break; case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); From 2ccce1bc3954ce5f2faa0dcf7fa68ec5cae710ca Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 16:58:44 +0100 Subject: [PATCH 0663/1452] some style fixes --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 12 ++++++------ src/lread.c | 2 +- src/pdumper.c | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e8a9b6c2b69..6b9965b8200 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -406,7 +406,7 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :name function-name - :c-name (comp-c-func-name function-name"F") + :c-name (comp-c-func-name function-name "F") :doc (documentation f) :int-spec (interactive-form f)))) (when (byte-code-function-p f) diff --git a/src/comp.c b/src/comp.c index 7e25bdc9256..87986abee68 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1824,7 +1824,7 @@ emit_ctxt_code (void) fields[n_frelocs++] = xmint_pointer (XCDR (el)); } - Lisp_Object subr_l = Vsubr_list; + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); @@ -3121,7 +3121,7 @@ fill_freloc (void) memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); freloc.size = ARRAYELTS (helper_link_table); - Lisp_Object subr_l = Vsubr_list; + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { if (freloc.size == F_RELOC_MAX_SIZE) @@ -3290,7 +3290,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, XSETSUBR (tem, &x->s); set_symbol_function (name, tem); - Fputhash (name, c_name, Vsym_subr_c_name_h); + Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); LOADHIST_ATTACH (Fcons (Qdefun, name)); return Qnil; @@ -3431,12 +3431,12 @@ syms_of_comp (void) Vcomp_ctxt = Qnil; /* FIXME should be initialized but not here... */ - DEFVAR_LISP ("comp-subr-list", Vsubr_list, + DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); - DEFVAR_LISP ("comp-sym-subr-c-name-h", Vsym_subr_c_name_h, + DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, doc: /* Hash table symbol-function -> function-c-name. For internal use during */); - Vsym_subr_c_name_h = CALLN (Fmake_hash_table); + Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/lread.c b/src/lread.c index 1ba04835aa1..4e8a3adeb94 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4466,7 +4466,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETSUBR (tem, sname); set_symbol_function (sym, tem); #ifdef HAVE_NATIVE_COMP - Vsubr_list = Fcons (tem, Vsubr_list); + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); #endif /* HAVE_NATIVE_COMP */ } diff --git a/src/pdumper.c b/src/pdumper.c index 5bfccb8ac90..610b94b0a32 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5323,7 +5323,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, XNATIVE_COMP_UNIT (subr->native_comp_u); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); - Lisp_Object c_name = Fgethash (name, Vsym_subr_c_name_h, Qnil); + Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); if (NILP (c_name)) error ("missing label name"); void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); From ef59b67e4657fa80d1528b9d476c67f01abecc35 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 17:41:44 +0100 Subject: [PATCH 0664/1452] mitigate ifdef proliferation --- src/alloc.c | 17 +++++------------ src/comp.c | 2 +- src/comp.h | 10 ++++++++++ src/data.c | 5 ++--- src/doc.c | 2 -- src/eval.c | 19 +++++++++++-------- src/lisp.h | 15 ++++++++++----- src/lread.c | 32 +++++++++++++++----------------- src/pdumper.c | 21 ++++++--------------- 9 files changed, 60 insertions(+), 63 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 5e0b04b1cc7..6d6f6934bab 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3023,15 +3023,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } -#ifdef HAVE_NATIVE_COMP - else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + 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); eassert (cu->handle); dynlib_close (cu->handle); } -#endif } /* Reclaim space used by unmarked vectors. */ @@ -6565,14 +6564,12 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: -#ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (obj)) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_comp_u); + mark_object (subr->native_comp_u[0]); } -#endif break; case PVEC_FREE: @@ -6717,13 +6714,9 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: -#ifdef HAVE_NATIVE_COMP survives_p = (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); -#else - survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); -#endif break; case Lisp_Cons: @@ -7473,14 +7466,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}, 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}, 0}}; + 4, 4, "watch_gc_cons_percentage", {0}, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index 87986abee68..6f5658191c0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3285,7 +3285,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - x->s.native_comp_u = comp_u; + x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); set_symbol_function (name, tem); diff --git a/src/comp.h b/src/comp.h index 90b4f40426b..f756e38d292 100644 --- a/src/comp.h +++ b/src/comp.h @@ -19,6 +19,16 @@ along with GNU Emacs. If not, see . */ #ifndef COMP_H #define COMP_H +/* To keep ifdefs under control. */ +enum { + NATIVE_COMP_FLAG = +#ifdef HAVE_NATIVE_COMP + 1 +#else + 0 +#endif +}; + #ifdef HAVE_NATIVE_COMP #include diff --git a/src/data.c b/src/data.c index 3fb0fc0a190..d20db4dc3a3 100644 --- a/src/data.c +++ b/src/data.c @@ -881,7 +881,7 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, (Lisp_Object subr) { CHECK_SUBR (subr); - return XSUBR (subr)->native_comp_u; + return XSUBR (subr)->native_comp_u[0]; } DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, @@ -919,10 +919,9 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { -#ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; -#endif + const char *spec = XSUBR (fun)->intspec; if (spec) return list2 (Qinteractive, diff --git a/src/doc.c b/src/doc.c index 9e1d8392787..2c96fc15a7c 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,12 +510,10 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } -#ifdef HAVE_NATIVE_COMP else if (SUBRP_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->native_doc = Qnil; } -#endif /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) { diff --git a/src/eval.c b/src/eval.c index bf37ed9cefa..253de05a658 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,14 +219,17 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ -#ifndef HAVE_NATIVE_COMP - max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ - max_lisp_eval_depth = 800; -#else - /* Original values increased for comp.el. */ - max_specpdl_size = 2100; - max_lisp_eval_depth = 1400; -#endif + if (!NATIVE_COMP_FLAG) + { + max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ + max_lisp_eval_depth = 800; + } + else + { + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; + } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } diff --git a/src/lisp.h b/src/lisp.h index c7e55057ad3..a4cabc34855 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2098,9 +2098,7 @@ struct Lisp_Subr EMACS_INT doc; Lisp_Object native_doc; }; -#ifdef HAVE_NATIVE_COMP - Lisp_Object native_comp_u; -#endif + Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -3113,7 +3111,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}, 0}}; \ + minargs, maxargs, lname, {intspec}, {0}}}; \ Lisp_Object fnname /* defsubr (Sname); @@ -4763,7 +4761,7 @@ extern char *emacs_root_dir (void); INLINE bool SUBRP_NATIVE_COMPILEDP (Lisp_Object a) { - return SUBRP (a) && XSUBR (a)->native_comp_u; + return SUBRP (a) && XSUBR (a)->native_comp_u[0]; } INLINE struct Lisp_Native_Comp_Unit * @@ -4772,6 +4770,13 @@ allocate_native_comp_unit (void) return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, PVEC_NATIVE_COMP_UNIT); } +#else +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/lread.c b/src/lread.c index 4e8a3adeb94..1c5268d0dad 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,11 +1281,9 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif -#ifdef HAVE_NATIVE_COMP - bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); -#else - bool is_native_elisp = 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 @@ -1486,15 +1484,16 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { -#ifdef HAVE_NATIVE_COMP - specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (found); - Fnative_elisp_load (found); - build_load_history (found, true); -#else - /* This cannot happen. */ - emacs_abort (); -#endif + if (NATIVE_COMP_FLAG) + { + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fnative_elisp_load (found); + build_load_history (found, true); + } + else + /* This cannot happen. */ + emacs_abort (); } else { @@ -4465,9 +4464,8 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); -#ifdef HAVE_NATIVE_COMP - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); -#endif /* HAVE_NATIVE_COMP */ + if (NATIVE_COMP_FLAG) + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); } #ifdef NOTDEF /* Use fset in subr.el now! */ diff --git a/src/pdumper.c b/src/pdumper.c index 610b94b0a32..d66c4e99642 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,18 +2948,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); -#ifdef HAVE_NATIVE_COMP - if (subr->native_comp_u) + if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) out.function.a0 = NULL; else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); -#else - dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); -#endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); -#ifdef HAVE_NATIVE_COMP - if (subr->native_comp_u) + if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) { dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); dump_remember_cold_op (ctx, @@ -2974,15 +2969,11 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); } - dump_field_lv (ctx, &out, subr, &subr->native_comp_u, 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); -#endif + if (NATIVE_COMP_FLAG) + dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && subr->native_comp_u) + if (ctx->flags.dump_object_contents && 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], @@ -5320,7 +5311,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = - XNATIVE_COMP_UNIT (subr->native_comp_u); + XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); From e678021f0c3db705c91831cff466561fd73c3040 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 20:38:13 +0100 Subject: [PATCH 0665/1452] add batch-native-compile --- lisp/emacs-lisp/comp.el | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6b9965b8200..983ba0e0ba1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1886,6 +1886,11 @@ Return the compilation unit file name." (list input err-val)))))) data)) +;;;###autoload +(defun batch-native-compile () + "Ultra cheap impersonation of `batch-byte-compile'." + (mapc #'native-compile command-line-args-left)) + ;;;###autoload (defun native-compile-async (input &optional jobs recursively) "Compile INPUT asynchronously. From cedc19297e47473ae599faa7cbcb2f3f6c9d5846 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 22:26:20 +0100 Subject: [PATCH 0666/1452] add elns to the gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index d4be6bb23eb..52816e8473f 100644 --- a/.gitignore +++ b/.gitignore @@ -132,6 +132,7 @@ src/gl-stamp *.dll *.core *.elc +*.eln *.o *.res *.so From 44db9b912f1d8165383b5b30732fa9caa3d3a185 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Dec 2019 16:02:46 +0100 Subject: [PATCH 0667/1452] never load a compilation unit without filling the func link table --- src/comp.c | 23 +++++++++++------------ src/comp.h | 5 ----- src/emacs.c | 4 ---- 3 files changed, 11 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6f5658191c0..9baa990061b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3113,14 +3113,19 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, } -void -fill_freloc (void) +static void +freloc_check_fill (void) { + if (freloc.size) + return; + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) goto overflow; memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); freloc.size = ARRAYELTS (helper_link_table); + eassert (!NILP (Vcomp_subr_list)); + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { @@ -3136,12 +3141,6 @@ fill_freloc (void) fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); } -int -filled_freloc (void) -{ - return freloc.link_table[0] ? 1 : 0; -} - /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ @@ -3217,6 +3216,8 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { + freloc_check_fill (); + dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); @@ -3303,9 +3304,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); - if (!freloc.link_table[0]) - xsignal2 (Qnative_lisp_load_failed, file, - build_string ("Empty relocation table")); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); comp_u->handle = dynlib_open (SSDATA (file)); if (!comp_u->handle) @@ -3430,7 +3428,8 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - /* FIXME should be initialized but not here... */ + /* FIXME should be initialized but not here... Plus this don't have + to be necessarily exposed to lisp but can easy debug for now. */ DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, diff --git a/src/comp.h b/src/comp.h index f756e38d292..33b73548009 100644 --- a/src/comp.h +++ b/src/comp.h @@ -60,10 +60,5 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); -/* Fill the freloc structure. Must be called before any eln is loaded. */ -extern void fill_freloc (void); -/* Return 1 if freloc is filled or 0 otherwise. */ -extern int filled_freloc (void); - #endif #endif diff --git a/src/emacs.c b/src/emacs.c index 0798e0702f2..90ab7ac1e8e 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2050,10 +2050,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem moncontrol (0); #endif -#ifdef HAVE_NATIVE_COMP - fill_freloc (); -#endif - initialized = true; if (dump_mode) From 726d8c5bae847a3240b758a1d25135865e9304f0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Dec 2019 17:07:55 +0100 Subject: [PATCH 0668/1452] move late relocs after emacs relocations --- src/pdumper.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index d66c4e99642..422bec47a66 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -348,7 +348,7 @@ enum reloc_phase { /* First to run. Place here every relocation with no dependecy. */ EARLY_RELOCS, - /* Run just after EARLY_RELOCS. */ + /* Running after emacs relocations. */ LATE_RELOCS, /* Relocated at the very last after all hooks has been run. All lisp machinery (allocation included) is at disposal. */ @@ -5563,8 +5563,8 @@ pdumper_load (const char *dump_filename) dump_public.end = dump_public.start + dump_size; dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS); - dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_emacs_relocations (header, dump_base); + dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); for (int i = 0; i < ARRAYELTS (sections); ++i) From 5f63ac26ccc18bcf9e364b74af4424f9e3677cf8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Dec 2019 18:26:17 +0100 Subject: [PATCH 0669/1452] always fill freloc before compiling too --- src/comp.c | 58 +++++++++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9baa990061b..b0812433337 100644 --- a/src/comp.c +++ b/src/comp.c @@ -225,6 +225,34 @@ format_string (const char *format, ...) return scratch_area; } +static void +freloc_check_fill (void) +{ + if (freloc.size) + return; + + eassert (!NILP (Vcomp_subr_list)); + + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) + goto overflow; + memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); + freloc.size = ARRAYELTS (helper_link_table); + + Lisp_Object subr_l = Vcomp_subr_list; + FOR_EACH_TAIL (subr_l) + { + if (freloc.size == F_RELOC_MAX_SIZE) + goto overflow; + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + freloc.link_table[freloc.size] = subr->function.a0; + freloc.size++; + } + return; + + overflow: + fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); +} + static void bcall0 (Lisp_Object f) { @@ -1813,7 +1841,7 @@ emit_ctxt_code (void) emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); /* Functions imported from Lisp code. */ - + freloc_check_fill (); gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); ptrdiff_t n_frelocs = 0; Lisp_Object f_runtime = declare_runtime_imported_funcs (); @@ -3113,34 +3141,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, } -static void -freloc_check_fill (void) -{ - if (freloc.size) - return; - - if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) - goto overflow; - memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); - freloc.size = ARRAYELTS (helper_link_table); - - eassert (!NILP (Vcomp_subr_list)); - - Lisp_Object subr_l = Vcomp_subr_list; - FOR_EACH_TAIL (subr_l) - { - if (freloc.size == F_RELOC_MAX_SIZE) - goto overflow; - struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); - freloc.link_table[freloc.size] = subr->function.a0; - freloc.size++; - } - return; - - overflow: - fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); -} - /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ From 4beb850efb99b881fb8b648ad7bb43c6539a2431 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 20:48:49 +0100 Subject: [PATCH 0670/1452] add native support to the build system --- lisp/Makefile.in | 41 ++++++++++++++++++++++++++++++++++--- lisp/emacs-lisp/autoload.el | 2 +- src/Makefile.in | 20 ++++++++++++++++-- 3 files changed, 57 insertions(+), 6 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 57527bb5afc..91b44de46aa 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -32,6 +32,11 @@ XARGS_LIMIT = @XARGS_LIMIT@ # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +AM_V_ELN = $(am__v_ELN_@AM_V@) +am__v_ELN_ = $(am__v_ELN_@AM_DEFAULT_V@) +am__v_ELN_0 = @echo " ELN " $@; +am__v_ELN_1 = + AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) am__v_ELC_0 = @echo " ELC " $@; @@ -99,7 +104,8 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/cconv.elc \ $(lisp)/emacs-lisp/byte-opt.elc \ $(lisp)/emacs-lisp/bytecomp.elc \ - $(lisp)/emacs-lisp/autoload.elc + $(lisp)/emacs-lisp/autoload.elc \ + $(lisp)/emacs-lisp/comp.elc # Files to compile early in compile-main. Works around bug#25556. MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ @@ -127,7 +133,7 @@ SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS}) # cus-load and finder-inf are not explicitly requested by anything, so # we add them here to make sure they get built. -all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el +all: compile-main compile-native-main $(lisp)/cus-load.el $(lisp)/finder-inf.el PHONY_EXTRAS = .PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) @@ -281,6 +287,13 @@ $(THEFILE)c: -l bytecomp -f byte-compile-refresh-preloaded \ -f batch-byte-compile $(THEFILE) +THEFILE = no-such-file +.PHONY: $(THEFILE)n +$(THEFILE)n: + $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l comp -f byte-compile-refresh-preloaded \ + -f batch-native-compile $(THEFILE) + # 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 # the compilation environment is clean. We also set the load-path of @@ -288,13 +301,16 @@ $(THEFILE)c: # subdirectories, to make sure require's and load's in the files being # compiled find the right files. -.SUFFIXES: .elc .el +.SUFFIXES: .eln .elc .el # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. .el.elc: $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< +.el.eln: + $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-native-compile $< + .PHONY: compile-first compile-main compile compile-always compile-first: $(COMPILE_FIRST) @@ -329,6 +345,21 @@ compile-main: gen-lisp compile-clean $(MAKE) compile-targets TARGETS="$$chunk"; \ done +# Obsiusly copy pasted from above. Just do it on elns + ignoring errors... +compile-native-main: gen-lisp compile-clean + @(cd $(lisp) && \ + els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ + for el in ${MAIN_FIRST} $$els; do \ + test -f $$el || continue; \ + test ! -f $${el}c && \ + GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ + continue; \ + echo "$${el}n"; \ + done | xargs $(XARGS_LIMIT) echo) | \ + while read chunk; do \ + $(MAKE) -i compile-targets TARGETS="$$chunk"; \ + done + .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -338,6 +369,8 @@ compile-clean: if test -f "$$el" || test ! -f "$${el}c"; then :; else \ echo rm "$${el}c"; \ rm "$${el}c"; \ + echo rm "$${el}n"; \ + rm "$${el}n"; \ fi; \ done @@ -361,6 +394,8 @@ semantic: # Calling make recursively because suffix rule cannot have prerequisites. compile: $(LOADDEFS) autoloads compile-first $(MAKE) compile-main +# Ignore error for now cause we can't compile dynamic code + $(MAKE) -i compile-native-main # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 785e350e0e5..53d353858b3 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1045,7 +1045,7 @@ write its autoloads into the specified file instead." ;; we don't want to depend on whether Emacs was ;; built with or without modules support, nor ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) + (unless (string-match "\\.\\(elc\\|eln\\|so\\|dll\\)" suf) (push suf tmp))) (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc diff --git a/src/Makefile.in b/src/Makefile.in index 6c65275d6da..faf24802791 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -513,14 +513,26 @@ lisp.mk: $(lispsource)/loadup.el sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ echo "" ) > $@ +shortnativelisp = +native_lisp.mk: $(lispsource)/loadup.el + @rm -f $@ + ${AM_V_GEN}( printf 'shortnativelisp = \\\n'; \ + sed -n 's/^[ \t]*(load "\([^"]*\)".*/\1/p' $< | \ + sed -e 's/$$/.eln \\/' -e 's/\.el\.eln/.el/'; \ + echo "" ) > $@ + -include lisp.mk +-include native_lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) +shortnativelisp_filter = leim/leim-list.el site-load.eln site-init.eln +shortnativelisp := $(filter-out ${shortnativelisp_filter},${shortnativelisp}) ## Place loaddefs.el first, so it gets generated first, since it is on ## 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}) lisp = $(addprefix ${lispsource}/,${shortlisp}) +nativelisp = $(addprefix ${lispsource}/,${shortnativelisp}) ## Construct full set of libraries to be linked. LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ @@ -571,7 +583,7 @@ ${lispintdir}/characters.elc: ${charscript:.el=.elc} ## since not all pieces are used on all platforms. But DOC depends ## on all of $lisp, and emacs depends on DOC, so it is ok to use $lisp here. emacs$(EXEEXT): temacs$(EXEEXT) \ - lisp.mk $(etc)/DOC $(lisp) \ + lisp.mk native_lisp.mk $(etc)/DOC $(lisp) $(nativelisp) \ $(lispsource)/international/charprop.el ${charsets} ifeq ($(DUMPING),unexec) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=dump @@ -721,7 +733,7 @@ bootstrap-clean: clean fi distclean: bootstrap-clean - rm -f Makefile lisp.mk + rm -f Makefile lisp.mk native_lisp.mk rm -fr $(DEPDIR) maintainer-clean: distclean @@ -788,6 +800,10 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS @$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\ THEFILE=$< $ Date: Wed, 25 Dec 2019 20:24:01 +0100 Subject: [PATCH 0671/1452] adjust max_specpdl_size to sustain bootstrap --- src/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/eval.c b/src/eval.c index 253de05a658..e5c850a579e 100644 --- a/src/eval.c +++ b/src/eval.c @@ -227,8 +227,8 @@ init_eval_once (void) else { /* Original values increased for comp.el. */ - max_specpdl_size = 2100; - max_lisp_eval_depth = 1400; + max_specpdl_size = 2500; + max_lisp_eval_depth = 1600; } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); From fdb31d6a2709bff751c2ad240c41b30db1848b44 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Dec 2019 23:04:13 +0100 Subject: [PATCH 0672/1452] fix naming for predicate SUBR_NATIVE_COMPILEDP --- src/alloc.c | 4 ++-- src/data.c | 4 ++-- src/doc.c | 2 +- src/lisp.h | 4 ++-- src/pdumper.c | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 6d6f6934bab..faa8e703937 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6564,7 +6564,7 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: - if (SUBRP_NATIVE_COMPILEDP (obj)) + if (SUBR_NATIVE_COMPILEDP (obj)) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); @@ -6715,7 +6715,7 @@ survives_gc_p (Lisp_Object obj) case Lisp_Vectorlike: survives_p = - (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || + (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); break; diff --git a/src/data.c b/src/data.c index d20db4dc3a3..191fb313687 100644 --- a/src/data.c +++ b/src/data.c @@ -872,7 +872,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; + return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -919,7 +919,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) + if (SUBR_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; const char *spec = XSUBR (fun)->intspec; diff --git a/src/doc.c b/src/doc.c index 2c96fc15a7c..192e2011093 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,7 +510,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - else if (SUBRP_NATIVE_COMPILEDP (fun)) + else if (SUBR_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->native_doc = Qnil; } diff --git a/src/lisp.h b/src/lisp.h index a4cabc34855..69db8cdef10 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4759,7 +4759,7 @@ extern char *emacs_root_dir (void); #ifdef HAVE_NATIVE_COMP INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +SUBR_NATIVE_COMPILEDP (Lisp_Object a) { return SUBRP (a) && XSUBR (a)->native_comp_u[0]; } @@ -4772,7 +4772,7 @@ allocate_native_comp_unit (void) } #else INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +SUBR_NATIVE_COMPILEDP (Lisp_Object a) { return false; } diff --git a/src/pdumper.c b/src/pdumper.c index 422bec47a66..81d48496be2 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -956,7 +956,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object object) static void * dump_object_emacs_ptr (Lisp_Object lv) { - if (SUBRP (lv) && !SUBRP_NATIVE_COMPILEDP (lv)) + if (SUBRP (lv) && !SUBR_NATIVE_COMPILEDP (lv)) return XSUBR (lv); if (dump_builtin_symbol_p (lv)) return XSYMBOL (lv); @@ -3962,7 +3962,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) && !SUBRP_NATIVE_COMPILEDP(arg)) + if (SUBRP (arg) && !SUBR_NATIVE_COMPILEDP (arg)) { dump_value = emacs_offset (XSUBR (arg)); if (type == DUMP_FIXUP_LISP_OBJECT) From 92e285fdf0821d8a01db598c4e2ac7e2e0fbb3cf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 26 Dec 2019 08:35:01 +0100 Subject: [PATCH 0673/1452] set disassemble buffer in read only --- lisp/emacs-lisp/disass.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index c23dbe1e068..82c8de6e133 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -103,6 +103,7 @@ redefine OBJECT if it is a symbol." (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 #" name))) (if (eq (car-safe obj) 'macro) ;Handle macros. From a5a1b53807a9449298f62c761223e6a1c5654bf7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 26 Dec 2019 20:40:43 +0100 Subject: [PATCH 0674/1452] do not force function inlining --- src/comp.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index b0812433337..98ee6c19a2a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2239,7 +2239,7 @@ define_CHECK_TYPE (void) "x") }; comp.check_type = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.void_type, "CHECK_TYPE", 3, @@ -2613,7 +2613,7 @@ define_PSEUDOVECTORP (void) comp.pseudovectorp = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.bool_type, "PSEUDOVECTORP", 2, @@ -2665,7 +2665,7 @@ define_CHECK_IMPURE (void) "ptr") }; comp.check_impure = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.void_type, "CHECK_IMPURE", 2, @@ -2709,7 +2709,7 @@ define_bool_to_lisp_obj (void) "x"); comp.bool_to_lisp_obj = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, "bool_to_lisp_obj", 1, From f4cb9cc9034c09a8798df3d98f6fa9313a777a96 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Dec 2019 15:57:31 +0100 Subject: [PATCH 0675/1452] rename IMPORTED_FUNC_LINK_TABLE -> FUNC_LINK_TABLE_SYM --- src/comp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 98ee6c19a2a..85b0983a6df 100644 --- a/src/comp.c +++ b/src/comp.c @@ -38,7 +38,7 @@ along with GNU Emacs. If not, see . */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" -#define IMPORTED_FUNC_LINK_TABLE "freloc_link_table" +#define FUNC_LINK_TABLE_SYM "freloc_link_table" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) @@ -1873,7 +1873,7 @@ emit_ctxt_code (void) NULL, GCC_JIT_GLOBAL_EXPORTED, gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), - IMPORTED_FUNC_LINK_TABLE); + FUNC_LINK_TABLE_SYM); xfree (fields); } @@ -3223,7 +3223,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - void **freloc_link_table = dynlib_sym (handle, IMPORTED_FUNC_LINK_TABLE); + void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc From 1c08dc82121d50e80bd2dcb0d1f39654cc6762dd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Dec 2019 17:02:23 +0100 Subject: [PATCH 0676/1452] some rework to please --enable-check-lisp-object-type --- src/comp.c | 2 +- src/data.c | 2 +- src/lisp.h | 2 +- src/pdumper.c | 6 +++--- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 85b0983a6df..eacda5de550 100644 --- a/src/comp.c +++ b/src/comp.c @@ -866,7 +866,7 @@ emit_const_lisp_obj (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); - if (Qnil == NULL && EQ (obj, Qnil)) + if (NIL_IS_ZERO && EQ (obj, Qnil)) return emit_cast (comp.lisp_obj_type, gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, diff --git a/src/data.c b/src/data.c index 191fb313687..8901ffbb2c3 100644 --- a/src/data.c +++ b/src/data.c @@ -919,7 +919,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBR_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) + if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec)) return XSUBR (fun)->native_intspec; const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index 69db8cdef10..2d083dc4582 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4761,7 +4761,7 @@ extern char *emacs_root_dir (void); INLINE bool SUBR_NATIVE_COMPILEDP (Lisp_Object a) { - return SUBRP (a) && XSUBR (a)->native_comp_u[0]; + return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); } INLINE struct Lisp_Native_Comp_Unit * diff --git a/src/pdumper.c b/src/pdumper.c index 81d48496be2..a35cc7ffcd6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,13 +2948,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); - if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) + 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); - if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) + 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, @@ -2973,7 +2973,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && subr->native_comp_u[0]) + if (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], From c00236a880567c72dcdba5fc90d6de1125616c76 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Dec 2019 16:28:44 +0100 Subject: [PATCH 0677/1452] sign and check function link table --- src/comp.c | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index eacda5de550..5ef09086407 100644 --- a/src/comp.c +++ b/src/comp.c @@ -33,12 +33,14 @@ along with GNU Emacs. If not, see . */ #include "dynlib.h" #include "buffer.h" #include "blockinput.h" +#include "sha512.h" /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define FUNC_LINK_TABLE_SYM "freloc_link_table" +#define LINK_TABLE_HASH_SYM "freloc_hash" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) @@ -225,6 +227,21 @@ format_string (const char *format, ...) return scratch_area; } +/* Produce a key hashing Vcomp_subr_list. */ + +static Lisp_Object +hash_subr_list (void) +{ + Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string (" ")); + Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); + + sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + + return digest; +} + static void freloc_check_fill (void) { @@ -1852,6 +1869,9 @@ emit_ctxt_code (void) fields[n_frelocs++] = xmint_pointer (XCDR (el)); } + /* Compute and store function link table hash. */ + emit_static_object (LINK_TABLE_HASH_SYM, hash_subr_list ()); + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { @@ -3205,10 +3225,12 @@ typedef char *(*comp_lit_str_func) (void); /* Deserialize read and return static object. */ static Lisp_Object -load_static_obj (dynlib_handle_ptr handle, const char *name) +load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) { - static_obj_t *(*f)(void) = dynlib_sym (handle, name); - eassert (f); + static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name); + if (!f) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + static_obj_t *res = f (); return Fread (make_string (res->data, res->len)); } @@ -3230,7 +3252,9 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) && pure_reloc && data_relocs && freloc_link_table - && top_level_run)) + && top_level_run) + || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), + hash_subr_list ()))) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; @@ -3241,7 +3265,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) /* Imported data. */ if (!loading_dump) - comp_u->data_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); @@ -3408,7 +3432,8 @@ syms_of_comp (void) Fput (Qnative_lisp_file_inconsistent, Qerror_conditions, pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror)); Fput (Qnative_lisp_file_inconsistent, Qerror_message, - build_pure_c_string ("inconsistent eln file")); + build_pure_c_string ("eln file inconsistent with current runtime " + "configuration, please recompile")); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); From 0bb5a47402313634b0e8654355e519388851e07f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Dec 2019 23:02:47 +0100 Subject: [PATCH 0678/1452] move LATE_RELOCS just before VERY_LATE_RELOCS --- src/pdumper.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index a35cc7ffcd6..85809c9978f 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -348,10 +348,10 @@ enum reloc_phase { /* First to run. Place here every relocation with no dependecy. */ EARLY_RELOCS, - /* Running after emacs relocations. */ + /* 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, - /* Relocated at the very last after all hooks has been run. All - lisp machinery (allocation included) is at disposal. */ VERY_LATE_RELOCS, /* Fake, must be last. */ RELOC_NUM_PHASES @@ -5564,7 +5564,6 @@ pdumper_load (const char *dump_filename) dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS); dump_do_all_emacs_relocations (header, dump_base); - dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); for (int i = 0; i < ARRAYELTS (sections); ++i) @@ -5574,6 +5573,8 @@ pdumper_load (const char *dump_filename) initialization. */ for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + + 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); initialized = true; From 00f7fd7d427b85e69a53403a1d10ac122a92a95d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 28 Dec 2019 11:39:29 +0100 Subject: [PATCH 0679/1452] fix non local propagation handling --- lisp/emacs-lisp/comp.el | 16 +++++++++++++--- src/comp.c | 9 ++++++++- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 983ba0e0ba1..b212f24bf9c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -248,7 +248,9 @@ structure.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.")) + :documentation "Counter to create ssa limple vars.") + (has-non-local nil :type boolean + :documentation "t if non local jumps are present.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -660,6 +662,7 @@ Return value is the fall through block name." "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label (cl-assert (= (- label-sp 2) (comp-sp))) + (setf (comp-func-has-non-local comp-func) t) (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) @@ -1350,8 +1353,12 @@ Top-level forms for the current context are rendered too." (slot-assigned-p (slot-n bb) ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) - when (and (comp-assign-op-p (car insn)) - (eql slot-n (comp-mvar-slot (cadr insn)))) + for op = (car insn) + when (or (and (comp-assign-op-p op) + (eql slot-n (comp-mvar-slot (cadr insn)))) + ;; fetch-handler is after a non local + ;; therefore clobbers all frame!!! + (eq op 'fetch-handler)) return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) @@ -1411,6 +1418,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (let ((mvar (aref frame slot-n))) (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) (new-lvalue)) + (`(fetch-handler . ,_) + ;; Clobber all no matter what! + (setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) diff --git a/src/comp.c b/src/comp.c index 5ef09086407..df841a66fd1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -146,6 +146,7 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ + bool func_has_non_local; /* From comp-func has-non-local slot. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ @@ -355,7 +356,11 @@ get_slot (Lisp_Object mvar) } EMACS_INT slot_n = XFIXNUM (mvar_slot); gcc_jit_lvalue **frame = - (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) + /* Disable floating frame for functions with non local jumps. + This is probably overkill cause we could do it just for blocks + dominated by push-handler. */ + comp.func_has_non_local + || (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; return frame[slot_n]; } @@ -2824,6 +2829,8 @@ compile_function (Lisp_Object func) comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), comp.exported_funcs_h, Qnil)); + comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); + gcc_jit_lvalue *frame_array = gcc_jit_function_new_local ( comp.func, From e666bf781f1d3d74068e8d2b505e35dd75b5b423 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Dec 2019 14:10:19 +0100 Subject: [PATCH 0680/1452] add customize comp-never-optimize-functions --- lisp/emacs-lisp/comp.el | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b212f24bf9c..99cc93580bf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,6 +74,15 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) +(defcustom comp-never-optimize-functions + '(macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer + make-indirect-buffer delete-file top-level abort-recursive-edit) + "Primitive functions for which we do not perform trampoline optimization. +This is especially usefull for primitives known to be advised if bootstrap is +performed at `comp-speed' > 0." + :type 'list + :group 'comp) + (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -1631,7 +1640,8 @@ Return t if something was changed." (setf (comp-mvar-ref arg) nil)) args) args)) - (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. + (not (member callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) (callee-in-unit (gethash callee From 037b9897a464bf25ef9587ee860cc7f20376a97c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Dec 2019 15:56:49 +0100 Subject: [PATCH 0681/1452] add batch-byte-native-compile-for-bootstrap --- lisp/emacs-lisp/bytecomp.el | 7 +++++-- lisp/emacs-lisp/comp.el | 31 ++++++++++++++++++++++++------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3e354951ea3..19d9884c3fc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -570,7 +570,9 @@ Each element is (INDEX . VALUE)") "All other top level forms." form) (defvar byte-native-compiling nil - "t while native compiling.") + "Non nil while native compiling.") +(defvar byte-native-always-write-elc nil + "Always write the elc file also while native compiling.") (defvar byte-to-native-lap nil "A-list to accumulate LAP. Each pair is (NAME . LAP)") @@ -2032,7 +2034,8 @@ The value is non-nil if there were no errors, nil if errors." ;; emacs-lisp files in the build tree are ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. - (if byte-native-compiling + (if (and byte-native-compiling + (not byte-native-always-write-elc)) (delete-file tempfile) (rename-file tempfile target-file t))) (or noninteractive (message "Wrote %s" target-file))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99cc93580bf..9272bcc0021 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -140,6 +140,13 @@ Can be used by code that wants to expand differently in this case.") direct-callref) "Limple operators use to call subrs.") +(define-error 'native-compiler-error-dyn-func + "can't native compile a non lexical scoped function" + 'native-compiler-error) +(define-error 'native-compiler-error-empty-byte + "empty byte compiler output" + 'native-compiler-error) + (eval-when-compile (defconst comp-op-stack-info (cl-loop with h = (make-hash-table) @@ -390,11 +397,10 @@ Put PREFIX in front of it." (rx (not (any "0-9a-z_"))) "" human-readable))) (concat prefix crypted "_" human-readable))) -(defun comp-decrypt-arg-list (x) - "Decript argument list X." +(defun comp-decrypt-arg-list (x function-name) + "Decript argument list X for FUNCTION-NAME." (unless (fixnump x) - (signal 'native-compiler-error - "can't native compile a non lexical scoped function")) + (signal 'native-compiler-error-dyn-func function-name)) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -430,7 +436,7 @@ Put PREFIX in front of it." (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) - (comp-decrypt-arg-list arg-list) + (comp-decrypt-arg-list arg-list function-name) (comp-func-lap func) lap (comp-func-frame-size func) @@ -443,7 +449,7 @@ Put PREFIX in front of it." "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms - (signal 'native-compiler-error "empty byte compiler output")) + (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. @@ -458,7 +464,7 @@ Put PREFIX in front of it." :doc (documentation data) :int-spec (interactive-form data) :c-name (comp-c-func-name name "F") - :args (comp-decrypt-arg-list (aref data 0)) + :args (comp-decrypt-arg-list (aref data 0) name) :lap (alist-get name byte-to-native-lap) :frame-size (comp-byte-frame-size data)) do (comp-log (format "Function %s:\n" name) 1) @@ -1911,6 +1917,17 @@ Return the compilation unit file name." "Ultra cheap impersonation of `batch-byte-compile'." (mapc #'native-compile command-line-args-left)) +;;;###autoload +(defun batch-byte-native-compile-for-bootstrap () + "As `batch-byte-compile' but used for booststrap. +Always generate elc files too and handle native compiler expected errors." + ;; FIXME remove when dynamic scope support is implemented. + (let ((byte-native-always-write-elc t)) + (condition-case _ + (batch-native-compile) + (native-compiler-error-dyn-func) + (native-compiler-error-empty-byte)))) + ;;;###autoload (defun native-compile-async (input &optional jobs recursively) "Compile INPUT asynchronously. From 2875340c9fcc3bd6a799a3c4a4d875fc753ea7b1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Dec 2019 22:46:06 +0100 Subject: [PATCH 0682/1452] fix nit --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index df841a66fd1..7d4bcc2cdff 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3284,7 +3284,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) Lisp_Object comp_u_obj; XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); /* Executing this will perform all the expected environment - modification. */ + modifications. */ top_level_run (comp_u_obj); } From 4946ed48fee637eba75b674b9ad568b9df26bac9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Dec 2019 16:06:07 +0100 Subject: [PATCH 0683/1452] rework build system for one pass --- lisp/Makefile.in | 42 +++++++++++++----------------------------- src/Makefile.in | 17 +++-------------- 2 files changed, 16 insertions(+), 43 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 91b44de46aa..5bcb85ff141 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -34,12 +34,12 @@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AM_V_ELN = $(am__v_ELN_@AM_V@) am__v_ELN_ = $(am__v_ELN_@AM_DEFAULT_V@) -am__v_ELN_0 = @echo " ELN " $@; +am__v_ELN_0 = @echo " ELC+ELN " $@; am__v_ELN_1 = AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) -am__v_ELC_0 = @echo " ELC " $@; +am__v_ELC_0 = @echo " ELC+ELN " $@; am__v_ELC_1 = AM_V_GEN = $(am__v_GEN_@AM_V@) @@ -133,7 +133,7 @@ SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS}) # cus-load and finder-inf are not explicitly requested by anything, so # we add them here to make sure they get built. -all: compile-main compile-native-main $(lisp)/cus-load.el $(lisp)/finder-inf.el +all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el PHONY_EXTRAS = .PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) @@ -280,19 +280,19 @@ TAGS: ${ETAGS} ${tagsfiles} # src/Makefile.in to rebuild a particular Lisp file, no questions asked. # Use byte-compile-refresh-preloaded to try and work around some of # the most common problems of not bootstrapping from a clean state. +# THEFILE = no-such-file +# .PHONY: $(THEFILE)c +# $(THEFILE)c: +# $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ +# -l bytecomp -f byte-compile-refresh-preloaded \ +# -f batch-byte-compile $(THEFILE) + THEFILE = no-such-file .PHONY: $(THEFILE)c $(THEFILE)c: - $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ - -l bytecomp -f byte-compile-refresh-preloaded \ - -f batch-byte-compile $(THEFILE) - -THEFILE = no-such-file -.PHONY: $(THEFILE)n -$(THEFILE)n: $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f byte-compile-refresh-preloaded \ - -f batch-native-compile $(THEFILE) + -f batch-byte-native-compile-for-bootstrap $(THEFILE) # 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 @@ -306,7 +306,8 @@ $(THEFILE)n: # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. .el.elc: - $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l comp -f batch-byte-native-compile-for-bootstrap $< .el.eln: $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-native-compile $< @@ -345,21 +346,6 @@ compile-main: gen-lisp compile-clean $(MAKE) compile-targets TARGETS="$$chunk"; \ done -# Obsiusly copy pasted from above. Just do it on elns + ignoring errors... -compile-native-main: gen-lisp compile-clean - @(cd $(lisp) && \ - els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ - for el in ${MAIN_FIRST} $$els; do \ - test -f $$el || continue; \ - test ! -f $${el}c && \ - GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ - continue; \ - echo "$${el}n"; \ - done | xargs $(XARGS_LIMIT) echo) | \ - while read chunk; do \ - $(MAKE) -i compile-targets TARGETS="$$chunk"; \ - done - .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -394,8 +380,6 @@ semantic: # Calling make recursively because suffix rule cannot have prerequisites. compile: $(LOADDEFS) autoloads compile-first $(MAKE) compile-main -# Ignore error for now cause we can't compile dynamic code - $(MAKE) -i compile-native-main # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they diff --git a/src/Makefile.in b/src/Makefile.in index faf24802791..cc43cd9f319 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -513,26 +513,15 @@ lisp.mk: $(lispsource)/loadup.el sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ echo "" ) > $@ -shortnativelisp = -native_lisp.mk: $(lispsource)/loadup.el - @rm -f $@ - ${AM_V_GEN}( printf 'shortnativelisp = \\\n'; \ - sed -n 's/^[ \t]*(load "\([^"]*\)".*/\1/p' $< | \ - sed -e 's/$$/.eln \\/' -e 's/\.el\.eln/.el/'; \ - echo "" ) > $@ -include lisp.mk --include native_lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) -shortnativelisp_filter = leim/leim-list.el site-load.eln site-init.eln -shortnativelisp := $(filter-out ${shortnativelisp_filter},${shortnativelisp}) ## Place loaddefs.el first, so it gets generated first, since it is on ## 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}) lisp = $(addprefix ${lispsource}/,${shortlisp}) -nativelisp = $(addprefix ${lispsource}/,${shortnativelisp}) ## Construct full set of libraries to be linked. LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ @@ -583,7 +572,7 @@ ${lispintdir}/characters.elc: ${charscript:.el=.elc} ## since not all pieces are used on all platforms. But DOC depends ## on all of $lisp, and emacs depends on DOC, so it is ok to use $lisp here. emacs$(EXEEXT): temacs$(EXEEXT) \ - lisp.mk native_lisp.mk $(etc)/DOC $(lisp) $(nativelisp) \ + lisp.mk $(etc)/DOC $(lisp) \ $(lispsource)/international/charprop.el ${charsets} ifeq ($(DUMPING),unexec) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=dump @@ -733,7 +722,7 @@ bootstrap-clean: clean fi distclean: bootstrap-clean - rm -f Makefile lisp.mk native_lisp.mk + rm -f Makefile lisp.mk rm -fr $(DEPDIR) maintainer-clean: distclean @@ -801,7 +790,7 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS THEFILE=$< $ Date: Sat, 28 Dec 2019 13:51:46 +0100 Subject: [PATCH 0684/1452] disable propagation when non locals are present --- lisp/emacs-lisp/comp.el | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9272bcc0021..f63e5842bc5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1609,13 +1609,15 @@ Return t if something was changed." (defun comp-propagate (_) (when (>= comp-speed 2) (maphash (lambda (_ f) - (let ((comp-func f)) - (comp-basic-const-propagate) - (cl-loop - for i from 1 - while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-log-func comp-func 3))) + ;; FIXME remove the following condition when tested. + (unless (comp-func-has-non-local f) + (let ((comp-func f)) + (comp-basic-const-propagate) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -1780,13 +1782,15 @@ These are substituted with a normal 'set' op." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (cl-loop - for i from 1 - while (comp-dead-assignments-func) - finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3)) - (comp-remove-type-hints-func) - (comp-log-func comp-func 3))) + ;; FIXME remove the following condition when tested. + (unless (comp-func-has-non-local comp-func) + (cl-loop + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)) + (comp-remove-type-hints-func) + (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) From 976b7fcc8ced57fa12a0504899974b5b2057c943 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Dec 2019 19:16:53 +0100 Subject: [PATCH 0685/1452] fix aliased function names trampoline removal --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f63e5842bc5..da1d3f160f0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1657,7 +1657,8 @@ Return t if something was changed." (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. - (let* ((maxarg (cdr (subr-arity f))) + (let* ((callee (intern (subr-name f))) ; Fix aliased names. + (maxarg (cdr (subr-arity f))) (call-type (if (if subrp (not (numberp maxarg)) (comp-nargs-p callee-in-unit)) From 6c77a9e046de682aaace72aaf3af78e6ba9e5489 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Dec 2019 20:12:17 +0100 Subject: [PATCH 0686/1452] do not crash compilation trying to optimize wrong code --- lisp/emacs-lisp/comp.el | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da1d3f160f0..039cd6cd411 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -450,7 +450,8 @@ Put PREFIX in front of it." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) - (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. when (and (byte-to-native-function-p x) @@ -1551,10 +1552,15 @@ This can run just once." "Given INSN when F is pure if all ARGS are known remove the function call." (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el (cl-every #'comp-mvar-const-vld args)) - (let ((val (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-set-const'. - (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs val) val))))) + (condition-case err + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. + (setf (car insn) 'setimm + (cddr insn) (list (comp-add-const-to-relocs val) val))) + ;; FIXME Should we crash? At least we should complain once. + (t (message "Native compiler trying to move run-time error into \ +compile-time? %S calling %S inside function %S." err f +(comp-func-name comp-func)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." From b18f92a942dca6f95c9a74835644e482f3b1b907 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 31 Dec 2019 00:20:35 +0100 Subject: [PATCH 0687/1452] rework predicates to be homogeneous --- lisp/emacs-lisp/comp.el | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 039cd6cd411..de3b28e438c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -296,22 +296,21 @@ structure.") -(defun comp-set-op-p (op) +(defsubst comp-set-op-p (op) "Assignment predicate for OP." - (cl-find op comp-limple-sets)) + (when (member op comp-limple-sets) t)) -(defun comp-assign-op-p (op) +(defsubst comp-assign-op-p (op) "Assignment predicate for OP." - (cl-find op comp-limple-assignments)) + (when (member op comp-limple-assignments) t)) -(defun comp-limple-insn-call-p (insn) +(defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." - (when (member (car-safe insn) comp-limple-calls) - t)) + (when (member (car-safe insn) comp-limple-calls) t)) -(defun comp-type-hint-p (func) +(defsubst comp-type-hint-p (func) "Type hint predicate for function name FUNC." - (member func comp-type-hints)) + (when (member func comp-type-hints) t)) (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. From c4b886831acb82643a38f48c91456b15363bed75 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 31 Dec 2019 00:19:22 +0100 Subject: [PATCH 0688/1452] compile each eln to a temporary one and rename it as last --- src/comp.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 7d4bcc2cdff..c25b3245ca3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3151,15 +3151,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); - - /* Remove the old eln before creating the new one to get a new inode and - prevent crashes in case the old one is currently loaded. */ - if (!NILP (Ffile_exists_p (out_file))) - Fdelete_file (out_file, Qnil); - + Lisp_Object tmp_file = + Fmake_temp_file_internal (ctxtname, Qnil, dot_so, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - SSDATA (out_file)); + SSDATA (tmp_file)); + + /* Remove the old eln instead of copying the new one into ti to get + a new inode and prevent crashes in case the old one is currently + loaded. */ + if (!NILP (Ffile_exists_p (out_file))) + Fdelete_file (out_file, Qnil); + Frename_file (tmp_file, out_file, Qnil); pthread_sigmask (SIG_SETMASK, &oldset, 0); unblock_input (); From 498468a2367524c7bd763826df5aad2b76345912 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 31 Dec 2019 00:37:47 +0100 Subject: [PATCH 0689/1452] make build system configurable again --- configure.ac | 2 +- lisp/Makefile.in | 40 ++++++++++++++++++++++------------------ src/Makefile.in | 1 - 3 files changed, 23 insertions(+), 20 deletions(-) diff --git a/configure.ac b/configure.ac index 03570bd6c90..2afa9572544 100644 --- a/configure.ac +++ b/configure.ac @@ -3760,10 +3760,10 @@ If you are sure you want Emacs compiled without elisp native compiler, pass to configure.]) fi fi +AC_SUBST(HAVE_NATIVE_COMP) AC_SUBST(LIBGCCJIT_LIB) AC_SUBST(COMP_OBJ) - ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no LIBPNG= diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 5bcb85ff141..cfc6f494991 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -32,14 +32,15 @@ XARGS_LIMIT = @XARGS_LIMIT@ # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AM_V_ELN = $(am__v_ELN_@AM_V@) -am__v_ELN_ = $(am__v_ELN_@AM_DEFAULT_V@) -am__v_ELN_0 = @echo " ELC+ELN " $@; -am__v_ELN_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) +ifeq ($(HAVE_NATIVE_COMP),yes) am__v_ELC_0 = @echo " ELC+ELN " $@; +else +am__v_ELC_0 = @echo " ELC " $@; +endif am__v_ELC_1 = AM_V_GEN = $(am__v_GEN_@AM_V@) @@ -103,9 +104,11 @@ 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/comp.elc + $(lisp)/emacs-lisp/bytecomp.elc +ifeq ($(HAVE_NATIVE_COMP),yes) +COMPILE_FIRST += $(lisp)/emacs-lisp/comp.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 \ @@ -280,19 +283,18 @@ TAGS: ${ETAGS} ${tagsfiles} # src/Makefile.in to rebuild a particular Lisp file, no questions asked. # Use byte-compile-refresh-preloaded to try and work around some of # the most common problems of not bootstrapping from a clean state. -# THEFILE = no-such-file -# .PHONY: $(THEFILE)c -# $(THEFILE)c: -# $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -# -l bytecomp -f byte-compile-refresh-preloaded \ -# -f batch-byte-compile $(THEFILE) - THEFILE = no-such-file .PHONY: $(THEFILE)c $(THEFILE)c: - $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) \ +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 @@ -305,12 +307,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 $< - -.el.eln: - $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-native-compile $< +else +.el.elc: + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< +endif .PHONY: compile-first compile-main compile compile-always diff --git a/src/Makefile.in b/src/Makefile.in index cc43cd9f319..6a151d18d02 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -513,7 +513,6 @@ lisp.mk: $(lispsource)/loadup.el sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ echo "" ) > $@ - -include lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) From 3ba1b52e277261286738b637e45a675b7d587f58 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 31 Dec 2019 03:10:13 +0100 Subject: [PATCH 0690/1452] check for libgccjit lib to be reachable in configure.ac --- configure.ac | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/configure.ac b/configure.ac index 2afa9572544..8c8b57c1079 100644 --- a/configure.ac +++ b/configure.ac @@ -3742,14 +3742,11 @@ HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_HEADER([libgccjit.h], [HAVE_NATIVE_COMP=yes]) + AC_CHECK_HEADER(libgccjit.h, + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit)) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" - if test "${HAVE_MODULES}" = yes; then - COMP_OBJ="comp.o" - else - COMP_OBJ="dynlib.o comp.o" - fi + COMP_OBJ+=comp.o AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) From 11192b29adf4ee500f5056d1b02d35908f858b53 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 1 Jan 2020 21:13:13 +0100 Subject: [PATCH 0691/1452] make standard emacs compilable again --- configure.ac | 4 ++-- lisp/Makefile.in | 6 ++++++ src/comp.h | 4 ++-- src/lread.c | 5 +++-- src/pdumper.c | 2 ++ 5 files changed, 15 insertions(+), 6 deletions(-) diff --git a/configure.ac b/configure.ac index 8c8b57c1079..247484a8501 100644 --- a/configure.ac +++ b/configure.ac @@ -3748,8 +3748,6 @@ if test "${with_nativecomp}" != "no"; then LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ+=comp.o AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) - AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", - [System extension for native compiled elisp]) else AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. If you are sure you want Emacs compiled without elisp native compiler, pass @@ -3757,6 +3755,8 @@ If you are sure you want Emacs compiled without elisp native compiler, pass to configure.]) fi fi +AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) AC_SUBST(LIBGCCJIT_LIB) AC_SUBST(COMP_OBJ) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index cfc6f494991..5793b6474dc 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -332,7 +332,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.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! diff --git a/src/comp.h b/src/comp.h index 33b73548009..86fa54f5158 100644 --- a/src/comp.h +++ b/src/comp.h @@ -29,8 +29,6 @@ enum { #endif }; -#ifdef HAVE_NATIVE_COMP - #include struct Lisp_Native_Comp_Unit @@ -43,6 +41,8 @@ struct Lisp_Native_Comp_Unit dynlib_handle_ptr handle; }; +#ifdef HAVE_NATIVE_COMP + INLINE bool NATIVE_COMP_UNITP (Lisp_Object a) { diff --git a/src/lread.c b/src/lread.c index 1c5268d0dad..d6d13861417 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4464,8 +4464,9 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); - if (NATIVE_COMP_FLAG) - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); +#ifdef HAVE_NATIVE_COMP + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); +#endif } #ifdef NOTDEF /* Use fset in subr.el now! */ diff --git a/src/pdumper.c b/src/pdumper.c index 85809c9978f..ae8fe014e0e 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5296,6 +5296,7 @@ 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: { struct Lisp_Native_Comp_Unit *comp_u = @@ -5323,6 +5324,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, subr->function.a0 = func; break; } +#endif case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); From dd66ef5ad198fe914dd603a484e1459dff2af641 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 1 Jan 2020 11:16:59 +0100 Subject: [PATCH 0692/1452] set nativecomp configure option off by default --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 247484a8501..717b4564999 100644 --- a/configure.ac +++ b/configure.ac @@ -463,7 +463,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],[compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) -OPTION_DEFAULT_ON([nativecomp],[don't compile with emacs lisp native compiler support]) +OPTION_DEFAULT_OFF([nativecomp],[don't 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)])], From b0a283872c7bdfb8dbd1af459d0827c07fa72ec2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 1 Jan 2020 12:14:53 +0100 Subject: [PATCH 0693/1452] Revert "Pacify gcc -Wunused-function on Ubuntu 18.04.3" This reverts commit 186152ba400b58d2d278c52d2e3d896decae767e. --- src/xfns.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/xfns.c b/src/xfns.c index b94666d5548..021efafd579 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -4572,8 +4572,6 @@ On MS Windows, this just returns nil. */) return Qnil; } -#ifndef USE_GTK - /* Store the geometry of the workarea on display DPYINFO into *RECT. Return false if and only if the workarea information cannot be obtained via the _NET_WORKAREA root window property. */ @@ -4636,6 +4634,8 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect) return result; } +#ifndef USE_GTK + /* Return monitor number where F is "most" or closest to. */ static int x_get_monitor_for_frame (struct frame *f, From 5252b59b2b3a7959160378cbd0ecb09d9a1da24b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jan 2020 22:02:20 +0100 Subject: [PATCH 0694/1452] Better compile-clean and bootstrap-clean target definition --- lisp/Makefile.in | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 5793b6474dc..fdd39d5fd54 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -365,6 +365,8 @@ compile-clean: if test -f "$$el" || test ! -f "$${el}c"; then :; else \ echo rm "$${el}c"; \ rm "$${el}c"; \ + fi; \ + if test -f "$$el" || test ! -f "$${el}n"; then :; else \ echo rm "$${el}n"; \ rm "$${el}n"; \ fi; \ @@ -485,7 +487,7 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el .PHONY: bootstrap-clean distclean maintainer-clean extraclean bootstrap-clean: - find $(lisp) -name '*.elc' $(FIND_DELETE) + find $(lisp) -regex '.*\.elc\|.*\.eln' $(FIND_DELETE) rm -f $(AUTOGENEL) distclean: From 3039c55642fbb2feb577e057ee167c2cedc12feb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jan 2020 22:14:25 +0100 Subject: [PATCH 0695/1452] Do not block sw interrupts in batch mode (don't ignore C-c) --- src/comp.c | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index c25b3245ca3..bb8b952cf52 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3110,16 +3110,19 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); - /* Gcc doesn't like being interrupted at all. */ - block_input (); sigset_t oldset; - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - sigaddset (&blocked, SIGIO); - pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + if (!noninteractive) + { + sigset_t blocked; + /* Gcc doesn't like being interrupted at all. */ + block_input (); + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + } emit_ctxt_code (); /* Define inline functions. */ @@ -3164,8 +3167,11 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Fdelete_file (out_file, Qnil); Frename_file (tmp_file, out_file, Qnil); - pthread_sigmask (SIG_SETMASK, &oldset, 0); - unblock_input (); + if (!noninteractive) + { + pthread_sigmask (SIG_SETMASK, &oldset, 0); + unblock_input (); + } return out_file; } From 25332bb0d396b79b37e6eaf96850ac560eaa55cd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jan 2020 22:35:34 +0100 Subject: [PATCH 0696/1452] Fix bytecomp message when native compiling --- lisp/emacs-lisp/bytecomp.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 19d9884c3fc..9278c92d819 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2035,10 +2035,12 @@ The value is non-nil if there were no errors, nil if errors." ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. (if (and byte-native-compiling - (not byte-native-always-write-elc)) + (null byte-native-always-write-elc)) (delete-file tempfile) (rename-file tempfile target-file t))) - (or noninteractive (message "Wrote %s" target-file))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (let ((exists (file-exists-p target-file))) (signal (if exists 'file-error 'file-missing) From 2239cc81b72e0c066d83271f5c9b4d8097b1ce0d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jan 2020 22:55:38 +0100 Subject: [PATCH 0697/1452] Extend find-library-suffixes and find-library-name for eln support --- lisp/emacs-lisp/find-func.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 167ead3ce02..86b5e5456f0 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -167,7 +167,8 @@ See the functions `find-function' and `find-variable'." (defun find-library-suffixes () (let ((suffixes nil)) (dolist (suffix (get-load-suffixes) (nreverse suffixes)) - (unless (string-match "elc" suffix) (push suffix suffixes))))) + (unless (string-match "el[cn]" suffix) + (push suffix suffixes))))) (defun find-library--load-name (library) (let ((name library)) @@ -183,7 +184,7 @@ See the functions `find-function' and `find-variable'." 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) + (when (string-match "\\.el\\([cn]\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) (or (locate-file library From 5a228fefb6f1d1932f452693ded660cd903f457d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 1 Jan 2020 22:02:49 +0100 Subject: [PATCH 0698/1452] Prevent false warning emission --- lisp/emacs-lisp/comp.el | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index de3b28e438c..77d47bde8a8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1551,15 +1551,15 @@ This can run just once." "Given INSN when F is pure if all ARGS are known remove the function call." (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el (cl-every #'comp-mvar-const-vld args)) - (condition-case err - (let ((val (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-set-const'. - (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs val) val))) - ;; FIXME Should we crash? At least we should complain once. - (t (message "Native compiler trying to move run-time error into \ -compile-time? %S calling %S inside function %S." err f -(comp-func-name comp-func)))))) + (ignore-errors + ;; No point to complain here because we should do basic block + ;; pruning in order to be sure that this is not dead-code. This + ;; is now left to gcc, to be implemented only if we want a + ;; reliable diagnostic here. + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. + (setf (car insn) 'setimm + (cddr insn) (list (comp-add-const-to-relocs val) val)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." From a59cc78fcb8df8acbf5139c2b4d2fada55627248 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 3 Jan 2020 02:49:01 +0100 Subject: [PATCH 0699/1452] Simplify configure.ac removing unnecessary empty parameters --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 717b4564999..9c8a6e3a9fc 100644 --- a/configure.ac +++ b/configure.ac @@ -3743,7 +3743,7 @@ LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then AC_CHECK_HEADER(libgccjit.h, - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit)) + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes)) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ+=comp.o From 93ed2c32dfd2e385ab0b75e9cbc0768c29b15b50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 11 Jan 2020 09:50:34 +0100 Subject: [PATCH 0700/1452] Move function reloc data into pure space during bootstrap --- lisp/emacs-lisp/comp.el | 29 +++++++++++++++++------------ src/comp.c | 37 ++++++++++++++++++++++++------------- 2 files changed, 41 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 77d47bde8a8..0f71746407a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -167,7 +167,7 @@ Can be used by code that wants to expand differently in this case.") :documentation "lisp-func-name -> comp-func. This is to build the prev field.") (data-relocs-l () :type list - :documentation "Constant objects used by functions.") + :documentation "List of pairs (impure . obj-to-reloc).") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into data-relocs.")) @@ -288,8 +288,10 @@ structure.") :documentation "When non nil indicates the type when known at compile time.") (ref nil :type boolean - :documentation "When t the m-var is involved in a call where is passed by - reference.")) + :documentation "When non nil the m-var is involved in a + call where is passed by reference.") + (impure nil :type boolean + :documentation "When non nil can't be copied into pure space.")) ;; Special vars used by some passes (defvar comp-func) @@ -312,14 +314,16 @@ structure.") "Type hint predicate for function name FUNC." (when (member func comp-type-hints) t)) -(defun comp-add-const-to-relocs (obj) +(defun comp-add-const-to-relocs (obj &optional impure) "Keep track of OBJ into the ctxt relocations. +When IMPURE is non nil OBJ cannot be copied into pure space. The corresponding index is returned." - (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) - (if-let ((idx (gethash obj data-relocs-idx))) + (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt)) + (packed-obj (cons impure obj))) + (if-let ((idx (gethash packed-obj data-relocs-idx))) idx - (push obj (comp-ctxt-data-relocs-l comp-ctxt)) - (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + (push packed-obj (comp-ctxt-data-relocs-l comp-ctxt)) + (puthash packed-obj (hash-table-count data-relocs-idx) data-relocs-idx)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -584,11 +588,12 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type + impure) (when const-vld - (comp-add-const-to-relocs constant)) + (comp-add-const-to-relocs constant impure)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type)) + :type type :impure impure)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1099,7 +1104,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) (comp-emit (comp-call 'eval - (make-comp-mvar :constant form) + (make-comp-mvar :constant form :impure t) (make-comp-mvar :constant t))))) (defun comp-limplify-top-level () diff --git a/src/comp.c b/src/comp.c index bb8b952cf52..0d1f83eb8ff 100644 --- a/src/comp.c +++ b/src/comp.c @@ -883,7 +883,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj) +emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -895,11 +895,13 @@ emit_const_lisp_obj (Lisp_Object obj) NULL)); Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); - ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); + Lisp_Object packed_obj = Fcons (impure, obj); + Lisp_Object reloc_idx = Fgethash (packed_obj, d_reloc_idx, Qnil); + eassert (!NILP (reloc_idx)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, - reloc_fixn); + XFIXNUM (reloc_idx)); return gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, @@ -912,7 +914,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil)); + return emit_EQ (x, emit_const_lisp_obj (Qnil, Qnil)); } static gcc_jit_rvalue * @@ -1015,7 +1017,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp), + emit_const_lisp_obj (Qconsp, Qnil), x }; gcc_jit_block_add_eval ( @@ -1126,7 +1128,7 @@ emit_mvar_val (Lisp_Object mvar) return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant); + return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar)); } return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); @@ -1161,7 +1163,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil); + gcc_args[2] = emit_const_lisp_obj (Qnil, Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -2360,11 +2362,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_const_lisp_obj (Qnil, Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp), c }; + { emit_const_lisp_obj (Qlistp, Qnil), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2373,7 +2375,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_const_lisp_obj (Qnil, Qnil)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2753,12 +2755,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt)); + emit_const_lisp_obj (Qt, Qnil)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil)); + emit_const_lisp_obj (Qnil, Qnil)); } @@ -3285,8 +3287,17 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + if (!loading_dump && !NILP (Vpurify_flag)) + for (EMACS_INT i = 0; i < d_vec_len; i++) + { + Lisp_Object packed_obj = AREF (comp_u->data_vec, i); + if (NILP (XCAR (packed_obj))) + /* If is not impure can be copied into pure space. */ + XSETCDR (packed_obj, Fpurecopy (XCDR (packed_obj))); + } + for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (comp_u->data_vec, i); + data_relocs[i] = XCDR (AREF (comp_u->data_vec, i)); if (!loading_dump) { From c1d034fc27e3aef2370cf0153e7b54dac7eba91b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Jan 2020 11:47:50 +0100 Subject: [PATCH 0701/1452] Split relocated data into two separate arrays Rework the functionality of the previous commit to be more efficient. --- lisp/emacs-lisp/comp.el | 44 +++++++++++----- src/comp.c | 110 +++++++++++++++++++++++++--------------- src/comp.h | 3 ++ src/lisp.h | 4 +- 4 files changed, 107 insertions(+), 54 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0f71746407a..69141f657a6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -157,6 +157,13 @@ Can be used by code that wants to expand differently in this case.") finally return h) "Hash table lap-op -> stack adjustment.")) +(cl-defstruct comp-data-container + "Data relocation container structure." + (l () :type list + :documentation "Constant objects used by functions.") + (idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into the previous field.")) + (cl-defstruct comp-ctxt "Lisp side of the compiler context." (output nil :type string @@ -166,10 +173,11 @@ Can be used by code that wants to expand differently in this case.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") - (data-relocs-l () :type list - :documentation "List of pairs (impure . obj-to-reloc).") - (data-relocs-idx (make-hash-table :test #'equal) :type hash-table - :documentation "Obj -> position into data-relocs.")) + (d-base (make-comp-data-container) :type comp-data-container + :documentation "Standard data relocated in use by functions.") + (d-impure (make-comp-data-container) :type comp-data-container + :documentation "Data relocated that cannot be moved into pure space. +This is tipically for top-level forms other than defun.")) (cl-defstruct comp-args-base (min nil :type number @@ -314,16 +322,28 @@ structure.") "Type hint predicate for function name FUNC." (when (member func comp-type-hints) t)) +(defun comp-data-container-check (cont) + "Sanity check CONT coherency." + (cl-assert (= (length (comp-data-container-l cont)) + (hash-table-count (comp-data-container-idx cont))))) + +(defun comp-add-const-to-relocs-to-cont (obj cont) + "Keep track of OBJ into the CONT relocation container. +The corresponding index is returned." + (let ((h (comp-data-container-idx cont))) + (if-let ((idx (gethash obj h))) + idx + (push obj (comp-data-container-l cont)) + (puthash obj (hash-table-count h) h)))) + (defun comp-add-const-to-relocs (obj &optional impure) "Keep track of OBJ into the ctxt relocations. When IMPURE is non nil OBJ cannot be copied into pure space. The corresponding index is returned." - (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt)) - (packed-obj (cons impure obj))) - (if-let ((idx (gethash packed-obj data-relocs-idx))) - idx - (push packed-obj (comp-ctxt-data-relocs-l comp-ctxt)) - (puthash packed-obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + (comp-add-const-to-relocs-to-cont obj + (if impure + (comp-ctxt-d-impure comp-ctxt) + (comp-ctxt-d-base comp-ctxt)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -1810,8 +1830,8 @@ These are substituted with a normal 'set' op." (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) - (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) + (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) (comp--compile-ctxt-to-file name)) (defun comp-final (_) diff --git a/src/comp.c b/src/comp.c index 0d1f83eb8ff..290fc3a9c45 100644 --- a/src/comp.c +++ b/src/comp.c @@ -39,9 +39,11 @@ along with GNU Emacs. If not, see . */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" +#define DATA_RELOC_IMPURE_SYM "d_reloc_imp" #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" #define TEXT_DATA_RELOC_SYM "text_data_reloc" +#define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -171,8 +173,12 @@ typedef struct { Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; - gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ - gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ + /* Synthesized struct holding data relocs. */ + gcc_jit_rvalue *data_relocs; + /* Same as before but can't go in pure space. */ + gcc_jit_rvalue *data_relocs_impure; + /* Synthesized struct holding func relocs. */ + gcc_jit_lvalue *func_relocs; } comp_t; static comp_t comp; @@ -894,9 +900,10 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) comp.void_ptr_type, NULL)); - Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); - Lisp_Object packed_obj = Fcons (impure, obj); - Lisp_Object reloc_idx = Fgethash (packed_obj, d_reloc_idx, Qnil); + Lisp_Object container = impure ? CALL1I (comp-ctxt-d-impure, Vcomp_ctxt) + : CALL1I (comp-ctxt-d-base, Vcomp_ctxt); + Lisp_Object reloc_idx = + Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil); eassert (!NILP (reloc_idx)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -906,7 +913,8 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - comp.data_relocs, + impure ? comp.data_relocs_impure + : comp.data_relocs, reloc_n)); } @@ -1749,14 +1757,52 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_block_end_with_return (block, NULL, res); } +static gcc_jit_rvalue * +declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, + const char *text_symbol) +{ + /* Imported objects. */ + EMACS_INT d_reloc_len = + XFIXNUM (CALL1I (hash-table-count, + CALL1I (comp-data-container-idx, container))); + Lisp_Object d_reloc = Fnreverse (CALL1I (comp-data-container-l, container)); + d_reloc = Fvconcat (1, &d_reloc); + + gcc_jit_rvalue *reloc_struct = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + code_symbol)); + + emit_static_object (text_symbol, d_reloc); + + return reloc_struct; +} + static void -declare_runtime_imported_data (void) +declare_imported_data (void) { /* Imported symbols by inliner functions. */ CALL1I (comp-add-const-to-relocs, Qnil); CALL1I (comp-add-const-to-relocs, Qt); CALL1I (comp-add-const-to-relocs, Qconsp); CALL1I (comp-add-const-to-relocs, Qlistp); + + /* Imported objects. */ + comp.data_relocs = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-base, Vcomp_ctxt), + DATA_RELOC_SYM, + TEXT_DATA_RELOC_SYM); + comp.data_relocs_impure = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt), + DATA_RELOC_IMPURE_SYM, + TEXT_DATA_RELOC_IMPURE_SYM); } /* @@ -1842,27 +1888,7 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.void_ptr_type), PURE_RELOC_SYM)); - declare_runtime_imported_data (); - /* Imported objects. */ - EMACS_INT d_reloc_len = - XFIXNUM (CALL1I (hash-table-count, - CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - Lisp_Object d_reloc = Fnreverse (CALL1I (comp-ctxt-data-relocs-l, Vcomp_ctxt)); - d_reloc = Fvconcat (1, &d_reloc); - - comp.data_relocs = - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - d_reloc_len), - DATA_RELOC_SYM)); - - emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); + declare_imported_data (); /* Functions imported from Lisp code. */ freloc_check_fill (); @@ -3263,12 +3289,14 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc && pure_reloc && data_relocs + && data_imp_relocs && freloc_link_table && top_level_run) || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), @@ -3283,21 +3311,23 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) /* Imported data. */ if (!loading_dump) - comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + { + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + comp_u->data_impure_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + + if (!NILP (Vpurify_flag)) + /* Non impure can be copied into pure space. */ + comp_u->data_vec = Fpurecopy (comp_u->data_vec); + } EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); - - if (!loading_dump && !NILP (Vpurify_flag)) - for (EMACS_INT i = 0; i < d_vec_len; i++) - { - Lisp_Object packed_obj = AREF (comp_u->data_vec, i); - if (NILP (XCAR (packed_obj))) - /* If is not impure can be copied into pure space. */ - XSETCDR (packed_obj, Fpurecopy (XCDR (packed_obj))); - } - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = XCDR (AREF (comp_u->data_vec, i)); + data_relocs[i] = AREF (comp_u->data_vec, i); + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); if (!loading_dump) { diff --git a/src/comp.h b/src/comp.h index 86fa54f5158..ddebbbcccf0 100644 --- a/src/comp.h +++ b/src/comp.h @@ -38,6 +38,9 @@ struct Lisp_Native_Comp_Unit Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; + /* Same but for data that cannot be moved to pure space. + Must be the last lisp object here. */ + Lisp_Object data_impure_vec; dynlib_handle_ptr handle; }; diff --git a/src/lisp.h b/src/lisp.h index 2d083dc4582..04489959ed8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4767,8 +4767,8 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { - return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, - PVEC_NATIVE_COMP_UNIT); + return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, + data_impure_vec, PVEC_NATIVE_COMP_UNIT); } #else INLINE bool From e83bc2503b6639542e85a859f88642bde3411bf5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 20 Jan 2020 21:57:11 +0000 Subject: [PATCH 0702/1452] Always force debug 0 for bootstrap test Debug symbols would make it fail otherwise. --- test/src/comp-tests.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 82a30424d09..d71dad6dd59 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -48,7 +48,9 @@ Check that the resulting binaries do not differ." (comp1-src (make-temp-file "stage1-" nil ".el")) (comp2-src (make-temp-file "stage2-" nil ".el")) (comp1 (concat comp1-src "n")) - (comp2 (concat comp2-src "n"))) + (comp2 (concat comp2-src "n")) + ;; Can't use debug symbols. + (comp-debug 0)) (copy-file comp-src comp1-src t) (copy-file comp-src comp2-src t) (load (concat comp-src "c") nil nil t t) From a0c6ee6fc5725dab42aba662d46e46c213c8018a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 20 Jan 2020 21:59:40 +0000 Subject: [PATCH 0703/1452] Do no force speed while running the testsuite --- test/src/comp-tests.el | 3 --- 1 file changed, 3 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d71dad6dd59..bd844a90c3c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,9 +29,6 @@ (require 'cl-lib) (require 'comp) -;; (setq comp-debug 1) -(setq comp-speed 0) - (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) (defconst comp-test-src From fce1333c22d07c6b359f084b74316458f4187dc4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 20 Jan 2020 19:30:24 +0000 Subject: [PATCH 0704/1452] Clean-up unnecessary member usage --- lisp/emacs-lisp/comp.el | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 69141f657a6..550fa7ddf2e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -308,19 +308,19 @@ structure.") (defsubst comp-set-op-p (op) "Assignment predicate for OP." - (when (member op comp-limple-sets) t)) + (when (memq op comp-limple-sets) t)) (defsubst comp-assign-op-p (op) "Assignment predicate for OP." - (when (member op comp-limple-assignments) t)) + (when (memq op comp-limple-assignments) t)) (defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." - (when (member (car-safe insn) comp-limple-calls) t)) + (when (memq (car-safe insn) comp-limple-calls) t)) (defsubst comp-type-hint-p (func) "Type hint predicate for function name FUNC." - (when (member func comp-type-hints) t)) + (when (memq func comp-type-hints) t)) (defun comp-data-container-check (cont) "Sanity check CONT coherency." @@ -531,12 +531,12 @@ Points to the next slot to be filled.") (defsubst comp-lap-eob-p (inst) "Return t if INST closes the current basic blocks, nil otherwise." - (when (member (car inst) comp-lap-eob-ops) + (when (memq (car inst) comp-lap-eob-ops) t)) (defsubst comp-lap-fall-through-p (inst) "Return t if INST fall through, nil otherwise." - (when (not (member (car inst) '(byte-goto byte-return))) + (when (not (memq (car inst) '(byte-goto byte-return))) t)) (defsubst comp-sp () @@ -1679,7 +1679,7 @@ Return t if something was changed." args) args)) (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. - (not (member callee comp-never-optimize-functions))) + (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) (callee-in-unit (gethash callee @@ -1788,7 +1788,7 @@ Return the list of m-var ids nuked." for insn = (car insn-cell) for (op arg0 rest) = insn when (and (comp-set-op-p op) - (member (comp-mvar-id arg0) nuke-list)) + (memq (comp-mvar-id arg0) nuke-list)) do (setcar insn-cell (if (comp-limple-insn-call-p rest) rest From 9e08edf98fdf1a2547eef7b5d9d3debdddb6e7c6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 20 Jan 2020 21:16:10 +0000 Subject: [PATCH 0705/1452] Extend propagation to a wider set of (non pure) functions --- lisp/emacs-lisp/comp.el | 34 ++++++++++++++++++++++++++++++---- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 550fa7ddf2e..4ec84563f38 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1529,6 +1529,17 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. +(defvar comp-propagate-classes '(byte-optimize-associative-math + byte-optimize-binary-predicate + byte-optimize-concat + byte-optimize-equal + byte-optimize-identity + byte-optimize-member + byte-optimize-memq + byte-optimize-predicate) + "We optimize functions with 'byte-optimizer' property set to + one of these symbols. See byte-opt.el.") + (defsubst comp-strict-type-of (obj) "Given OBJ return its type understanding fixnums." ;; Should be certainly smarter but now we take advantages just from fixnums. @@ -1572,19 +1583,34 @@ This can run just once." (comp-mvar-constant lval) (comp-mvar-constant rval) (comp-mvar-type lval) (comp-mvar-type rval))) +;; Here should fall most of (defun byte-optimize-* equivalents. +(defsubst comp-function-optimizable (f args) + "Given function F called with ARGS return non nil when optimizable." + (when (cl-every #'comp-mvar-const-vld args) + (or (get f 'pure) + (memq (get f 'byte-optimizer) comp-propagate-classes) + (let ((values (mapcar #'comp-mvar-constant args))) + (pcase f + ;; Simple integer operation. + ;; Note: byte-opt uses `byte-opt--portable-numberp' + ;; instead of just`fixnump'. + ((or '+ '- '* '1+ '-1) (and (cl-every #'fixnump values) + (fixnump (apply f values)))) + ('/ (and (cl-every #'fixnump values) + (not (= (car (last values)) 0))))))))) + (defsubst comp-function-call-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." - (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el - (cl-every #'comp-mvar-const-vld args)) + (when (comp-function-optimizable f args) (ignore-errors ;; No point to complain here because we should do basic block ;; pruning in order to be sure that this is not dead-code. This ;; is now left to gcc, to be implemented only if we want a ;; reliable diagnostic here. - (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + (let ((values (apply f (mapcar #'comp-mvar-constant args)))) ;; See `comp-emit-set-const'. (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs val) val)))))) + (cddr insn) (list (comp-add-const-to-relocs values) values)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." From 6696b561d4d37aebdbb42833d8b5a8d1f4e14482 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Sun, 2 Feb 2020 15:39:29 +0000 Subject: [PATCH 0706/1452] Fix load_comp_unit for non zero speeds 'dlopen' returns the same handle when trying to load two times the same shared. Touching 'd_reloc' etc leads to fails in case a frame with a reference to it in a register is active. (comp-speed >= 0) --- src/alloc.c | 19 +++++++++ src/comp.c | 116 ++++++++++++++++++++++++++++++-------------------- src/pdumper.c | 1 + 3 files changed, 90 insertions(+), 46 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index faa8e703937..431238b13e6 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -517,6 +517,14 @@ Lisp_Object const *staticvec[NSTATICS] int staticidx; +/* Lisp of freed native compilation unit handles. + + Because during GC Vcomp_loaded_handles can't be used (hash table) temporary + annotate here and update Vcomp_loaded_handles when finished. +*/ + +static Lisp_Object freed_cu_handles[NATIVE_COMP_FLAG]; + static void *pure_alloc (size_t, int); /* Return PTR rounded up to the next multiple of ALIGNMENT. */ @@ -3030,6 +3038,10 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); + /* We'll update Vcomp_loaded_handles when finished. */ + freed_cu_handles[0] = + Fcons (make_mint_ptr (cu->handle), freed_cu_handles[0]); + set_cons_marked (XCONS (freed_cu_handles[0])); } } @@ -5937,6 +5949,9 @@ garbage_collect (void) if (garbage_collection_messages) message1_nolog ("Garbage collecting..."); + if (NATIVE_COMP_FLAG) + freed_cu_handles[0] = Qnil; + block_input (); shrink_regexp_cache (); @@ -6001,6 +6016,10 @@ garbage_collect (void) gc_in_progress = 0; + if (NATIVE_COMP_FLAG) + FOR_EACH_TAIL (freed_cu_handles[0]) + Fputhash (XCAR (freed_cu_handles[0]), Qnil, Vcomp_loaded_handles); + unblock_input (); consing_until_gc = gc_threshold diff --git a/src/comp.c b/src/comp.c index 290fc3a9c45..7a1ccdcb83c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3282,61 +3282,81 @@ load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { + dynlib_handle_ptr handle = comp_u->handle; + Lisp_Object lisp_handle = make_mint_ptr (handle); + bool reloading_cu = !NILP (Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil)); + Lisp_Object comp_u_obj; + XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + + if (reloading_cu) + /* 'dlopen' returns the same handle when trying to load two times + the same shared. In this case touching 'd_reloc' etc leads to + fails in case a frame with a reference to it in a live reg is + active (comp-speed >= 0). + + We must *never* mess with static pointers in an already loaded + eln. */ + { + comp_u_obj = Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil); + comp_u = XNATIVE_COMP_UNIT (comp_u_obj); + } + else + Fputhash (lisp_handle, comp_u_obj, Vcomp_loaded_handles); + freloc_check_fill (); - dynlib_handle_ptr handle = comp_u->handle; - struct thread_state ***current_thread_reloc = - dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); - Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); - void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); - if (!(current_thread_reloc - && pure_reloc - && data_relocs - && data_imp_relocs - && freloc_link_table - && top_level_run) - || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), - hash_subr_list ()))) - xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - - *current_thread_reloc = ¤t_thread; - *pure_reloc = (EMACS_INT **)&pure; - - /* Imported functions. */ - *freloc_link_table = freloc.link_table; - - /* Imported data. */ - if (!loading_dump) + if (!reloading_cu) { - comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); - comp_u->data_impure_vec = - load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); - if (!NILP (Vpurify_flag)) - /* Non impure can be copied into pure space. */ - comp_u->data_vec = Fpurecopy (comp_u->data_vec); + if (!(current_thread_reloc + && pure_reloc + && data_relocs + && data_imp_relocs + && freloc_link_table + && top_level_run) + || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), + hash_subr_list ()))) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + + *current_thread_reloc = ¤t_thread; + *pure_reloc = (EMACS_INT **)&pure; + + /* Imported functions. */ + *freloc_link_table = freloc.link_table; + + /* Imported data. */ + if (!loading_dump) + { + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + comp_u->data_impure_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + + if (!NILP (Vpurify_flag)) + /* Non impure can be copied into pure space. */ + comp_u->data_vec = Fpurecopy (comp_u->data_vec); + } + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); } - EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (comp_u->data_vec, i); - - d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); - if (!loading_dump) - { - Lisp_Object comp_u_obj; - XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); - /* Executing this will perform all the expected environment - modifications. */ - top_level_run (comp_u_obj); - } + /* Executing this will perform all the expected environment + modifications. */ + top_level_run (comp_u_obj); return; } @@ -3518,6 +3538,10 @@ syms_of_comp (void) doc: /* Hash table symbol-function -> function-c-name. For internal use during */); Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + DEFVAR_LISP ("comp-loaded-handles", Vcomp_loaded_handles, + doc: /* Hash table keeping track of the currently + loaded compilation unit: handle -> comp_u */); + Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/pdumper.c b/src/pdumper.c index ae8fe014e0e..8a758499a91 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5577,6 +5577,7 @@ pdumper_load (const char *dump_filename) dump_hooks[i] (); dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); + Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; From ffa59bb1611609879151b6dfa94772f9e2144849 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 2 Feb 2020 22:24:03 +0100 Subject: [PATCH 0707/1452] Always define subr-native-elisp-p also without native compiler --- src/data.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data.c b/src/data.c index 8901ffbb2c3..b7337b19bc6 100644 --- a/src/data.c +++ b/src/data.c @@ -866,7 +866,6 @@ SUBR must be a built-in function. */) return build_string (name); } -#ifdef HAVE_NATIVE_COMP 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. */) @@ -875,6 +874,7 @@ nil otherwise. */) return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } +#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. */) From 7c93bb113ec353baa6316fa97744e65a6e109d91 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 3 Feb 2020 16:40:45 +0000 Subject: [PATCH 0708/1452] Rework load mechanism to make Vcomp_loaded_handles unnecessary --- src/alloc.c | 19 ------------------- src/comp.c | 30 +++++++++++++++++++----------- src/pdumper.c | 1 - 3 files changed, 19 insertions(+), 31 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 431238b13e6..faa8e703937 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -517,14 +517,6 @@ Lisp_Object const *staticvec[NSTATICS] int staticidx; -/* Lisp of freed native compilation unit handles. - - Because during GC Vcomp_loaded_handles can't be used (hash table) temporary - annotate here and update Vcomp_loaded_handles when finished. -*/ - -static Lisp_Object freed_cu_handles[NATIVE_COMP_FLAG]; - static void *pure_alloc (size_t, int); /* Return PTR rounded up to the next multiple of ALIGNMENT. */ @@ -3038,10 +3030,6 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); - /* We'll update Vcomp_loaded_handles when finished. */ - freed_cu_handles[0] = - Fcons (make_mint_ptr (cu->handle), freed_cu_handles[0]); - set_cons_marked (XCONS (freed_cu_handles[0])); } } @@ -5949,9 +5937,6 @@ garbage_collect (void) if (garbage_collection_messages) message1_nolog ("Garbage collecting..."); - if (NATIVE_COMP_FLAG) - freed_cu_handles[0] = Qnil; - block_input (); shrink_regexp_cache (); @@ -6016,10 +6001,6 @@ garbage_collect (void) gc_in_progress = 0; - if (NATIVE_COMP_FLAG) - FOR_EACH_TAIL (freed_cu_handles[0]) - Fputhash (XCAR (freed_cu_handles[0]), Qnil, Vcomp_loaded_handles); - unblock_input (); consing_until_gc = gc_threshold diff --git a/src/comp.c b/src/comp.c index 7a1ccdcb83c..ebe7b8b9a9a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -42,6 +42,7 @@ along with GNU Emacs. If not, see . */ #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" +#define COMP_UNIT_SYM "comp_unit" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" @@ -1888,6 +1889,13 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.void_ptr_type), PURE_RELOC_SYM)); + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), + COMP_UNIT_SYM); + declare_imported_data (); /* Functions imported from Lisp code. */ @@ -3284,9 +3292,13 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { dynlib_handle_ptr handle = comp_u->handle; Lisp_Object lisp_handle = make_mint_ptr (handle); - bool reloading_cu = !NILP (Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil)); - Lisp_Object comp_u_obj; - XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + Lisp_Object comp_u_lisp_obj; + XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); + + Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); + if (!saved_cu) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + bool reloading_cu = *saved_cu ? true : false; if (reloading_cu) /* 'dlopen' returns the same handle when trying to load two times @@ -3297,11 +3309,11 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) We must *never* mess with static pointers in an already loaded eln. */ { - comp_u_obj = Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil); - comp_u = XNATIVE_COMP_UNIT (comp_u_obj); + comp_u_lisp_obj = *saved_cu; + comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj); } else - Fputhash (lisp_handle, comp_u_obj, Vcomp_loaded_handles); + *saved_cu = comp_u_lisp_obj; freloc_check_fill (); @@ -3356,7 +3368,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) if (!loading_dump) /* Executing this will perform all the expected environment modifications. */ - top_level_run (comp_u_obj); + top_level_run (comp_u_lisp_obj); return; } @@ -3538,10 +3550,6 @@ syms_of_comp (void) doc: /* Hash table symbol-function -> function-c-name. For internal use during */); Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); - DEFVAR_LISP ("comp-loaded-handles", Vcomp_loaded_handles, - doc: /* Hash table keeping track of the currently - loaded compilation unit: handle -> comp_u */); - Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/pdumper.c b/src/pdumper.c index 8a758499a91..ae8fe014e0e 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5577,7 +5577,6 @@ pdumper_load (const char *dump_filename) dump_hooks[i] (); dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); - Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; From ea56b58098d78b242bc0c51cf1d8b1d21962c130 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 3 Feb 2020 21:12:03 +0000 Subject: [PATCH 0709/1452] Add assertion in load_comp_unit While resurrecting from an image dump loading more than once the same compilation unit does not make any sense. --- src/comp.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/comp.c b/src/comp.c index ebe7b8b9a9a..03b320bf5f4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3300,6 +3300,10 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); bool reloading_cu = *saved_cu ? true : false; + /* While resurrecting from an image dump loading more than once the + same compilation unit does not make any sense. */ + eassert (!(loading_dump && reloading_cu)); + if (reloading_cu) /* 'dlopen' returns the same handle when trying to load two times the same shared. In this case touching 'd_reloc' etc leads to From d71801ea34b0607edd02d65e2b3150ecd7c2e8fc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 6 Feb 2020 22:57:58 +0100 Subject: [PATCH 0710/1452] Clean-up unused variable into load_comp_unit --- src/comp.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 03b320bf5f4..4b1ddeda0f4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3291,7 +3291,6 @@ void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { dynlib_handle_ptr handle = comp_u->handle; - Lisp_Object lisp_handle = make_mint_ptr (handle); Lisp_Object comp_u_lisp_obj; XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); From fe9e4c42b3e4519032c7c9ee62400f9793ab4f76 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 9 Feb 2020 15:12:51 +0100 Subject: [PATCH 0711/1452] Better function naming for comp-function-call-maybe-remove --- lisp/emacs-lisp/comp.el | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4ec84563f38..2d609f0527c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1599,7 +1599,7 @@ This can run just once." ('/ (and (cl-every #'fixnump values) (not (= (car (last values)) 0))))))))) -(defsubst comp-function-call-remove (insn f args) +(defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." (when (comp-function-optimizable f args) (ignore-errors @@ -1620,13 +1620,11 @@ This can run just once." (`(,(or 'call 'direct-call) ,f . ,args) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-remove insn f args)) + (comp-function-call-maybe-remove insn f args)) (`(,(or 'callref 'direct-callref) ,f . ,args) - (cl-loop for v in args - do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-remove insn f args)) + (comp-function-call-maybe-remove insn f args)) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) From 0c6f4caeb32b2bf531079feb5a9e73b79496b99d Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Fri, 14 Feb 2020 14:32:47 +0000 Subject: [PATCH 0712/1452] Clean-up old gc disable refuse in comp-tests-non-locals --- test/src/comp-tests.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index bd844a90c3c..15a39c4e883 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -258,16 +258,15 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-non-locals () "Test non locals." - (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! - (should (string= (comp-tests-condition-case-0-f) - "arith-error Arithmetic error catched")) - (should (string= (comp-tests-condition-case-1-f) - "error foo catched")) - (should (= (comp-tests-catch-f - (lambda () (throw 'foo 3))) - 3)) - (should (= (catch 'foo - (comp-tests-throw-f 3)))))) + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched")) + (should (= (comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3))))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." From c27394da7e3e35ab35e0430ab331d6dadca2803d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 9 Feb 2020 16:17:21 +0100 Subject: [PATCH 0713/1452] Rework frame layout Every function call by reference gets use one unique array of arguments. --- lisp/emacs-lisp/comp.el | 77 +++++++++++++++++--------- src/comp.c | 117 +++++++++++++++++++++++++--------------- 2 files changed, 126 insertions(+), 68 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2d609f0527c..701cba32906 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -274,7 +274,9 @@ structure.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Counter to create ssa limple vars.") (has-non-local nil :type boolean - :documentation "t if non local jumps are present.")) + :documentation "t if non local jumps are present.") + (array-h (make-hash-table) :type hash-table + :documentation "array idx -> array length.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -285,6 +287,8 @@ structure.") "A meta-variable being a slot in the meta-stack." (slot nil :type (or fixnum symbol) :documentation "Slot number if a number or 'scratch' for scratch slot.") + (array-idx 0 :type fixnum + :documentation "Array index.") (id nil :type (or null number) :documentation "SSA number when in SSA form.") (const-vld nil :type boolean @@ -295,9 +299,6 @@ structure.") (type nil :documentation "When non nil indicates the type when known at compile time.") - (ref nil :type boolean - :documentation "When non nil the m-var is involved in a - call where is passed by reference.") (impure nil :type boolean :documentation "When non nil can't be copied into pure space.")) @@ -466,6 +467,8 @@ Put PREFIX in front of it." (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-function :name function-name))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (list func)))) (cl-defgeneric comp-spill-lap-function ((filename string)) @@ -491,7 +494,10 @@ Put PREFIX in front of it." :args (comp-decrypt-arg-list (aref data 0) name) :lap (alist-get name byte-to-native-lap) :frame-size (comp-byte-frame-size data)) - do (comp-log (format "Function %s:\n" name) 1) + do + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1) collect func)) @@ -1149,6 +1155,7 @@ into the C code forwarding the compilation unit." (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) (defun comp-addr-to-bb-name (addr) @@ -1564,14 +1571,38 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) -(defun comp-basic-const-propagate () - "Propagate simple constants for setimm operands. -This can run just once." +(defun comp-ref-args-to-array (args) + "Given ARGS assign them to a dedicated array." + (when (and args + ;; Never rename an already renamed array index. + (= (comp-mvar-array-idx (car args)) 0)) + (cl-loop with array-h = (comp-func-array-h comp-func) + with arr-idx = (hash-table-count array-h) + for i from 0 + for arg in args + initially + (puthash arr-idx (length args) array-h) + do + ;; Just check that all args have zeroed arr-idx. + ;; (arrays must be used once). + (cl-assert (= (comp-mvar-array-idx arg) 0)) + (setf (comp-mvar-slot arg) i) + (setf (comp-mvar-array-idx arg) arr-idx)))) + +(defun comp-propagate-once () + "Prologue for the propagate pass. +Here goes everything that can be done not iteratively (read once). +- Forward propagate immediate involed in assignments +- Backward propagate placement into arrays" (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) do (pcase insn + (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args)) + (comp-ref-args-to-array args)) + (`(,(or 'callref 'direct-callref) ,_f . ,args) + (comp-ref-args-to-array args)) (`(setimm ,lval ,_ ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v @@ -1628,13 +1659,13 @@ This can run just once." (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) - ;; Const prop here. + ;; Forward const prop here. (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) (consts (mapcar #'comp-mvar-constant rest)) (x (car consts)) (equals (cl-every (lambda (y) (equal x y)) consts))) (setf (comp-mvar-constant lval) x)) - ;; Type propagation. + ;; Forward type propagation. ;; FIXME: checking for type equality is not sufficient cause does not ;; account type hierarchy! (when-let* ((types (mapcar #'comp-mvar-type rest)) @@ -1642,10 +1673,14 @@ This can run just once." (x (car types)) (eqs (cl-every (lambda (y) (eq x y)) types))) (setf (comp-mvar-type lval) x)) - ;; Reference propagation. - (let ((operands (cons lval rest))) - (when (cl-some #'comp-mvar-ref operands) - (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) + ;; Backward propagate array index and slot. + (let ((arr-idx (comp-mvar-array-idx lval))) + (when (> arr-idx 0) + (cl-loop with slot = (comp-mvar-slot lval) + for arg in rest + do + (setf (comp-mvar-array-idx arg) arr-idx) + (setf (comp-mvar-slot arg) slot))))))) (defun comp-propagate* () "Propagate for set* and phi operands. @@ -1666,7 +1701,7 @@ Return t if something was changed." ;; FIXME remove the following condition when tested. (unless (comp-func-has-non-local f) (let ((comp-func f)) - (comp-basic-const-propagate) + (comp-propagate-once) (cl-loop for i from 1 while (comp-propagate*) @@ -1695,13 +1730,7 @@ Return t if something was changed." (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) - collect (make-comp-mvar :constant nil)))) - (clean-args-ref (args) - ;; Clean-up the ref slot in all args - (mapc (lambda (arg) - (setf (comp-mvar-ref arg) nil)) - args) - args)) + collect (make-comp-mvar :constant nil))))) (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) @@ -1721,7 +1750,7 @@ Return t if something was changed." (args (if (eq call-type 'callref) args (fill-args args maxarg)))) - `(,call-type ,callee ,@(clean-args-ref args)))) + `(,call-type ,callee ,@args))) ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers that for non self calls too!! ((or (eq callee self) @@ -1733,7 +1762,7 @@ Return t if something was changed." (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@(clean-args-ref args)))) + `(,call-type ,callee ,@args))) ((comp-type-hint-p callee) `(call ,callee ,@args))))))) diff --git a/src/comp.c b/src/comp.c index 4b1ddeda0f4..d95a87b03b1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -150,10 +150,10 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ - gcc_jit_block *block; /* Current basic block being compiled. */ - gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ + gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ + gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -348,7 +348,7 @@ declare_block (Lisp_Object block_name) } static gcc_jit_lvalue * -get_slot (Lisp_Object mvar) +emit_mvar_access (Lisp_Object mvar) { Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); @@ -361,15 +361,18 @@ get_slot (Lisp_Object mvar) "scratch"); return comp.scratch; } + + EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); EMACS_INT slot_n = XFIXNUM (mvar_slot); - gcc_jit_lvalue **frame = - /* Disable floating frame for functions with non local jumps. - This is probably overkill cause we could do it just for blocks - dominated by push-handler. */ - comp.func_has_non_local - || (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) - ? comp.frame : comp.f_frame; - return frame[slot_n]; + if (comp.func_has_non_local || !SPEED) + return comp.arrays[arr_idx][slot_n]; + else + { + if (arr_idx) + return comp.arrays[arr_idx][slot_n]; + else + return comp.f_frame[slot_n]; + } } static void @@ -1140,7 +1143,7 @@ emit_mvar_val (Lisp_Object mvar) return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar)); } - return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); + return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); } static void @@ -1150,7 +1153,7 @@ emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) gcc_jit_block_add_assignment ( comp.block, NULL, - get_slot (dst_mvar), + emit_mvar_access (dst_mvar), val); } @@ -1239,10 +1242,28 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_INT base_ptr = 0; - if (nargs) - base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); - return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); + + if (!nargs) + return emit_call_ref (callee, + nargs, + comp.arrays[0][0], + direct); + + Lisp_Object first_arg = SECOND (insn); + Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg); + + /* Make sure all the arguments are layout-ed into the same array. */ + Lisp_Object p = XCDR (XCDR (insn)); + FOR_EACH_TAIL (p) + if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p)))) + xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"), + insn); + + EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); + return emit_call_ref (callee, + nargs, + comp.arrays[XFIXNUM (arr_idx)][first_slot], + direct); } /* Register an handler for a non local exit. */ @@ -2867,34 +2888,43 @@ compile_function (Lisp_Object func) comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); - gcc_jit_lvalue *frame_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - frame_size), - "local"); - comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (EMACS_INT i = 0; i < frame_size; ++i) - comp.frame[i] = - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (frame_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); + struct Lisp_Hash_Table *array_h = + XHASH_TABLE (CALL1I (comp-func-array-h, func)); + comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays)); + for (ptrdiff_t i = 0; i < array_h->count; i++) + { + EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i)); + comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays)); + + gcc_jit_lvalue *arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + array_len), + format_string ("arr_%td", i)); + + for (ptrdiff_t j = 0; j < array_len; j++) + comp.arrays[i][j] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + j)); + } /* - The floating frame is a copy of the normal frame that can be used to store - locals if the are not going to be used in a nargs call. - This has two advantages: - - Enable gcc for better reordering (frame array is clobbered every time is - passed as parameter being involved into an nargs function call). - - Allow gcc to trigger other optimizations that are prevented by memory - referencing. + The floating frame is a copy of the normal frame that can be used to store + locals if the are not going to be used in a nargs call. + This has two advantages: + - Enable gcc for better reordering (frame array is clobbered every time is + passed as parameter being involved into an nargs function call). + - Allow gcc to trigger other optimizations that are prevented by memory + referencing. */ if (SPEED >= 2) { @@ -2952,7 +2982,6 @@ compile_function (Lisp_Object func) build_string ("failing to compile function"), CALL1I (comp-func-name, func), build_string (err)); - SAFE_FREE (); } From 3b3525b916eee975697e9c3c72a5fd780f6eecd6 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Fri, 14 Feb 2020 14:54:36 +0000 Subject: [PATCH 0714/1452] Backward propagate only once --- lisp/emacs-lisp/comp.el | 42 +++++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 701cba32906..6476603f9b9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -99,9 +99,9 @@ Can be used by code that wants to expand differently in this case.") (defconst comp-passes '(comp-spill-lap comp-limplify comp-ssa - comp-propagate + comp-propagate-1 comp-call-optim - comp-propagate + comp-propagate-2 comp-dead-code comp-final) "Passes to be executed in order.") @@ -1571,11 +1571,10 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) + (defun comp-ref-args-to-array (args) "Given ARGS assign them to a dedicated array." - (when (and args - ;; Never rename an already renamed array index. - (= (comp-mvar-array-idx (car args)) 0)) + (when args (cl-loop with array-h = (comp-func-array-h comp-func) with arr-idx = (hash-table-count array-h) for i from 0 @@ -1583,26 +1582,32 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." initially (puthash arr-idx (length args) array-h) do - ;; Just check that all args have zeroed arr-idx. - ;; (arrays must be used once). + ;; We are not supposed to rename arrays more then once. + ;; This because we do only one final back propagation + ;; and arrays are used only once. + + ;; Note: this last is just a property of the code generated + ;; by the byte-compiler. (cl-assert (= (comp-mvar-array-idx arg) 0)) (setf (comp-mvar-slot arg) i) (setf (comp-mvar-array-idx arg) arr-idx)))) -(defun comp-propagate-once () +(defun comp-propagate-prologue (backward) "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). -- Forward propagate immediate involed in assignments -- Backward propagate placement into arrays" +- Forward propagate immediate involed in assignments. +- Backward propagate array layout when BACKWARD is non nil." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) do (pcase insn (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args)) - (comp-ref-args-to-array args)) + (when backward + (comp-ref-args-to-array args))) (`(,(or 'callref 'direct-callref) ,_f . ,args) - (comp-ref-args-to-array args)) + (when backward + (comp-ref-args-to-array args))) (`(setimm ,lval ,_ ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v @@ -1695,13 +1700,13 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-propagate (_) +(defun comp-propagate-iterate (backward) (when (>= comp-speed 2) (maphash (lambda (_ f) ;; FIXME remove the following condition when tested. (unless (comp-func-has-non-local f) (let ((comp-func f)) - (comp-propagate-once) + (comp-propagate-prologue backward) (cl-loop for i from 1 while (comp-propagate*) @@ -1709,6 +1714,15 @@ Return t if something was changed." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) +(defun comp-propagate-1 (_) + "Forward propagate types and consts within the lattice." + (comp-propagate-iterate nil)) + +(defun comp-propagate-2 (_) + "Forward propagate types and consts within the lattice. +Backward propagate array placement properties." + (comp-propagate-iterate t)) + ;;; Call optimizer pass specific code. ;; This pass is responsible for the following optimizations: From 4b4c7535a053caf8a074246d0eabb44873119076 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Fri, 14 Feb 2020 15:22:24 +0000 Subject: [PATCH 0715/1452] Speed 2 goes default --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6476603f9b9..9a782f7497f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,7 +38,7 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-speed 0 +(defcustom comp-speed 2 "Compiler optimization level. From 0 to 3. - 0 no optimizations are performed, compile time is favored. - 1 lite optimizations. From 2a8a3a9f28a6b1404161512115b059a376bc07f0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Feb 2020 08:46:30 +0000 Subject: [PATCH 0716/1452] Use `sxhash-eq' to generate mvar SSA ids --- lisp/emacs-lisp/comp.el | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9a782f7497f..b6c1a95315d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -271,18 +271,11 @@ structure.") :documentation "Generates block numbers.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") - (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.")) -(defun comp-func-reset-generators (func) - "Reset unique id generators for FUNC." - (setf (comp-func-edge-cnt-gen func) (comp-gen-counter) - (comp-func-ssa-cnt-gen func) (comp-gen-counter))) - (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type (or fixnum symbol) @@ -1254,9 +1247,12 @@ Top-level forms for the current context are rendered too." ;; This pass should be run every time basic blocks or m-var are shuffled. (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) - (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) - :slot slot :const-vld const-vld :constant constant - :type type)) + (let ((mvar (make--comp-mvar :slot slot + :const-vld const-vld + :constant constant + :type type))) + (setf (comp-mvar-id mvar) (sxhash-eq mvar)) + mvar)) (defun comp-compute-edges () "Compute the basic block edges for the current function." @@ -1518,7 +1514,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (let ((comp-func f)) ;; TODO: if this is run more than once we should clean all CFG ;; data including phis here. - (comp-func-reset-generators comp-func) (comp-compute-edges) (comp-compute-dominator-tree) (comp-compute-dominator-frontiers) @@ -1571,7 +1566,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) - (defun comp-ref-args-to-array (args) "Given ARGS assign them to a dedicated array." (when args From 5bd485340fea0788035241860aad0804ebeeb388 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Feb 2020 10:31:46 +0000 Subject: [PATCH 0717/1452] Introduce comp-dry-run --- lisp/emacs-lisp/comp.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6c1a95315d..7ba319204d1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -83,6 +83,9 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) +(defvar comp-dry-run nil + "When non nil run everything but the C back-end.") + (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -1893,7 +1896,8 @@ These are substituted with a normal 'set' op." Prepare every function for final compilation and drive the C back-end." (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) - (comp--compile-ctxt-to-file name)) + (unless comp-dry-run + (comp--compile-ctxt-to-file name))) (defun comp-final (_) "Final pass driving the C back-end for code emission." From 8c108ce607693f9fb5bfa6ca30da66faad777512 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Feb 2020 12:19:10 +0100 Subject: [PATCH 0718/1452] Add a simple pass for self TCO --- lisp/emacs-lisp/comp.el | 43 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7ba319204d1..67fc8f39f8c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -106,6 +106,7 @@ Can be used by code that wants to expand differently in this case.") comp-call-optim comp-propagate-2 comp-dead-code + comp-tco comp-final) "Passes to be executed in order.") @@ -1888,6 +1889,48 @@ These are substituted with a normal 'set' op." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) + +;;; Tail Call Optimization pass specific code. + +(defun comp-form-tco-call-seq (args) + "Generate a tco sequence for ARGS." + `(,@(cl-loop for arg in args + for i from 0 + collect `(set ,(make-comp-mvar :slot i) ,arg)) + (jump bb_0))) + +(defun comp-tco-func () + "Try to pattern match and perform TCO within the current function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((set ,l-val (direct-call ,func . ,args)) + (comment ,_comment) + (return ,ret-val)) + (when (and (eq func (comp-func-name comp-func)) + (eq l-val ret-val)) + (let ((tco-seq (comp-form-tco-call-seq args))) + (setf (car insns-seq) (car tco-seq) + (cdr insns-seq) (cdr tco-seq)) + (cl-return-from in-the-basic-block)))))))) + +(defun comp-tco (_) + "Simple peephole pass performing self TCO." + (when (>= comp-speed 3) + (maphash (lambda (_ f) + (let ((comp-func f)) + (unless (comp-func-has-non-local comp-func) + (comp-tco-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt)))) + +;; NOTE: After TCO runs edges, phis etc are not updated. In case some +;; other pass that make use of them after here is added `comp-ssa' +;; should be re-run. + ;;; Final pass specific code. From 81c34a35aab53978bc2f3608dff3751030d0e914 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Feb 2020 18:14:35 +0100 Subject: [PATCH 0719/1452] Update copyright years plus two style nits --- lisp/emacs-lisp/comp.el | 10 +++++----- src/comp.c | 2 +- src/comp.h | 2 +- test/src/comp-test-funcs.el | 2 +- test/src/comp-tests.el | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 67fc8f39f8c..80a542257fb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2,7 +2,7 @@ ;; Author: Andrea Corallo -;; Copyright (C) 2019 Free Software Foundation, Inc. +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Keywords: lisp ;; Package: emacs @@ -1587,8 +1587,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;; Note: this last is just a property of the code generated ;; by the byte-compiler. (cl-assert (= (comp-mvar-array-idx arg) 0)) - (setf (comp-mvar-slot arg) i) - (setf (comp-mvar-array-idx arg) arr-idx)))) + (setf (comp-mvar-slot arg) i + (comp-mvar-array-idx arg) arr-idx)))) (defun comp-propagate-prologue (backward) "Prologue for the propagate pass. @@ -1682,8 +1682,8 @@ Here goes everything that can be done not iteratively (read once). (cl-loop with slot = (comp-mvar-slot lval) for arg in rest do - (setf (comp-mvar-array-idx arg) arr-idx) - (setf (comp-mvar-slot arg) slot))))))) + (setf (comp-mvar-array-idx arg) arr-idx + (comp-mvar-slot arg) slot))))))) (defun comp-propagate* () "Propagate for set* and phi operands. diff --git a/src/comp.c b/src/comp.c index d95a87b03b1..2f24b10bba0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,5 +1,5 @@ /* Compile elisp into native code. - Copyright (C) 2019 Free Software Foundation, Inc. + Copyright (C) 2019-2020 Free Software Foundation, Inc. Author: Andrea Corallo diff --git a/src/comp.h b/src/comp.h index ddebbbcccf0..6019831bc30 100644 --- a/src/comp.h +++ b/src/comp.h @@ -1,5 +1,5 @@ /* Elisp native compiler definitions -Copyright (C) 2012-2019 Free Software Foundation, Inc. +Copyright (C) 2019-2020 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index cbf287838cb..46d324bc42f 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -1,6 +1,6 @@ ;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- -;; Copyright (C) 2019 Free Software Foundation, Inc. +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Author: Andrea Corallo diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 15a39c4e883..fc6543bcaec 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1,6 +1,6 @@ ;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- -;; Copyright (C) 2019 Free Software Foundation, Inc. +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Author: Andrea Corallo From d8e4ba2693308b6501f346bb1116daf5ea3a2234 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Thu, 20 Feb 2020 09:14:57 +0000 Subject: [PATCH 0720/1452] Reorder m-var slots --- lisp/emacs-lisp/comp.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 80a542257fb..eabba243c2e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -282,18 +282,20 @@ structure.") (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (slot nil :type (or fixnum symbol) - :documentation "Slot number if a number or 'scratch' for scratch slot.") - (array-idx 0 :type fixnum - :documentation "Array index.") (id nil :type (or null number) - :documentation "SSA number when in SSA form.") + :documentation "Unique id when in SSA form.") + ;; The following two are allocation info. + (array-idx 0 :type fixnum + :documentation "The array where the m-var gets allocated.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number in the array if a number or + 'scratch' for scratch slot.") (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil :documentation "When const-vld non nil this is used for holding a value known at compile time.") - (type nil + (type nil :type symbol :documentation "When non nil indicates the type when known at compile time.") (impure nil :type boolean From ec5d95782d90c6b6b7f291a4a8214cc7f64dadd6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 21 Feb 2020 10:24:32 +0100 Subject: [PATCH 0721/1452] Verify '--with-nativecomp' has also '--with-dumping=pdumper' --- configure.ac | 3 +++ 1 file changed, 3 insertions(+) diff --git a/configure.ac b/configure.ac index c8e22ff5925..0b2f5b69d6b 100644 --- a/configure.ac +++ b/configure.ac @@ -3738,6 +3738,9 @@ If you are sure you want Emacs compiled without elisp native compiler, pass to configure.]) fi fi +if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then + AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) +fi AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) From 3a7aa06d1575750a498c453bec321a69c2b3bb48 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Fri, 21 Feb 2020 14:28:05 +0000 Subject: [PATCH 0722/1452] Emit 'top_level_run' objects as impure --- lisp/emacs-lisp/comp.el | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eabba243c2e..edbc98f190b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -99,6 +99,8 @@ Can be used by code that wants to expand differently in this case.") (defvar comp-pass nil "Every pass has the right to bind what it likes here.") +(defvar comp-emitting-impure nil "Non nil to emit only impure objects.") + (defconst comp-passes '(comp-spill-lap comp-limplify comp-ssa @@ -336,14 +338,13 @@ The corresponding index is returned." (push obj (comp-data-container-l cont)) (puthash obj (hash-table-count h) h)))) -(defun comp-add-const-to-relocs (obj &optional impure) +(defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. -When IMPURE is non nil OBJ cannot be copied into pure space. The corresponding index is returned." (comp-add-const-to-relocs-to-cont obj - (if impure + (if comp-emitting-impure (comp-ctxt-d-impure comp-ctxt) - (comp-ctxt-d-base comp-ctxt)))) + (comp-ctxt-d-base comp-ctxt)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -526,7 +527,7 @@ Points to the next slot to be filled.") (label-to-addr nil :type hash-table :documentation "LAP hash table -> address.") (pending-blocks () :type list - :documentation "List of blocks waiting for limplification.")) + :documentation "List of blocks waiting for limplification.")) (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop @@ -613,12 +614,11 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type - impure) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld - (comp-add-const-to-relocs constant impure)) + (comp-add-const-to-relocs constant)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type :impure impure)) + :type type :impure comp-emitting-impure)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1129,7 +1129,8 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) (comp-emit (comp-call 'eval - (make-comp-mvar :constant form :impure t) + (let ((comp-emitting-impure t)) + (make-comp-mvar :constant form)) (make-comp-mvar :constant t))))) (defun comp-limplify-top-level () @@ -1140,7 +1141,11 @@ Synthesize a function called 'top_level_run' that gets one single parameter (the compilation unit it-self). To define native functions 'top_level_run' will call back `comp--register-subr' into the C code forwarding the compilation unit." - (let* ((func (make-comp-func :name 'top-level-run + ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no + ;; reasons to be execute ever again. Therefore all objects can be + ;; just impure. + (let* ((comp-emitting-impure t) + (func (make-comp-func :name 'top-level-run :c-name "top_level_run" :args (make-comp-args :min 1 :max 1) :frame-size 1)) From 93f86a23784822968ba8f2e1f79abaeb1ab35dab Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 21 Feb 2020 18:59:46 +0000 Subject: [PATCH 0723/1452] Test 'comp-eq' should not assume any string hashing policy --- test/src/comp-tests.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fc6543bcaec..00a40228740 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -441,8 +441,7 @@ Check that the resulting binaries do not differ." (ert-deftest comp-eq () (should (comp-test-eq 'a 'a)) (should (comp-test-eq 5 5)) - (should-not (comp-test-eq 'a 'b)) - (should-not (comp-test-eq "x" "x"))) + (should-not (comp-test-eq 'a 'b))) (ert-deftest comp-if () (should (eq (comp-test-if 'a 'b) 'a)) From 3130690882d187a5d6b757fd109c60c84009d973 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Feb 2020 10:31:00 +0000 Subject: [PATCH 0724/1452] Fix `comp-tests-free-fun' Address the case were comp-tests.el is byte-compiled. --- test/src/comp-tests.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 00a40228740..e4b7a066cc0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -325,10 +325,11 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." - (defun comp-tests-free-fun-f () - "Some doc." - (interactive) - 3) + (eval '(defun comp-tests-free-fun-f () + "Some doc." + (interactive) + 3) + t) (load (native-compile #'comp-tests-free-fun-f)) (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) From 1dc237f280702d959216916b236cb9bf9bbcb22c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Feb 2020 14:06:59 +0000 Subject: [PATCH 0725/1452] Make build process robust against interruptions During boo-strap 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 to build interruptions. --- lisp/emacs-lisp/bytecomp.el | 21 +++++++++++++++------ lisp/emacs-lisp/comp.el | 16 ++++++++++------ 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1f64626a993..b3bd6879b69 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -571,13 +571,19 @@ Each element is (INDEX . VALUE)") form) (defvar byte-native-compiling nil "Non nil while native compiling.") -(defvar byte-native-always-write-elc nil - "Always write the elc file also while native compiling.") +(defvar byte-native-for-bootstrap nil + "Non nil while compiling for bootstrap." + ;; During boostrap 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-lap nil "A-list to accumulate LAP. Each pair is (NAME . LAP)") (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.") ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2035,10 +2041,13 @@ The value is non-nil if there were no errors, nil if errors." ;; emacs-lisp files in the build tree are ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. - (if (and byte-native-compiling - (null byte-native-always-write-elc)) - (delete-file tempfile) - (rename-file tempfile target-file t))) + (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))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index edbc98f190b..c13844c70b7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2071,12 +2071,16 @@ Return the compilation unit file name." (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." - ;; FIXME remove when dynamic scope support is implemented. - (let ((byte-native-always-write-elc t)) - (condition-case _ - (batch-native-compile) - (native-compiler-error-dyn-func) - (native-compiler-error-empty-byte)))) + (let ((byte-native-for-bootstrap t) + (byte-to-native-output-file nil)) + (unwind-protect + (condition-case _ + (batch-native-compile) + (native-compiler-error-dyn-func) + (native-compiler-error-empty-byte)) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t)))))) ;;;###autoload (defun native-compile-async (input &optional jobs recursively) From 48b131c6d17383eed4b09634e4dddf226b0cd3cd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Feb 2020 14:49:46 +0000 Subject: [PATCH 0726/1452] * Add two hooks for async native compilation --- lisp/emacs-lisp/comp.el | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c13844c70b7..af7963289dc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -83,6 +83,20 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) +(defcustom comp-async-cu-done-hook nil + "This hook is run whenever an asyncronous native compilation +finish compiling a single compilation unit. +The argument FILE passed to the function is the filename used as +compilation input." + :type 'hook + :group 'comp) + +(defcustom comp-async-all-done-hook nil + "This hook is run whenever the asyncronous native compilation +finished compiling all input files." + :type 'hook + :group 'comp) + (defvar comp-dry-run nil "When non nil run everything but the C back-end.") @@ -2016,6 +2030,9 @@ Prepare every function for final compilation and drive the C back-end." "--eval" (prin1-to-string code)) :sentinel (lambda (prc _event) + (run-hook-with-args + 'comp-async-cu-done-hook + f) (accept-process-output prc) (comp-start-async-worker))) comp-prc-pool) @@ -2023,6 +2040,7 @@ Prepare every function for final compilation and drive the C back-end." (when (cl-notany #'process-live-p comp-prc-pool) (let ((msg "Compilation finished.")) (setf comp-prc-pool ()) + (run-hooks 'comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion (goto-char (point-max)) From f0daf1292ccfd6f07b8ded28e29f01919c43022e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Feb 2020 09:32:51 +0000 Subject: [PATCH 0727/1452] * Two grammar fixes into async hooks doc --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index af7963289dc..7054c588999 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,7 +85,7 @@ performed at `comp-speed' > 0." (defcustom comp-async-cu-done-hook nil "This hook is run whenever an asyncronous native compilation -finish compiling a single compilation unit. +finishes compiling a single compilation unit. The argument FILE passed to the function is the filename used as compilation input." :type 'hook @@ -93,7 +93,7 @@ compilation input." (defcustom comp-async-all-done-hook nil "This hook is run whenever the asyncronous native compilation -finished compiling all input files." +finishes compiling all input files." :type 'hook :group 'comp) From 94dcb69256a0daea2c51540217c3abdc2fd50552 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 25 Feb 2020 22:35:02 +0000 Subject: [PATCH 0728/1452] Add ephemeral relocation data class Add a new class of relocated objects that is in use just during load process. This in order to avoid having to maintain them in the heap and traverse them at every GC. --- lisp/emacs-lisp/comp.el | 39 ++++++++++++++------- src/comp.c | 78 ++++++++++++++++++++++++++++++++--------- 2 files changed, 88 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7054c588999..000f266ba22 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -32,6 +32,7 @@ (require 'gv) (require 'cl-lib) (require 'cl-extra) +(require 'cl-macs) (require 'subr-x) (defgroup comp nil @@ -113,7 +114,9 @@ Can be used by code that wants to expand differently in this case.") (defvar comp-pass nil "Every pass has the right to bind what it likes here.") -(defvar comp-emitting-impure nil "Non nil to emit only impure objects.") +(defvar comp-curr-allocation-class 'd-base + "Current allocation class. +Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -196,8 +199,10 @@ This is to build the prev field.") (d-base (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container - :documentation "Data relocated that cannot be moved into pure space. -This is tipically for top-level forms other than defun.")) + :documentation "Relocated data that cannot be moved into pure space. +This is tipically for top-level forms other than defun.") + (d-ephemeral (make-comp-data-container) :type comp-data-container + :documentation "Relocated data not necessary after load.")) (cl-defstruct comp-args-base (min nil :type number @@ -314,8 +319,9 @@ structure.") (type nil :type symbol :documentation "When non nil indicates the type when known at compile time.") - (impure nil :type boolean - :documentation "When non nil can't be copied into pure space.")) + (alloc-class nil :type symbol + :documentation "Can be one of: 'd-base' 'd-impure' + or 'd-ephemeral'.")) ;; Special vars used by some passes (defvar comp-func) @@ -352,13 +358,17 @@ The corresponding index is returned." (push obj (comp-data-container-l cont)) (puthash obj (hash-table-count h) h)))) +(defsubst comp-alloc-class-to-container (alloc-class) + "Given ALLOC-CLASS return the data container for the current context. +Assume allocaiton class 'd-base as default." + (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-base) comp-ctxt)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." (comp-add-const-to-relocs-to-cont obj - (if comp-emitting-impure - (comp-ctxt-d-impure comp-ctxt) - (comp-ctxt-d-base comp-ctxt)))) + (comp-alloc-class-to-container + comp-curr-allocation-class))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -632,7 +642,7 @@ STACK-OFF is the index of the first slot frame involved." (when const-vld (comp-add-const-to-relocs constant)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type :impure comp-emitting-impure)) + :type type :alloc-class comp-curr-allocation-class)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1143,7 +1153,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) (comp-emit (comp-call 'eval - (let ((comp-emitting-impure t)) + (let ((comp-curr-allocation-class 'd-impure)) (make-comp-mvar :constant form)) (make-comp-mvar :constant t))))) @@ -1158,7 +1168,7 @@ into the C code forwarding the compilation unit." ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no ;; reasons to be execute ever again. Therefore all objects can be ;; just impure. - (let* ((comp-emitting-impure t) + (let* ((comp-curr-allocation-class 'd-impure) (func (make-comp-func :name 'top-level-run :c-name "top_level_run" :args (make-comp-args :min 1 :max 1) @@ -1271,11 +1281,13 @@ Top-level forms for the current context are rendered too." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type + (alloc-class comp-curr-allocation-class)) (let ((mvar (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type))) + :type type + :alloc-class alloc-class))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) @@ -1960,6 +1972,7 @@ These are substituted with a normal 'set' op." Prepare every function for final compilation and drive the C back-end." (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) + (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) (unless comp-dry-run (comp--compile-ctxt-to-file name))) diff --git a/src/comp.c b/src/comp.c index 2f24b10bba0..b6de0ece36a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -40,11 +40,13 @@ along with GNU Emacs. If not, see . */ #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" +#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph" #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" #define COMP_UNIT_SYM "comp_unit" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" +#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -178,6 +180,8 @@ typedef struct { gcc_jit_rvalue *data_relocs; /* Same as before but can't go in pure space. */ gcc_jit_rvalue *data_relocs_impure; + /* Same as before but content does not survive load phase. */ + gcc_jit_rvalue *data_relocs_ephemeral; /* Synthesized struct holding func relocs. */ gcc_jit_lvalue *func_relocs; } comp_t; @@ -382,6 +386,20 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } +static gcc_jit_rvalue * +alloc_class_to_reloc (Lisp_Object alloc_class) +{ + if (alloc_class == Qd_base) + return comp.data_relocs; + else if (alloc_class == Qd_impure) + return comp.data_relocs_impure; + else if (alloc_class == Qd_ephemeral) + return comp.data_relocs_ephemeral; + xsignal (Qnative_ice, + build_string ("inconsistent allocation class")); + assume (false); +} + static void emit_comment (const char *str) { @@ -893,7 +911,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) +emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -904,8 +922,7 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) comp.void_ptr_type, NULL)); - Lisp_Object container = impure ? CALL1I (comp-ctxt-d-impure, Vcomp_ctxt) - : CALL1I (comp-ctxt-d-base, Vcomp_ctxt); + Lisp_Object container = CALL1I (comp-alloc-class-to-container, alloc_class); Lisp_Object reloc_idx = Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil); eassert (!NILP (reloc_idx)); @@ -917,8 +934,7 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - impure ? comp.data_relocs_impure - : comp.data_relocs, + alloc_class_to_reloc (alloc_class), reloc_n)); } @@ -926,7 +942,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil, Qnil)); + return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_base)); } static gcc_jit_rvalue * @@ -1029,7 +1045,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp, Qnil), + emit_const_lisp_obj (Qconsp, Qd_base), x }; gcc_jit_block_add_eval ( @@ -1140,7 +1156,8 @@ emit_mvar_val (Lisp_Object mvar) return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar)); + return emit_const_lisp_obj (constant, + CALL1I (comp-mvar-alloc-class, mvar)); } return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); @@ -1175,7 +1192,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil, Qnil); + gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_base); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1563,7 +1580,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - comp.data_relocs, + alloc_class_to_reloc ( + CALL1I (comp-mvar-alloc-class, + arg[0])), reloc_n))); } else if (EQ (op, Qcomment)) @@ -1825,6 +1844,10 @@ declare_imported_data (void) declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt), DATA_RELOC_IMPURE_SYM, TEXT_DATA_RELOC_IMPURE_SYM); + comp.data_relocs_ephemeral = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt), + DATA_RELOC_EPHEMERAL_SYM, + TEXT_DATA_RELOC_EPHEMERAL_SYM); } /* @@ -2417,11 +2440,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qnil)); + emit_const_lisp_obj (Qnil, Qd_base)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp, Qnil), c }; + { emit_const_lisp_obj (Qlistp, Qd_base), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2430,7 +2453,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qnil)); + emit_const_lisp_obj (Qnil, Qd_base)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2810,13 +2833,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt, Qnil)); + emit_const_lisp_obj (Qt, Qd_base)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil, Qnil)); - + emit_const_lisp_obj (Qnil, Qd_base)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ @@ -3358,12 +3380,25 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + Lisp_Object *data_eph_relocs = + dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); + Lisp_Object volatile data_ephemeral_vec; + + /* Note: data_ephemeral_vec is not GC protected except than by + this function frame. After this functions will be + deactivated GC will be free to collect it, but it MUST + survive till 'top_level_run' has finished his job. We store + into the ephemeral allocation class only objects that we know + are necessary exclusively during the first load. Once these + are collected we don't have to maintain them in the heap + forever. */ if (!(current_thread_reloc && pure_reloc && data_relocs && data_imp_relocs + && data_eph_relocs && freloc_link_table && top_level_run) || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), @@ -3382,6 +3417,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3512,6 +3553,11 @@ syms_of_comp (void) DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); + /* Allocation classes. */ + DEFSYM (Qd_base, "d-base"); + DEFSYM (Qd_impure, "d-impure"); + DEFSYM (Qd_ephemeral, "d-ephemeral"); + /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); From 6898161a2b4d6af2d4b4b8f20a813304938bed53 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 25 Feb 2020 21:39:59 +0000 Subject: [PATCH 0729/1452] Rename d-base allocation classe into d-default --- lisp/emacs-lisp/comp.el | 14 +++++++------- src/comp.c | 22 +++++++++++----------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 000f266ba22..d34ff3c0c89 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -114,9 +114,9 @@ Can be used by code that wants to expand differently in this case.") (defvar comp-pass nil "Every pass has the right to bind what it likes here.") -(defvar comp-curr-allocation-class 'd-base +(defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") +Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -196,7 +196,7 @@ Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") - (d-base (make-comp-data-container) :type comp-data-container + (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container :documentation "Relocated data that cannot be moved into pure space. @@ -320,7 +320,7 @@ structure.") :documentation "When non nil indicates the type when known at compile time.") (alloc-class nil :type symbol - :documentation "Can be one of: 'd-base' 'd-impure' + :documentation "Can be one of: 'd-default' 'd-impure' or 'd-ephemeral'.")) ;; Special vars used by some passes @@ -360,8 +360,8 @@ The corresponding index is returned." (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. -Assume allocaiton class 'd-base as default." - (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-base) comp-ctxt)) +Assume allocaiton class 'd-default as default." + (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. @@ -1970,7 +1970,7 @@ These are substituted with a normal 'set' op." (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) + (comp-data-container-check (comp-ctxt-d-default comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) (unless comp-dry-run diff --git a/src/comp.c b/src/comp.c index b6de0ece36a..9855e352785 100644 --- a/src/comp.c +++ b/src/comp.c @@ -389,7 +389,7 @@ register_emitter (Lisp_Object key, void *func) static gcc_jit_rvalue * alloc_class_to_reloc (Lisp_Object alloc_class) { - if (alloc_class == Qd_base) + if (alloc_class == Qd_default) return comp.data_relocs; else if (alloc_class == Qd_impure) return comp.data_relocs_impure; @@ -942,7 +942,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_base)); + return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_default)); } static gcc_jit_rvalue * @@ -1045,7 +1045,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp, Qd_base), + emit_const_lisp_obj (Qconsp, Qd_default), x }; gcc_jit_block_add_eval ( @@ -1192,7 +1192,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_base); + gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_default); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1837,7 +1837,7 @@ declare_imported_data (void) /* Imported objects. */ comp.data_relocs = - declare_imported_data_relocs (CALL1I (comp-ctxt-d-base, Vcomp_ctxt), + declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt), DATA_RELOC_SYM, TEXT_DATA_RELOC_SYM); comp.data_relocs_impure = @@ -2440,11 +2440,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_base)); + emit_const_lisp_obj (Qnil, Qd_default)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp, Qd_base), c }; + { emit_const_lisp_obj (Qlistp, Qd_default), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2453,7 +2453,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_base)); + emit_const_lisp_obj (Qnil, Qd_default)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2833,12 +2833,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt, Qd_base)); + emit_const_lisp_obj (Qt, Qd_default)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil, Qd_base)); + emit_const_lisp_obj (Qnil, Qd_default)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ @@ -3554,7 +3554,7 @@ syms_of_comp (void) DEFSYM (Qintegerp, "integerp"); /* Allocation classes. */ - DEFSYM (Qd_base, "d-base"); + DEFSYM (Qd_default, "d-default"); DEFSYM (Qd_impure, "d-impure"); DEFSYM (Qd_ephemeral, "d-ephemeral"); From 511415f6f656a5bf4da4f5f49d58de9dc7d5d64d Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 25 Feb 2020 22:37:20 +0000 Subject: [PATCH 0730/1452] Store optimize qualities into .eln files For now just comp-speed and comp-debug are stored. --- src/comp.c | 10 ++++++++++ src/comp.h | 1 + src/print.c | 7 +++++-- 3 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9855e352785..0fc6e412924 100644 --- a/src/comp.c +++ b/src/comp.c @@ -47,6 +47,7 @@ along with GNU Emacs. If not, see . */ #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" +#define TEXT_OPTIM_QLY "text_optim_qly" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -1915,6 +1916,14 @@ declare_runtime_imported_funcs (void) static void emit_ctxt_code (void) { + /* Emit optimize qualities. */ + Lisp_Object opt_qly[] = + { Fcons (Qcomp_speed, + Fsymbol_value (Qcomp_speed)), + Fcons (Qcomp_debug, + Fsymbol_value (Qcomp_debug)) }; + emit_static_object (TEXT_OPTIM_QLY, Flist (2, opt_qly)); + comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -3414,6 +3423,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) /* Imported data. */ if (!loading_dump) { + comp_u->optimize_qualities = load_static_obj (comp_u, TEXT_OPTIM_QLY); comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); diff --git a/src/comp.h b/src/comp.h index 6019831bc30..3aff440ecb7 100644 --- a/src/comp.h +++ b/src/comp.h @@ -36,6 +36,7 @@ struct Lisp_Native_Comp_Unit union vectorlike_header header; /* Original eln file loaded. */ Lisp_Object file; + Lisp_Object optimize_qualities; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Same but for data that cannot be moved to pure space. diff --git a/src/print.c b/src/print.c index ce8dd625b68..9b8308a6758 100644 --- a/src/print.c +++ b/src/print.c @@ -1840,8 +1840,11 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, #ifdef HAVE_NATIVE_COMP case PVEC_NATIVE_COMP_UNIT: { - print_c_string ("#file, printcharfun); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj); + print_c_string ("#file, printcharfun); + printchar (' ', printcharfun); + print_object (cu->optimize_qualities, printcharfun, escapeflag); printchar ('>', printcharfun); } break; From 86cc9377cec397884744fcc4d0e5b555cbc3ca46 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 25 Feb 2020 22:41:59 +0000 Subject: [PATCH 0731/1452] * ; Add a TODO for a future optimization --- lisp/emacs-lisp/comp.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d34ff3c0c89..3c993c5c935 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1973,6 +1973,9 @@ Prepare every function for final compilation and drive the C back-end." (comp-data-container-check (comp-ctxt-d-default comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) + ;; TODO: here we could optimize cleaning up objects present in the + ;; impure and or in the ephemeral container that are also in the + ;; default one. (unless comp-dry-run (comp--compile-ctxt-to-file name))) From 62384df2656c0a57cdc07ac5397e22fa450a7de1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Feb 2020 11:05:46 +0000 Subject: [PATCH 0732/1452] * Reduce stack depth while marking native compiled subrs --- src/alloc.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/alloc.c b/src/alloc.c index 354c6f09cc5..9a01edca3f8 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6683,7 +6683,9 @@ mark_object (Lisp_Object arg) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_comp_u[0]); + obj = subr->native_comp_u[0]; + eassert (obj); + goto loop; } break; From b7f36249246a8f80924806593afcf55ab3baca2a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Feb 2020 14:12:21 +0000 Subject: [PATCH 0733/1452] * Rename comp-emit-set-const -> comp-emit-setimm --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3c993c5c935..6ad97062b42 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -679,7 +679,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-emit-set-const (val) +(defun comp-emit-setimm (val) "Set constant VAL to current slot." (let ((rel-idx (comp-add-const-to-relocs val))) (cl-assert (numberp rel-idx)) @@ -1086,7 +1086,7 @@ the annotation emission." (cl-second (comp-block-insns (comp-limplify-curr-block comp-pass))))) (byte-constant - (comp-emit-set-const arg)) + (comp-emit-setimm arg)) (byte-discardN-preserve-tos (cl-incf (comp-sp) (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) @@ -1112,7 +1112,7 @@ the annotation emission." (intern (format "entry_fallback_%s" (1+ i)))) do (comp-with-sp i (comp-make-curr-block bb (comp-sp)) - (comp-emit-set-const nil) + (comp-emit-setimm nil) (comp-emit `(jump ,next-bb))))) (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) @@ -1675,7 +1675,7 @@ Here goes everything that can be done not iteratively (read once). ;; is now left to gcc, to be implemented only if we want a ;; reliable diagnostic here. (let ((values (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-set-const'. + ;; See `comp-emit-setimm'. (setf (car insn) 'setimm (cddr insn) (list (comp-add-const-to-relocs values) values)))))) From 5543338b0c6245f0d1939d9c2617b65ded59ca3b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Feb 2020 15:53:42 +0000 Subject: [PATCH 0734/1452] Optimize relocation classes for object duplication Merge duplicated objects during final. Precendece is: 1 d-default 2 d-impure 3 d-ephemeral Now every object identify uniquely a relocation class. Because of this there's no need to keep the reloc class into m-var. --- lisp/emacs-lisp/comp.el | 95 ++++++++++++++++++-------------- src/comp.c | 119 +++++++++++++++++++++++----------------- 2 files changed, 123 insertions(+), 91 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6ad97062b42..7792605fff8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -318,10 +318,7 @@ structure.") a value known at compile time.") (type nil :type symbol :documentation "When non nil indicates the type when known at compile - time.") - (alloc-class nil :type symbol - :documentation "Can be one of: 'd-default' 'd-impure' - or 'd-ephemeral'.")) + time.")) ;; Special vars used by some passes (defvar comp-func) @@ -344,31 +341,15 @@ structure.") "Type hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defun comp-data-container-check (cont) - "Sanity check CONT coherency." - (cl-assert (= (length (comp-data-container-l cont)) - (hash-table-count (comp-data-container-idx cont))))) - -(defun comp-add-const-to-relocs-to-cont (obj cont) - "Keep track of OBJ into the CONT relocation container. -The corresponding index is returned." - (let ((h (comp-data-container-idx cont))) - (if-let ((idx (gethash obj h))) - idx - (push obj (comp-data-container-l cont)) - (puthash obj (hash-table-count h) h)))) - (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. Assume allocaiton class 'd-default as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) -(defun comp-add-const-to-relocs (obj) - "Keep track of OBJ into the ctxt relocations. -The corresponding index is returned." - (comp-add-const-to-relocs-to-cont obj - (comp-alloc-class-to-container - comp-curr-allocation-class))) +(defsubst comp-add-const-to-relocs (obj) + "Keep track of OBJ into the ctxt relocations." + (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container + comp-curr-allocation-class)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -642,7 +623,7 @@ STACK-OFF is the index of the first slot frame involved." (when const-vld (comp-add-const-to-relocs constant)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type :alloc-class comp-curr-allocation-class)) + :type type)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -679,11 +660,12 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-emit-setimm (val) +(defsubst comp-emit-setimm (val) "Set constant VAL to current slot." - (let ((rel-idx (comp-add-const-to-relocs val))) - (cl-assert (numberp rel-idx)) - (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) + (comp-add-const-to-relocs val) + ;; Leave relocation index nil on purpose, will be fixed-up in final + ;; by `comp-finalize-relocs'. + (comp-emit `(setimm ,(comp-slot) nil ,val))) (defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. @@ -1281,13 +1263,11 @@ Top-level forms for the current context are rendered too." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type - (alloc-class comp-curr-allocation-class)) +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) (let ((mvar (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type - :alloc-class alloc-class))) + :type type))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) @@ -1674,10 +1654,11 @@ Here goes everything that can be done not iteratively (read once). ;; pruning in order to be sure that this is not dead-code. This ;; is now left to gcc, to be implemented only if we want a ;; reliable diagnostic here. - (let ((values (apply f (mapcar #'comp-mvar-constant args)))) + (let ((value (apply f (mapcar #'comp-mvar-constant args)))) ;; See `comp-emit-setimm'. + (comp-add-const-to-relocs value) (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs values) values)))))) + (cddr insn) `(nil ,value)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." @@ -1967,15 +1948,47 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. +(defun comp-finalize-container (cont) + "Finalize data container CONT." + (setf (comp-data-container-l cont) + (cl-loop with h = (comp-data-container-idx cont) + for obj each hash-keys of h + for i from 0 + do (puthash obj i h) + collect obj))) + +(defun comp-finalize-relocs () + "Finalize data containers for each relocation class. +Remove immediate duplicates within relocation classes. +Update all insn accordingly." + ;; Symbols imported by C inlined functions. We do this here because + ;; is better to add all objs to the relocation containers before we + ;; compacting them. + (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + + (let* ((d-default (comp-ctxt-d-default comp-ctxt)) + (d-default-idx (comp-data-container-idx d-default)) + (d-impure (comp-ctxt-d-impure comp-ctxt)) + (d-impure-idx (comp-data-container-idx d-impure)) + (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) + (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) + ;; Remove things in d-impure that are already in d-default. + (cl-loop for obj being each hash-keys of d-impure-idx + when (gethash obj d-default-idx) + do (remhash obj d-impure-idx)) + ;; Remove things in d-ephemeral that are already in d-default or + ;; d-impure. + (cl-loop for obj being each hash-keys of d-ephemeral-idx + when (or (gethash obj d-default-idx) (gethash obj d-impure-idx)) + do (remhash obj d-ephemeral-idx)) + ;; Fix-up indexes in each relocation class and fill corresponding + ;; reloc lists. + (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)))) + (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (comp-data-container-check (comp-ctxt-d-default comp-ctxt)) - (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) - (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) - ;; TODO: here we could optimize cleaning up objects present in the - ;; impure and or in the ephemeral container that are also in the - ;; default one. + (comp-finalize-relocs) (unless comp-dry-run (comp--compile-ctxt-to-file name))) diff --git a/src/comp.c b/src/comp.c index 0fc6e412924..bcb0c69986d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -185,6 +185,9 @@ typedef struct { gcc_jit_rvalue *data_relocs_ephemeral; /* Synthesized struct holding func relocs. */ gcc_jit_lvalue *func_relocs; + Lisp_Object d_default_idx; + Lisp_Object d_impure_idx; + Lisp_Object d_ephemeral_idx; } comp_t; static comp_t comp; @@ -197,6 +200,11 @@ typedef struct { const char data[]; } static_obj_t; +typedef struct { + gcc_jit_rvalue *array; + gcc_jit_rvalue *idx; +} imm_reloc_t; + /* Helper functions called by the run-time. @@ -387,18 +395,43 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } -static gcc_jit_rvalue * -alloc_class_to_reloc (Lisp_Object alloc_class) +static imm_reloc_t +obj_to_reloc (Lisp_Object obj) { - if (alloc_class == Qd_default) - return comp.data_relocs; - else if (alloc_class == Qd_impure) - return comp.data_relocs_impure; - else if (alloc_class == Qd_ephemeral) - return comp.data_relocs_ephemeral; - xsignal (Qnative_ice, - build_string ("inconsistent allocation class")); + imm_reloc_t reloc; + Lisp_Object idx; + + idx = Fgethash (obj, comp.d_default_idx, Qnil); + if (!NILP (idx)) { + reloc.array = comp.data_relocs; + goto found; + } + + idx = Fgethash (obj, comp.d_impure_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_impure; + goto found; + } + + idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_ephemeral; + goto found; + } + + xsignal1 (Qnative_ice, + build_string ("cant't find data in relocation containers")); assume (false); + found: + if (!FIXNUMP (idx)) + xsignal1 (Qnative_ice, + build_string ("inconsistent data relocation container")); + reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (idx)); + return reloc; } static void @@ -912,7 +945,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) +emit_const_lisp_obj (Lisp_Object obj) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -922,28 +955,20 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, NULL)); - - Lisp_Object container = CALL1I (comp-alloc-class-to-container, alloc_class); - Lisp_Object reloc_idx = - Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil); - eassert (!NILP (reloc_idx)); - gcc_jit_rvalue *reloc_n = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - XFIXNUM (reloc_idx)); + imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - alloc_class_to_reloc (alloc_class), - reloc_n)); + reloc.array, + reloc.idx)); } static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_default)); + return emit_EQ (x, emit_const_lisp_obj (Qnil)); } static gcc_jit_rvalue * @@ -1046,7 +1071,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp, Qd_default), + emit_const_lisp_obj (Qconsp), x }; gcc_jit_block_add_eval ( @@ -1157,8 +1182,7 @@ emit_mvar_val (Lisp_Object mvar) return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant, - CALL1I (comp-mvar-alloc-class, mvar)); + return emit_const_lisp_obj (constant); } return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); @@ -1193,7 +1217,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_default); + gcc_args[2] = emit_const_lisp_obj (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1571,20 +1595,15 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qsetimm)) { /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ - gcc_jit_rvalue *reloc_n = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - XFIXNUM (arg[1])); emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); + imm_reloc_t reloc = obj_to_reloc (arg[2]); emit_frame_assignment ( arg[0], gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - alloc_class_to_reloc ( - CALL1I (comp-mvar-alloc-class, - arg[0])), - reloc_n))); + reloc.array, + reloc.idx))); } else if (EQ (op, Qcomment)) { @@ -1807,7 +1826,7 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, EMACS_INT d_reloc_len = XFIXNUM (CALL1I (hash-table-count, CALL1I (comp-data-container-idx, container))); - Lisp_Object d_reloc = Fnreverse (CALL1I (comp-data-container-l, container)); + Lisp_Object d_reloc = CALL1I (comp-data-container-l, container); d_reloc = Fvconcat (1, &d_reloc); gcc_jit_rvalue *reloc_struct = @@ -1830,12 +1849,6 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, static void declare_imported_data (void) { - /* Imported symbols by inliner functions. */ - CALL1I (comp-add-const-to-relocs, Qnil); - CALL1I (comp-add-const-to-relocs, Qt); - CALL1I (comp-add-const-to-relocs, Qconsp); - CALL1I (comp-add-const-to-relocs, Qlistp); - /* Imported objects. */ comp.data_relocs = declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt), @@ -2449,11 +2462,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_default)); + emit_const_lisp_obj (Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp, Qd_default), c }; + { emit_const_lisp_obj (Qlistp), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2462,7 +2475,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_default)); + emit_const_lisp_obj (Qnil)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2842,12 +2855,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt, Qd_default)); + emit_const_lisp_obj (Qt)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil, Qd_default)); + emit_const_lisp_obj (Qnil)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ @@ -3206,8 +3219,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); - sigset_t oldset; + comp.d_default_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); + comp.d_impure_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt)); + comp.d_ephemeral_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); + sigset_t oldset; if (!noninteractive) { sigset_t blocked; @@ -3231,8 +3250,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_add1_sub1 (); define_negate (); - struct Lisp_Hash_Table *func_h - = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); + struct Lisp_Hash_Table *func_h = + XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) declare_function (HASH_VALUE (func_h, i)); /* Compile all functions. Can't be done before because the From b41d76fa5e0bce80a3ef92f30243f9c53b9ac6bc Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Sun, 1 Mar 2020 14:42:41 +0000 Subject: [PATCH 0735/1452] Remove relocation index form LIMPLE setimm Given that every object identify a relocation class simplify setimm too. --- lisp/emacs-lisp/comp.el | 8 ++++---- src/comp.c | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7792605fff8..74d352394fb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -665,7 +665,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-add-const-to-relocs val) ;; Leave relocation index nil on purpose, will be fixed-up in final ;; by `comp-finalize-relocs'. - (comp-emit `(setimm ,(comp-slot) nil ,val))) + (comp-emit `(setimm ,(comp-slot) ,val))) (defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. @@ -762,7 +762,7 @@ Return value is the fall through block name." ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn - (`(setimm ,_ ,_ ,jmp-table) + (`(setimm ,_ ,jmp-table) (cl-loop for test being each hash-keys of jmp-table using (hash-value target-label) @@ -1619,7 +1619,7 @@ Here goes everything that can be done not iteratively (read once). (`(,(or 'callref 'direct-callref) ,_f . ,args) (when backward (comp-ref-args-to-array args))) - (`(setimm ,lval ,_ ,v) + (`(setimm ,lval ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v (comp-mvar-type lval) (comp-strict-type-of v))))))) @@ -1658,7 +1658,7 @@ Here goes everything that can be done not iteratively (read once). ;; See `comp-emit-setimm'. (comp-add-const-to-relocs value) (setf (car insn) 'setimm - (cddr insn) `(nil ,value)))))) + (cddr insn) `(,value)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." diff --git a/src/comp.c b/src/comp.c index bcb0c69986d..0b7b2b92615 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1594,9 +1594,9 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ - emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); - imm_reloc_t reloc = obj_to_reloc (arg[2]); + /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) a). */ + emit_comment (SSDATA (Fprin1_to_string (arg[1], Qnil))); + imm_reloc_t reloc = obj_to_reloc (arg[1]); emit_frame_assignment ( arg[0], gcc_jit_lvalue_as_rvalue ( From f60cb02cdfdcf69cc5e463a55f33845b3d862e62 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Feb 2020 17:14:43 +0000 Subject: [PATCH 0736/1452] * Allow for multiple SSA runs Add function ssa-status as `comp-func' slot and have `comp-clean-ssa' to run when necessary. --- lisp/emacs-lisp/comp.el | 51 ++++++++++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 13 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 74d352394fb..9037c23a4f7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -237,6 +237,7 @@ into it.") (closed nil :type boolean :documentation "t if closed.") ;; All the followings are for SSA and CGF analysis. + ;; Keep in sync with `comp-clean-ssa'!! (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list @@ -283,6 +284,10 @@ Is in use to help the SSA rename pass.")) :documentation "Interactive form.") (lap () :type list :documentation "LAP assembly representation.") + (ssa-status nil :type symbol + :documentation "SSA status either: 'nil', 'dirty' or 't'. +Once in SSA form this *must* be set to 'dirty' every time the topology of the +CFG is mutated by a pass.") (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table @@ -1271,6 +1276,22 @@ Top-level forms for the current context are rendered too." (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) +(defun comp-clean-ssa (f) + "Clean-up SSA for funtion F." + (setf (comp-func-edges f) ()) + (cl-loop + for b being each hash-value of (comp-func-blocks f) + do (setf (comp-block-in-edges b) () + (comp-block-out-edges b) () + (comp-block-dom b) nil + (comp-block-df b) (make-hash-table) + (comp-block-post-num b) nil + (comp-block-final-frame b) nil + ;; Prune all phis. + (comp-block-insns b) (cl-loop for insn in (comp-block-insns b) + unless (eq 'phi (car insn)) + collect insn)))) + (defun comp-compute-edges () "Compute the basic block edges for the current function." (cl-flet ((edge-add (&rest args) @@ -1523,22 +1544,25 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for (op . args) in (comp-block-insns b) when (eq op 'phi) - do (finalize-phi args b))))) + do (finalize-phi args b))))) (defun comp-ssa (_) "Port all functions into mininal SSA form." (maphash (lambda (_ f) - (let ((comp-func f)) - ;; TODO: if this is run more than once we should clean all CFG - ;; data including phis here. - (comp-compute-edges) - (comp-compute-dominator-tree) - (comp-compute-dominator-frontiers) - (comp-log-block-info) - (comp-place-phis) - (comp-ssa-rename) - (comp-finalize-phis) - (comp-log-func comp-func 3))) + (let* ((comp-func f) + (ssa-status (comp-func-ssa-status f))) + (unless (eq ssa-status t) + (when (eq ssa-status 'dirty) + (comp-clean-ssa f)) + (comp-compute-edges) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info) + (comp-place-phis) + (comp-ssa-rename) + (comp-finalize-phis) + (comp-log-func comp-func 3) + (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1928,7 +1952,8 @@ These are substituted with a normal 'set' op." (eq l-val ret-val)) (let ((tco-seq (comp-form-tco-call-seq args))) (setf (car insns-seq) (car tco-seq) - (cdr insns-seq) (cdr tco-seq)) + (cdr insns-seq) (cdr tco-seq) + (comp-func-ssa-status comp-func) 'dirty) (cl-return-from in-the-basic-block)))))))) (defun comp-tco (_) From 0cef208cc32c29b143be262fe673e7518b6ef2a8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Feb 2020 17:38:50 +0000 Subject: [PATCH 0737/1452] * Reorganize passes - Make propagate responsible for keeping SSA up to date. - Run propagate-alloc as very last before final not to risk bothering with mvar array allocation during previous tranformations. - Fix SSA if TCO modify the CFG. --- lisp/emacs-lisp/comp.el | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9037c23a4f7..e14f350c2ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -120,12 +120,12 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify - comp-ssa - comp-propagate-1 + comp-propagate comp-call-optim - comp-propagate-2 + comp-propagate comp-dead-code comp-tco + comp-propagate-alloc comp-final) "Passes to be executed in order.") @@ -1546,7 +1546,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-ssa (_) +(defun comp-ssa () "Port all functions into mininal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) @@ -1736,7 +1736,8 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-propagate-iterate (backward) +(defun comp-propagate1 (backward) + (comp-ssa) (when (>= comp-speed 2) (maphash (lambda (_ f) ;; FIXME remove the following condition when tested. @@ -1750,14 +1751,14 @@ Return t if something was changed." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) -(defun comp-propagate-1 (_) +(defun comp-propagate (_) "Forward propagate types and consts within the lattice." - (comp-propagate-iterate nil)) + (comp-propagate1 nil)) -(defun comp-propagate-2 (_) +(defun comp-propagate-alloc (_) "Forward propagate types and consts within the lattice. Backward propagate array placement properties." - (comp-propagate-iterate t)) + (comp-propagate1 t)) ;;; Call optimizer pass specific code. From 0da62d94e2a167d5ccfd8ece03623afdc178154c Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Thu, 6 Feb 2020 20:41:52 +0000 Subject: [PATCH 0738/1452] Change parameter name into comp--compile-ctxt-to-file --- src/comp.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0b7b2b92615..9dcd5547de6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3212,9 +3212,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) - (Lisp_Object ctxtname) + (Lisp_Object base_name) { - CHECK_STRING (ctxtname); + CHECK_STRING (base_name); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -3261,16 +3261,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (COMP_DEBUG) gcc_jit_context_dump_to_file (comp.ctxt, - format_string ("%s.c", SSDATA (ctxtname)), + format_string ("%s.c", SSDATA (base_name)), 1); if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); - Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); + Lisp_Object out_file = CALLN (Fconcat, base_name, dot_so); Lisp_Object tmp_file = - Fmake_temp_file_internal (ctxtname, Qnil, dot_so, Qnil); + Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); From 2dae7e1b697fef389e8e193d60ef799e2b3b09b4 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Thu, 6 Feb 2020 20:23:14 +0000 Subject: [PATCH 0739/1452] Add system-configuration in the compilation output path --- lisp/emacs-lisp/comp.el | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e14f350c2ee..c3e797b9b17 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2014,9 +2014,12 @@ Update all insn accordingly." (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (comp-finalize-relocs) - (unless comp-dry-run - (comp--compile-ctxt-to-file name))) + (let ((dir (file-name-directory name))) + (comp-finalize-relocs) + (unless (file-exists-p dir) + (make-directory dir)) + (unless comp-dry-run + (comp--compile-ctxt-to-file name)))) (defun comp-final (_) "Final pass driving the C back-end for code emission." @@ -2118,9 +2121,17 @@ Return the compilation unit file name." (let ((data input) (comp-native-compiling t) (comp-ctxt (make-comp-ctxt - :output (if (symbolp input) - (make-temp-file (concat (symbol-name input) "-")) - (file-name-sans-extension (expand-file-name input)))))) + :output + (if (symbolp input) + (make-temp-file (concat (symbol-name input) "-")) + (let ((exp-file (expand-file-name input))) + (concat + (file-name-as-directory + (concat + (file-name-directory exp-file) + system-configuration)) + (file-name-sans-extension + (file-name-nondirectory exp-file)))))))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) From 8788fab9e1adf8a4f212a850ebae6845878dbad7 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Wed, 26 Feb 2020 21:36:48 +0000 Subject: [PATCH 0740/1452] ; Nit fix in comment --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 9dcd5547de6..425784b9810 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3275,7 +3275,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* Remove the old eln instead of copying the new one into ti to get + /* Remove the old eln instead of copying the new one into it to get a new inode and prevent crashes in case the old one is currently loaded. */ if (!NILP (Ffile_exists_p (out_file))) From d0066e30615f135d9eebd48b98dddfcb7cf84ed0 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Sat, 29 Feb 2020 08:36:06 +0000 Subject: [PATCH 0741/1452] * Keep comp-subr-list into pure space Sad pure space is not effective nowdays but anyway... should go there. --- src/lread.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index 005528782d0..8b6db92cca9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4405,7 +4405,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETSUBR (tem, sname); set_symbol_function (sym, tem); #ifdef HAVE_NATIVE_COMP - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); + Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list)); #endif } From ce9e3a4ce75acc5450aa39eb4baf601c26aec3fe Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Sat, 29 Feb 2020 08:36:27 +0000 Subject: [PATCH 0742/1452] Introduce 'effective_load_path' --- src/lread.c | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index 8b6db92cca9..6d33bd3e496 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1055,6 +1055,26 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) return Fnreverse (lst); } +static Lisp_Object +effective_load_path (void) +{ + if (!NATIVE_COMP_FLAG) + return Vload_path; + + Lisp_Object lp = Vload_path; + Lisp_Object new_lp = Qnil; + FOR_EACH_TAIL (lp) + { + Lisp_Object el = XCAR (lp); + new_lp = + Fcons (concat2 (Ffile_name_as_directory (el), + Vsystem_configuration), + new_lp); + new_lp = Fcons (el, new_lp); + } + return Fnreverse (new_lp); +} + /* Return true if STRING ends with SUFFIX. */ static bool suffix_p (Lisp_Object string, const char *suffix) @@ -1199,7 +1219,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 (effective_load_path (), file, suffixes, &found, Qnil, + load_prefer_newer); } if (fd == -1) From bf4f620b2f97d218c4d96ff25fa246a4fe32d744 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Sun, 1 Mar 2020 21:10:49 +0000 Subject: [PATCH 0743/1452] * ; Clean-up out of date comment --- lisp/emacs-lisp/comp.el | 4 ---- 1 file changed, 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c3e797b9b17..a9db8c6ff07 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1967,10 +1967,6 @@ These are substituted with a normal 'set' op." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) -;; NOTE: After TCO runs edges, phis etc are not updated. In case some -;; other pass that make use of them after here is added `comp-ssa' -;; should be re-run. - ;;; Final pass specific code. From 286e21c4e86e19bac60f871120df6b51893c5849 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 3 Mar 2020 21:01:37 +0000 Subject: [PATCH 0744/1452] Rework `find-lisp-object-file-name' Rework it for eln new compilation folder layout. --- lisp/help-fns.el | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 2b7534bc78a..e629a408625 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -325,12 +325,19 @@ found via `load-path'. The return value can also be `C-source', which means that OBJECT is a function or variable defined in C. If no suitable file is found, return nil." (let* ((autoloaded (autoloadp type)) - (file-name (or (and autoloaded (nth 1 type)) + (true-name (or (and autoloaded (nth 1 type)) (symbol-file ;; FIXME: Why do we have this weird "If TYPE is the ;; value returned by `symbol-function' for a function ;; symbol" exception? - object (or (if (symbolp type) type) 'defun))))) + object (or (if (symbolp type) type) 'defun)))) + (file-name (if (and true-name + (string-match "[.]eln\\'" true-name)) + (expand-file-name (concat (file-name-base true-name) + ".el") + (concat (file-name-directory true-name) + "..")) + true-name))) (cond (autoloaded ;; An autoloaded function: Locate the file since `symbol-function' @@ -377,7 +384,7 @@ suitable file is found, return nil." ;; This applies to config files like ~/.emacs, ;; which people sometimes compile. ((let (fn) - (and (string-match "\\`\\..*\\.el[cn]\\'" + (and (string-match "\\`\\..*\\.elc\\'" (file-name-nondirectory file-name)) (string-equal (file-name-directory file-name) (file-name-as-directory (expand-file-name "~"))) @@ -386,9 +393,9 @@ suitable file is found, return nil." ;; When the Elisp source file can be found in the install ;; directory, return the name of that file. ((let ((lib-name - (if (string-match "[.]el[cn]\\'" file-name) + (if (string-match "[.]elc\\'" file-name) (substring-no-properties file-name 0 -1) - file-name))) + file-name))) (or (and (file-readable-p lib-name) lib-name) ;; The library might be compressed. (and (file-readable-p (concat lib-name ".gz")) lib-name)))) @@ -399,7 +406,7 @@ suitable file is found, return nil." ;; name, convert that back to a file name and see if we ;; get the original one. If so, they are equivalent. (if (equal file-name (locate-file lib-name load-path '(""))) - (if (string-match "[.]el[cn]\\'" lib-name) + (if (string-match "[.]elc\\'" lib-name) (substring-no-properties lib-name 0 -1) lib-name) file-name)) From f77f6ca77054ca6122df2742345710b7493ad293 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 3 Mar 2020 22:06:08 +0000 Subject: [PATCH 0745/1452] Fix org for eln new compilation folder layout --- lisp/org/org.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/org/org.el b/lisp/org/org.el index f1a7f61a9a1..a9303e880b8 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -78,8 +78,10 @@ (or (eq this-command 'eval-buffer) (condition-case nil - (load (concat (file-name-directory load-file-name) - "org-loaddefs.el") + (load (expand-file-name "org-loaddefs.el" + (if (string-match "[.]eln$" load-file-name) + (concat (file-name-directory load-file-name) "..") + (file-name-directory load-file-name))) nil t t t) (error (message "WARNING: No org-loaddefs.el file could be found from where org.el is loaded.") From 43b6f05dfb46637a414520b27430fbe3b0f005fa Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 3 Mar 2020 22:23:41 +0000 Subject: [PATCH 0746/1452] Hash eln ABI once and add it to the output compilation path --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 29 +++++++++++++++++++++++------ src/comp.h | 4 ++++ src/emacs.c | 5 +++++ src/lread.c | 3 ++- 5 files changed, 35 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a9db8c6ff07..342faa2879e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2125,7 +2125,7 @@ Return the compilation unit file name." (file-name-as-directory (concat (file-name-directory exp-file) - system-configuration)) + comp-native-path-postfix)) (file-name-sans-extension (file-name-nondirectory exp-file)))))))) (comp-log "\n \n" 1) diff --git a/src/comp.c b/src/comp.c index 425784b9810..4940ae52b3d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -250,8 +250,8 @@ format_string (const char *format, ...) /* Produce a key hashing Vcomp_subr_list. */ -static Lisp_Object -hash_subr_list (void) +void +hash_native_abi (void) { Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string (" ")); @@ -260,7 +260,17 @@ hash_subr_list (void) sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); - return digest; + /* Check runs once. */ + eassert (Vcomp_abi_hash); + Vcomp_abi_hash = digest; + /* If 10 characters are usually sufficient for git I guess 16 are + fine for us here. */ + Vcomp_native_path_postfix = + concat3 (Vsystem_configuration, + make_string ("-", 1), + Fsubstring_no_properties (Vcomp_abi_hash, + make_fixnum (0), + make_fixnum (16))); } static void @@ -1976,8 +1986,9 @@ emit_ctxt_code (void) fields[n_frelocs++] = xmint_pointer (XCDR (el)); } - /* Compute and store function link table hash. */ - emit_static_object (LINK_TABLE_HASH_SYM, hash_subr_list ()); + /* Sign the .eln for the exposed ABI it expects at load. */ + eassert (!NILP (Vcomp_abi_hash)); + emit_static_object (LINK_TABLE_HASH_SYM, Vcomp_abi_hash); Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) @@ -3430,7 +3441,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) && freloc_link_table && top_level_run) || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), - hash_subr_list ()))) + Vcomp_abi_hash))) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; @@ -3657,6 +3668,12 @@ syms_of_comp (void) doc: /* Hash table symbol-function -> function-c-name. For internal use during */); Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, + doc: /* String signing the ABI exposed to .eln files. */); + Vcomp_abi_hash = Qnil; + DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, + doc: /* Postifix to be added to the .eln compilation path. */); + Vcomp_native_path_postfix = Qnil; } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/comp.h b/src/comp.h index 3aff440ecb7..070ec4d5ca9 100644 --- a/src/comp.h +++ b/src/comp.h @@ -61,8 +61,12 @@ XNATIVE_COMP_UNIT (Lisp_Object a) } /* Defined in comp.c. */ + +extern void hash_native_abi (void); + extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); + #endif #endif diff --git a/src/emacs.c b/src/emacs.c index da08aeb9022..b16ffa4295e 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1949,6 +1949,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem keys_of_keyboard (); keys_of_keymap (); keys_of_window (); + +#ifdef HAVE_NATIVE_COMP + /* Must be after the last defsubr has run. */ + hash_native_abi (); +#endif } else { diff --git a/src/lread.c b/src/lread.c index 6d33bd3e496..acd2fea6881 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1068,7 +1068,7 @@ effective_load_path (void) Lisp_Object el = XCAR (lp); new_lp = Fcons (concat2 (Ffile_name_as_directory (el), - Vsystem_configuration), + Vcomp_native_path_postfix), new_lp); new_lp = Fcons (el, new_lp); } @@ -4427,6 +4427,7 @@ defsubr (union Aligned_Lisp_Subr *aname) 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 } From 1f3ba658fccdb0b35bdbbdfeb8591dba72ee983f Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Tue, 3 Mar 2020 23:06:46 +0000 Subject: [PATCH 0747/1452] * Do not crash if the output directory is created in the meanwhile --- lisp/emacs-lisp/comp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 342faa2879e..f16aa59dc5e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2013,7 +2013,9 @@ Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) (comp-finalize-relocs) (unless (file-exists-p dir) - (make-directory dir)) + ;; In case it's created in the meanwhile. + (ignore-error 'file-already-exists + (make-directory dir))) (unless comp-dry-run (comp--compile-ctxt-to-file name)))) From dc89f3a0df1013c7c5fcb3cff6da27fa0263f007 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 4 Mar 2020 21:52:38 +0000 Subject: [PATCH 0748/1452] * Fix build for stock configuration Vcomp_native_path_postfix is declared only in native configuration. --- src/lread.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/lread.c b/src/lread.c index acd2fea6881..32c83bfae8b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1058,9 +1058,9 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) static Lisp_Object effective_load_path (void) { - if (!NATIVE_COMP_FLAG) - return Vload_path; - +#ifndef HAVE_NATIVE_COMP + return Vload_path; +#else Lisp_Object lp = Vload_path; Lisp_Object new_lp = Qnil; FOR_EACH_TAIL (lp) @@ -1073,6 +1073,7 @@ effective_load_path (void) new_lp = Fcons (el, new_lp); } return Fnreverse (new_lp); +#endif } /* Return true if STRING ends with SUFFIX. */ From e4b5bd990b5a4b658f0e38451f0a910d4515a968 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 6 Mar 2020 21:16:43 +0000 Subject: [PATCH 0749/1452] * Add test-native-bootstrap as CI test --- .gitlab-ci.yml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9a62137c168..7b31810fd33 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -65,3 +65,14 @@ test-filenotify-gio: - ./configure --without-makeinfo --with-file-notification=gfile - make bootstrap - make -C test autorevert-tests filenotify-tests + +test-native-bootstrap: + # Test native bootstrap + stage: test + 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 From cd9c1e48890f935731a6bfb3d5106fa42df08258 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Mar 2020 19:12:36 +0000 Subject: [PATCH 0750/1452] * Raise timeout for test-native-bootstrap CI test and build with -j2 --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7b31810fd33..51968a158fa 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -75,4 +75,5 @@ test-native-bootstrap: - 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 + - make bootstrap -j2 + timeout: 10 hours From 6c3efad161dcccf28bf6db1b0b714b012059e719 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Mar 2020 12:34:43 +0000 Subject: [PATCH 0751/1452] * test-native-bootstrap CI test configured for speed 0 Run for now only speed 0 to limit memory usage and compilation time. --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 51968a158fa..d081bb7c474 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -68,6 +68,7 @@ test-filenotify-gio: test-native-bootstrap: # Test native bootstrap + # Run for now only speed 0 to limit memory usage and compilation time. stage: test only: - schedules @@ -75,5 +76,5 @@ test-native-bootstrap: - 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 -j2 + - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 timeout: 10 hours From f055f523216d6aa5fe2b59984e0aed81ca80b66e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Mar 2020 21:30:28 +0000 Subject: [PATCH 0752/1452] * Fix two find function functions for native compilation `find-function-library' and `find-library-name' gets fixed for new eln compilation directory layout. --- lisp/emacs-lisp/find-func.el | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 86b5e5456f0..21c10029ac4 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -184,8 +184,15 @@ See the functions `find-function' and `find-variable'." 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\\([cn]\\(\\..*\\)?\\)\\'" library) + (cond + ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) + ((string-match "\\.eln$" library) + ;; From help-fns.el. + (setq library (expand-file-name (concat (file-name-base library) + ".el") + (concat (file-name-directory library) + ".."))))) (or (locate-file library (or find-function-source-path load-path) @@ -439,7 +446,7 @@ message about the whole chain of aliases." (cons function (cond ((autoloadp def) (nth 1 def)) - ((subrp def) + ((and (subrp def) (not (subr-native-elisp-p def))) (if lisp-only (error "%s is a built-in function" function)) (help-C-file-name def 'subr)) From 4c8a84002f4c1a2d30f96fa451dd221605ab84e3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Mar 2020 21:40:51 +0000 Subject: [PATCH 0753/1452] * New native-comp CI setup - Disable 'test-all' till is known to be broken in this branch. - Run 'test-native-bootstrap' always (not only when scheduled). - Set 'test-native-bootstrap' timeout to 3 hours. --- .gitlab-ci.yml | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d081bb7c474..5069ad5fe00 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -37,15 +37,16 @@ before_script: stages: - test -test-all: - # This tests also file monitor libraries inotify and inotifywatch. - stage: test - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools - - ./autogen.sh autoconf - - ./configure --without-makeinfo - - make bootstrap - - make check-expensive +# FIXME: Commented for this branch till is known to be broken. +# test-all: +# # This tests also file monitor libraries inotify and inotifywatch. +# stage: test +# script: +# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools +# - ./autogen.sh autoconf +# - ./configure --without-makeinfo +# - make bootstrap +# - make check-expensive test-filenotify-gio: stage: test @@ -70,11 +71,12 @@ test-native-bootstrap: # Test native bootstrap # Run for now only speed 0 to limit memory usage and compilation time. stage: test - only: - - schedules + # 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 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 - timeout: 10 hours + timeout: 3 hours From dc7ccfaf0fe7580afb59e0ebe5b44123f5c4c586 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Mar 2020 22:33:54 +0000 Subject: [PATCH 0754/1452] * Fix typo into pdumper integration --- src/pdumper.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/pdumper.c b/src/pdumper.c index 71551d7c709..4ecdea14538 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5320,7 +5320,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, error ("missing label name"); void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); if (!func) - error ("can't function in compilation unit"); + error ("can't find function in compilation unit"); subr->function.a0 = func; break; } From 9838ee7ed870844470703b2648f8b59c0575bd46 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Mar 2020 07:47:57 +0000 Subject: [PATCH 0755/1452] * Fix regexp instroduced by f055f52321 --- lisp/emacs-lisp/find-func.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 21c10029ac4..fa87b255699 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -187,7 +187,7 @@ LIBRARY should be a string (the name of the library)." (cond ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) - ((string-match "\\.eln$" library) + ((string-match "\\.eln\\'" library) ;; From help-fns.el. (setq library (expand-file-name (concat (file-name-base library) ".el") From f21e1dfc9f9addf66e6913cd30fbd7f922510ede Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Mon, 9 Mar 2020 17:35:07 +0000 Subject: [PATCH 0756/1452] * Set relocation class as ephemeral in `comp-limplify-top-level' --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f16aa59dc5e..808a705a5cb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1154,8 +1154,8 @@ functions 'top_level_run' will call back `comp--register-subr' into the C code forwarding the compilation unit." ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no ;; reasons to be execute ever again. Therefore all objects can be - ;; just impure. - (let* ((comp-curr-allocation-class 'd-impure) + ;; just ephemeral. + (let* ((comp-curr-allocation-class 'd-ephemeral) (func (make-comp-func :name 'top-level-run :c-name "top_level_run" :args (make-comp-args :min 1 :max 1) From 2cf4b81009eeedd1b441af093c0ca147d0d9bbb9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 9 Mar 2020 10:45:51 +0000 Subject: [PATCH 0757/1452] * Fix GC mark for native compiled functions native_intspec and native_doc fields has to be reached by the subr cause are not anymore in the CU. --- src/alloc.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 9a01edca3f8..ac173077132 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6683,9 +6683,9 @@ mark_object (Lisp_Object arg) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - obj = subr->native_comp_u[0]; - eassert (obj); - goto loop; + mark_object (subr->native_intspec); + mark_object (subr->native_doc); + mark_object (subr->native_comp_u[0]); } break; From e23856167be46d7817ba02238e25dce37183bd2a Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Mon, 9 Mar 2020 16:51:15 +0000 Subject: [PATCH 0758/1452] * Fix store_function_docstring for for native functions Do not Nil native_doc fields. This will be naturally dumped by pdumper. This was affecting dumped functions. --- src/doc.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/doc.c b/src/doc.c index 192e2011093..1b6aa01ef04 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,12 +510,8 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - else if (SUBR_NATIVE_COMPILEDP (fun)) - { - XSUBR (fun)->native_doc = Qnil; - } /* Lisp_Subrs have a slot for it. */ - else if (SUBRP (fun)) + else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->doc = offset; } From 566f0f1b639c7cba5b7d6763fb13aa42a5cc4535 Mon Sep 17 00:00:00 2001 From: AndreaCorallo Date: Mon, 9 Mar 2020 22:00:37 +0000 Subject: [PATCH 0759/1452] * Improve load_comp_unit Fix uninitialized ephemeral data relocation for the case when a dumped compilation unit is manually reloaded. Guard also data_ephemeral_vec against compiler optimizations. --- src/comp.c | 47 ++++++++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4940ae52b3d..8176ba259ed 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3388,6 +3388,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); bool reloading_cu = *saved_cu ? true : false; + Lisp_Object *data_eph_relocs = + dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); /* While resurrecting from an image dump loading more than once the same compilation unit does not make any sense. */ @@ -3419,19 +3421,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); - Lisp_Object *data_eph_relocs = - dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); - Lisp_Object volatile data_ephemeral_vec; - - /* Note: data_ephemeral_vec is not GC protected except than by - this function frame. After this functions will be - deactivated GC will be free to collect it, but it MUST - survive till 'top_level_run' has finished his job. We store - into the ephemeral allocation class only objects that we know - are necessary exclusively during the first load. Once these - are collected we don't have to maintain them in the heap - forever. */ if (!(current_thread_reloc && pure_reloc @@ -3457,12 +3447,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); - data_ephemeral_vec = - load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); - - EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_eph_relocs[i] = AREF (data_ephemeral_vec, i); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3479,9 +3463,30 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) } if (!loading_dump) - /* Executing this will perform all the expected environment - modifications. */ - top_level_run (comp_u_lisp_obj); + { + /* Note: data_ephemeral_vec is not GC protected except than by + this function frame. After this functions will be + deactivated GC will be free to collect it, but it MUST + survive till 'top_level_run' has finished his job. We store + into the ephemeral allocation class only objects that we know + are necessary exclusively during the first load. Once these + are collected we don't have to maintain them in the heap + forever. */ + + Lisp_Object volatile data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); + + /* Executing this will perform all the expected environment + modifications. */ + top_level_run (comp_u_lisp_obj); + /* Make sure data_ephemeral_vec still exists after top_level_run has run. + Guard against sibling call optimization (or any other). */ + data_ephemeral_vec = data_ephemeral_vec; + } return; } From ab8fed0a96a55107895e6105e7b0e4b6735156d7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Mar 2020 22:36:39 +0000 Subject: [PATCH 0760/1452] * Do not produce .eln files when a byte compilation error happen Have the byte compiler signal an error when compilation fails to stop native compilation too. --- lisp/emacs-lisp/comp.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 808a705a5cb..64eb46cc38d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2118,6 +2118,9 @@ Return the compilation unit file name." (list "not a symbol function or file" input))) (let ((data input) (comp-native-compiling t) + ;; Have the byte compiler signal an error when compilation + ;; fails. + (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) From 144e8f64b69e01a6c870574d04c92368f0056dd0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 13 Mar 2020 22:16:21 +0000 Subject: [PATCH 0761/1452] Prefix native compilation folders with "eln-" --- lisp/emacs-lisp/comp.el | 1 + src/comp.c | 11 ++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 64eb46cc38d..0779373667d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2126,6 +2126,7 @@ Return the compilation unit file name." (if (symbolp input) (make-temp-file (concat (symbol-name input) "-")) (let ((exp-file (expand-file-name input))) + (cl-assert comp-native-path-postfix) (concat (file-name-as-directory (concat diff --git a/src/comp.c b/src/comp.c index 8176ba259ed..b9ecef07f32 100644 --- a/src/comp.c +++ b/src/comp.c @@ -266,11 +266,12 @@ hash_native_abi (void) /* If 10 characters are usually sufficient for git I guess 16 are fine for us here. */ Vcomp_native_path_postfix = - concat3 (Vsystem_configuration, - make_string ("-", 1), - Fsubstring_no_properties (Vcomp_abi_hash, - make_fixnum (0), - make_fixnum (16))); + concat3 (make_string ("eln-", 4), + Vsystem_configuration, + concat2 (make_string ("-", 1), + Fsubstring_no_properties (Vcomp_abi_hash, + make_fixnum (0), + make_fixnum (16)))); } static void From dab8dd836cb7c714cebae155f41e21fd824acaea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Mar 2020 10:57:34 +0000 Subject: [PATCH 0762/1452] Fix make bootstrap for native compilation Add Makefile target native-compile-clean removing all eln output folders. This is also triggered by make bootstrap to perform a clean bootstrap. Also revert some modification of the build system against master not effective anymore with the new directory layout. --- lisp/Makefile.in | 17 ++++++++++------- src/Makefile.in | 2 +- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index fdd39d5fd54..8ba619656d8 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -356,6 +356,13 @@ compile-main: gen-lisp compile-clean $(MAKE) compile-targets TARGETS="$$chunk"; \ done +.PHONY: native-compile-clean +native-compile-clean: +# Erase all eln output compilation folders. +ifeq ($(HAVE_NATIVE_COMP),yes) + find $(lisp) -regex ".*/eln-.*-[0-9a-z]+\\'" -type d | xargs rm -rf +endif + .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -366,10 +373,6 @@ compile-clean: echo rm "$${el}c"; \ rm "$${el}c"; \ fi; \ - if test -f "$$el" || test ! -f "$${el}n"; then :; else \ - echo rm "$${el}n"; \ - rm "$${el}n"; \ - fi; \ done .PHONY: gen-lisp leim semantic @@ -396,7 +399,7 @@ compile: $(LOADDEFS) autoloads compile-first # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they # set the local variable no-byte-compile. -compile-always: +compile-always: native-compile-clean find $(lisp) -name '*.elc' $(FIND_DELETE) $(MAKE) compile @@ -486,8 +489,8 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el .PHONY: bootstrap-clean distclean maintainer-clean extraclean -bootstrap-clean: - find $(lisp) -regex '.*\.elc\|.*\.eln' $(FIND_DELETE) +bootstrap-clean: native-compile-clean + find $(lisp) -name '*.elc' $(FIND_DELETE) rm -f $(AUTOGENEL) distclean: diff --git a/src/Makefile.in b/src/Makefile.in index 52d8ddd4e5d..8d7fdb8a607 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -327,7 +327,7 @@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ LIBGCCJIT = @LIBGCCJIT_LIB@ -## dynlib.o comp.o if native compiler is enabled, else empty +## dynlib.o comp.o if native compiler is enabled, otherwise empty. COMP_OBJ = @COMP_OBJ@ RUN_TEMACS = ./temacs From 46a4ca4774e27f76c93277db187df31aa6e1cf2e Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Sun, 15 Mar 2020 10:19:22 +0000 Subject: [PATCH 0763/1452] comp.el: Minor improvements Change: (comp-start-async-worker) Refactor slightly Change: (comp-start-async-worker) Inline (comp-to-file-p) Change: (comp-source-files) Rename from comp-src-pool Add: (comp-start-async-worker) Assertion Change: (comp-async-processes) Rename from comp-prc-pool Tidy: (native-compile) Rename variables, improve docstring, adjust log message, simplify filename code. Tidy: (batch-native-compile) Docstring Tidy: whitespace-cleanup Tidy: (comp-start-async-worker) Use () instead of nil Tidy: (comp-files-queue) Rename from comp-source-files Change: (native-compile-async) Improve paths support Tidy: Comment Save a line for one word. :) Change: (comp-log) Rewrite without macro, follow tail Change: (native-compile-async) Use end-of-string in filename regexps Change: (native-compile-async) Use cl-loop instead of dotimes Add/Change: (comp-log-to-buffer) And use in comp-log Comment: Tidy comment Fix: (configure.ac) Option description Fix: (comp-log) Argument Fix: (comp-start-async-worker) Variable name Change: Undo whitespace changes Some of them included incorrect indentation because the macros' (declare (indent)) forms were not loaded. The whitespace-cleanup should be run from Emacs 27+ with the file loaded. --- configure.ac | 2 +- lisp/emacs-lisp/comp.el | 245 +++++++++++++++++++++------------------- 2 files changed, 131 insertions(+), 116 deletions(-) diff --git a/configure.ac b/configure.ac index 0b2f5b69d6b..393a53d7633 100644 --- a/configure.ac +++ b/configure.ac @@ -463,7 +463,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([nativecomp],[don't compile with emacs lisp native compiler support]) +OPTION_DEFAULT_OFF([nativecomp],[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)])], diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0779373667d..2ce530ee592 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -356,34 +356,44 @@ Assume allocaiton class 'd-default as default." (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container comp-curr-allocation-class)))) -(defmacro comp-within-log-buff (&rest body) - "Execute BODY while at the end the log-buffer. -BODY is evaluate only if `comp-verbose' is > 0." - (declare (debug (form body)) - (indent defun)) - `(when (> comp-verbose 0) - (with-current-buffer (get-buffer-create comp-log-buffer-name) - (setf buffer-read-only t) - (let ((inhibit-read-only t)) - (goto-char (point-max)) - ,@body)))) - -(defun comp-log (data verbosity) - "Log DATA given VERBOSITY." - (when (>= comp-verbose verbosity) +(cl-defun comp-log (data &optional (level 1)) + "Log DATA at LEVEL. +LEVEL is a number from 1-3; if it is less than `comp-verbose', do +nothing. If `noninteractive', log with `message'. Otherwise, +log with `comp-log-to-buffer'." + (when (>= comp-verbose level) (if noninteractive - (if (atom data) - (message "%s" data) - (mapc (lambda (x) - (message "%s"(prin1-to-string x))) - data)) - (comp-within-log-buff - (if (and data (atom data)) - (insert data) - (mapc (lambda (x) - (insert (prin1-to-string x) "\n")) - data) - (insert "\n")))))) + (cl-typecase data + (atom (message "%s" data)) + (t (dolist (elem data) + (message "%s" elem)))) + (comp-log-to-buffer data)))) + +(cl-defun comp-log-to-buffer (data) + "Log DATA to `comp-log-buffer-name'." + (let* ((log-buffer + (or (get-buffer comp-log-buffer-name) + (with-current-buffer (get-buffer-create comp-log-buffer-name) + (setf buffer-read-only t) + (current-buffer)))) + (log-window (get-buffer-window log-buffer)) + (inhibit-read-only t) + at-end-p) + (with-current-buffer log-buffer + (when (= (point) (point-max)) + (setf at-end-p t)) + (save-excursion + (goto-char (point-max)) + (cl-typecase data + (atom (princ data log-buffer)) + (t (dolist (elem data) + (princ elem log-buffer) + (insert "\n")))) + (insert "\n")) + (when (and at-end-p log-window) + ;; When log window's point is at the end, follow the tail. + (with-selected-window log-window + (goto-char (point-max))))))) (defun comp-log-func (func verbosity) "Log function FUNC. @@ -2052,105 +2062,108 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. -(defvar comp-src-pool () - "List containing the files to be compiled.") +(defvar comp-files-queue () + "List of Elisp files to be compiled.") -(defvar comp-prc-pool () - "List containing all async compilation processes.") +(defvar comp-async-processes () + "List of running async compilation processes.") -(defun comp-to-file-p (file) - "Return t if FILE has to be compiled." - (let ((compiled-f (concat file "n"))) - (or comp-always-compile - (not (and (file-exists-p compiled-f) - (file-newer-than-file-p compiled-f file)))))) - -(cl-defun comp-start-async-worker () - "Run an async compile worker." - (let (f) - (while (setf f (pop comp-src-pool)) - (when (comp-to-file-p f) - (let* ((code `(progn - (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - load-path ',load-path) - (message "Compiling %s started." ,f) - (native-compile ,f)))) - (push (make-process :name (concat "Compiling: " f) - :buffer (get-buffer-create comp-async-buffer-name) - :command (list (concat invocation-directory - invocation-name) - "--batch" - "--eval" - (prin1-to-string code)) - :sentinel (lambda (prc _event) - (run-hook-with-args - 'comp-async-cu-done-hook - f) - (accept-process-output prc) - (comp-start-async-worker))) - comp-prc-pool) - (cl-return-from comp-start-async-worker)))) - (when (cl-notany #'process-live-p comp-prc-pool) +(defun comp-start-async-worker () + "Start compiling files from `comp-files-queue' asynchronously. +When compilation is finished, run `comp-async-all-done-hook' and +display a message." + (if comp-files-queue + (cl-loop + for source-file = (pop comp-files-queue) + while source-file + do (cl-assert (string-match-p (rx ".el" eos) source-file) nil + "`comp-files-queue' should be \".el\" files: %s" + source-file) + when (or comp-always-compile + (file-newer-than-file-p source-file (concat source-file "n"))) + do (let* ((expr `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + load-path ',load-path) + (message "Compiling %s..." ,source-file) + (native-compile ,source-file))) + (process (make-process + :name (concat "Compiling: " source-file) + :buffer (get-buffer-create comp-async-buffer-name) + :command (list + (expand-file-name invocation-name + invocation-directory) + "--batch" "--eval" (prin1-to-string expr)) + :sentinel (lambda (process _event) + (run-hook-with-args + 'comp-async-cu-done-hook + source-file) + (accept-process-output process) + (comp-start-async-worker))))) + (push process comp-async-processes))) + ;; No files left to compile. + (when (cl-notany #'process-live-p comp-async-processes) (let ((msg "Compilation finished.")) - (setf comp-prc-pool ()) + (setf comp-async-processes ()) (run-hooks 'comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion (goto-char (point-max)) (insert msg "\n"))) (message msg))))) + ;;; Compiler entry points. ;;;###autoload -(defun native-compile (input) - "Compile INPUT into native code. +(defun native-compile (function-or-file) + "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. -If INPUT is a symbol, native compile its function definition. -If INPUT is a string, use it as the file path to be native compiled. +FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. Return the compilation unit file name." - (unless (or (symbolp input) - (stringp input)) + (unless (or (functionp function-or-file) + (stringp function-or-file)) (signal 'native-compiler-error - (list "not a symbol function or file" input))) - (let ((data input) - (comp-native-compiling t) - ;; Have the byte compiler signal an error when compilation - ;; fails. - (byte-compile-debug t) - (comp-ctxt (make-comp-ctxt - :output - (if (symbolp input) - (make-temp-file (concat (symbol-name input) "-")) - (let ((exp-file (expand-file-name input))) - (cl-assert comp-native-path-postfix) - (concat - (file-name-as-directory - (concat - (file-name-directory exp-file) - comp-native-path-postfix)) - (file-name-sans-extension - (file-name-nondirectory exp-file)))))))) + (list "Not a function symbol or file" function-or-file))) + (let* ((data function-or-file) + (comp-native-compiling t) + ;; Have byte compiler signal an error when compilation fails. + (byte-compile-debug t) + (comp-ctxt + (make-comp-ctxt + :output + (if (symbolp function-or-file) + (make-temp-file (concat (symbol-name function-or-file) "-")) + (let* ((expanded-filename (expand-file-name function-or-file)) + (output-dir (file-name-as-directory + (concat (file-name-directory expanded-filename) + comp-native-path-postfix))) + (output-filename + (file-name-sans-extension + (file-name-nondirectory expanded-filename)))) + (expand-file-name output-filename output-dir)))))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) - (comp-log (format "Running pass %s:\n" pass) 2) + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) (setf data (funcall pass data))) comp-passes) (native-compiler-error ;; Add source input. (let ((err-val (cdr err))) - (signal (car err) (if (consp err-val) - (cons input err-val) - (list input err-val)))))) + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val)))))) data)) ;;;###autoload (defun batch-native-compile () - "Ultra cheap impersonation of `batch-byte-compile'." + "Run `native-compile' on remaining command-line arguments. +Ultra cheap impersonation of `batch-byte-compile'." (mapc #'native-compile command-line-args-left)) ;;;###autoload @@ -2169,23 +2182,25 @@ Always generate elc files too and handle native compiler expected errors." (rename-file tempfile target-file t)))))) ;;;###autoload -(defun native-compile-async (input &optional jobs recursively) - "Compile INPUT asynchronously. -INPUT can be either a list of files a folder or a file. -JOBS specifies the number of jobs (commands) to run simultaneously (1 default). -Follow folders RECURSIVELY if non nil." - (let ((jobs (or jobs 1)) - (files (if (listp input) - input - (if (file-directory-p input) - (if recursively - (directory-files-recursively input "\\.el$") - (directory-files input t "\\.el$")) - (if (file-exists-p input) - (list input) - (signal 'native-compiler-error - "input not a file nor directory")))))) - (setf comp-src-pool (nconc files comp-src-pool)) +(cl-defun native-compile-async (paths &optional (jobs 1) recursively) + "Compile PATHS asynchronously. +PATHS is one path or a list of paths to files or directories. +JOBS specifies the number of jobs (commands) to run +simultaneously (1 default). If RECURSIVELY, recurse into +subdirectories of given directories." + (unless (listp paths) + (setf paths (list paths))) + (let (files) + (dolist (path paths) + (cond ((file-directory-p path) + (dolist (file (if recursively + (directory-files-recursively path (rx ".el" eos)) + (directory-files path t (rx ".el" eos)))) + (push file files))) + ((file-exists-p path) (push path files)) + (t (signal 'native-compiler-error + (list "Path not a file nor directory" path))))) + (setf comp-files-queue (nconc files comp-files-queue)) (cl-loop repeat jobs do (comp-start-async-worker)) (message "Compilation started."))) From 7359f9e36366221a03e3516375ec415d6df4df65 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 10:26:31 +0000 Subject: [PATCH 0764/1452] * comp.el: Fix missing rx require --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ce530ee592..0a6a92573f2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -29,10 +29,11 @@ ;;; Code: (require 'bytecomp) -(require 'gv) -(require 'cl-lib) (require 'cl-extra) +(require 'cl-lib) (require 'cl-macs) +(require 'gv) +(require 'rx) (require 'subr-x) (defgroup comp nil From 62bc0c2d7a24e3635b3611a95deb5013971759e2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 10:27:38 +0000 Subject: [PATCH 0765/1452] * .gitlab-ci.yml: Always run test-filenotify-gio test-filenotify-gio is run always to keep stock bootstrap tested. --- .gitlab-ci.yml | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5069ad5fe00..fa613bb412c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -51,15 +51,17 @@ stages: test-filenotify-gio: stage: test # This tests file monitor libraries gfilemonitor and gio. - only: - changes: - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el + + ## Commented to keep stock bootstrap tested. + # only: + # changes: + # - .gitlab-ci.yml + # - lisp/autorevert.el + # - lisp/filenotify.el + # - lisp/net/tramp-sh.el + # - src/gfilenotify.c + # - test/lisp/autorevert-tests.el + # - test/lisp/filenotify-tests.el script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 - ./autogen.sh autoconf From 92fdfa4b5a468d9560e21a5a22a83847fd8ca2c7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 19:37:51 +0000 Subject: [PATCH 0766/1452] * comp.el: Make compilation logic to be dynamically controllable Introduce `comp-async-jobs-number' to control async job number, this can be now adjusted dynamically. Also make `native-compile-async' able to dynamically queue new compilations. --- lisp/emacs-lisp/comp.el | 111 +++++++++++++++++++++++----------------- 1 file changed, 63 insertions(+), 48 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a6a92573f2..f47d3ce470e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,6 +85,11 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) +(defcustom comp-async-jobs-number 2 + "Default number of processes used for async compilation." + :type 'fixnum + :group 'comp) + (defcustom comp-async-cu-done-hook nil "This hook is run whenever an asyncronous native compilation finishes compiling a single compilation unit. @@ -2069,51 +2074,61 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-async-processes () "List of running async compilation processes.") -(defun comp-start-async-worker () +(defun comp-async-runnings () + "Return the number of async compilations currently running. +This function has the side effect of cleaning-up finished +processes from `comp-async-processes'" + (setf comp-async-processes + (cl-delete-if-not #'process-live-p comp-async-processes)) + (length comp-async-processes)) + +(defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. When compilation is finished, run `comp-async-all-done-hook' and display a message." - (if comp-files-queue - (cl-loop - for source-file = (pop comp-files-queue) - while source-file - do (cl-assert (string-match-p (rx ".el" eos) source-file) nil - "`comp-files-queue' should be \".el\" files: %s" - source-file) - when (or comp-always-compile - (file-newer-than-file-p source-file (concat source-file "n"))) - do (let* ((expr `(progn - (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - load-path ',load-path) - (message "Compiling %s..." ,source-file) - (native-compile ,source-file))) - (process (make-process - :name (concat "Compiling: " source-file) - :buffer (get-buffer-create comp-async-buffer-name) - :command (list - (expand-file-name invocation-name - invocation-directory) - "--batch" "--eval" (prin1-to-string expr)) - :sentinel (lambda (process _event) - (run-hook-with-args - 'comp-async-cu-done-hook - source-file) - (accept-process-output process) - (comp-start-async-worker))))) - (push process comp-async-processes))) - ;; No files left to compile. - (when (cl-notany #'process-live-p comp-async-processes) - (let ((msg "Compilation finished.")) - (setf comp-async-processes ()) - (run-hooks 'comp-async-all-done-hook) - (with-current-buffer (get-buffer-create comp-async-buffer-name) - (save-excursion - (goto-char (point-max)) - (insert msg "\n"))) - (message msg))))) + (if (or comp-files-queue + (> (comp-async-runnings) 0)) + (unless (>= (comp-async-runnings) comp-async-jobs-number) + (cl-loop + for source-file = (pop comp-files-queue) + while source-file + do (cl-assert (string-match-p (rx ".el" eos) source-file) nil + "`comp-files-queue' should be \".el\" files: %s" + source-file) + when (or comp-always-compile + (file-newer-than-file-p source-file (concat source-file "n"))) + do (let* ((expr `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + load-path ',load-path) + (message "Compiling %s..." ,source-file) + (native-compile ,source-file))) + (process (make-process + :name (concat "Compiling: " source-file) + :buffer (get-buffer-create comp-async-buffer-name) + :command (list + (expand-file-name invocation-name + invocation-directory) + "--batch" "--eval" (prin1-to-string expr)) + :sentinel (lambda (process _event) + (run-hook-with-args + 'comp-async-cu-done-hook + source-file) + (accept-process-output process) + (comp-run-async-workers))))) + (push process comp-async-processes)) + when (>= (comp-async-runnings) comp-async-jobs-number) + do (cl-return))) + ;; No files left to compile and all processes finished. + (let ((msg "Compilation finished.")) + (run-hooks 'comp-async-all-done-hook) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (save-excursion + (goto-char (point-max)) + (insert msg "\n"))) + (message msg)))) ;;; Compiler entry points. @@ -2183,12 +2198,12 @@ Always generate elc files too and handle native compiler expected errors." (rename-file tempfile target-file t)))))) ;;;###autoload -(cl-defun native-compile-async (paths &optional (jobs 1) recursively) +(defun native-compile-async (paths recursively) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. -JOBS specifies the number of jobs (commands) to run -simultaneously (1 default). If RECURSIVELY, recurse into -subdirectories of given directories." +`comp-async-jobs-number' specifies the number of (commands) to +run simultaneously. If RECURSIVELY, recurse into subdirectories +of given directories." (unless (listp paths) (setf paths (list paths))) (let (files) @@ -2202,8 +2217,8 @@ subdirectories of given directories." (t (signal 'native-compiler-error (list "Path not a file nor directory" path))))) (setf comp-files-queue (nconc files comp-files-queue)) - (cl-loop repeat jobs - do (comp-start-async-worker)) + (when (zerop (comp-async-runnings)) + (comp-run-async-workers)) (message "Compilation started."))) (provide 'comp) From 0b28bf0529cc6e6125924cc54ba8de30f3872ab9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 20:17:15 +0000 Subject: [PATCH 0767/1452] * comp.el: Estimate async worker number using system CPU number This only when `comp-async-jobs-number' is 0 (default). --- lisp/emacs-lisp/comp.el | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f47d3ce470e..68d3b8b2c73 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,8 +85,9 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) -(defcustom comp-async-jobs-number 2 - "Default number of processes used for async compilation." +(defcustom comp-async-jobs-number 0 + "Default number of processes used for async compilation. +When zero use half of the CPUs or at least one." :type 'fixnum :group 'comp) @@ -2082,13 +2083,25 @@ processes from `comp-async-processes'" (cl-delete-if-not #'process-live-p comp-async-processes)) (length comp-async-processes)) +(let (num-cpus) + (defun comp-effective-async-max-jobs () + "Compute the effective number of async jobs." + (if (zerop comp-async-jobs-number) + (or num-cpus + (setf num-cpus + ;; Half of the CPUs or at least one. + ;; FIXME portable? + (max 1 (/ (string-to-number (shell-command-to-string "nproc")) + 2)))) + comp-async-jobs-number))) + (defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. When compilation is finished, run `comp-async-all-done-hook' and display a message." (if (or comp-files-queue (> (comp-async-runnings) 0)) - (unless (>= (comp-async-runnings) comp-async-jobs-number) + (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs)) (cl-loop for source-file = (pop comp-files-queue) while source-file @@ -2119,7 +2132,7 @@ display a message." (accept-process-output process) (comp-run-async-workers))))) (push process comp-async-processes)) - when (>= (comp-async-runnings) comp-async-jobs-number) + when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) ;; No files left to compile and all processes finished. (let ((msg "Compilation finished.")) From ea8864fb672a7ff2d1da1b91885239f60e16b359 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 21:07:14 +0000 Subject: [PATCH 0768/1452] * comp.el: (native-compile-async) do not duplicate queue entries --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 68d3b8b2c73..c00a68307b0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2229,7 +2229,8 @@ of given directories." ((file-exists-p path) (push path files)) (t (signal 'native-compiler-error (list "Path not a file nor directory" path))))) - (setf comp-files-queue (nconc files comp-files-queue)) + (dolist (file files) + (add-to-list 'comp-files-queue file t)) (when (zerop (comp-async-runnings)) (comp-run-async-workers)) (message "Compilation started."))) From 159f61baa9e374cfd17acf1a45c0d553b57b7ac9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 21:44:05 +0000 Subject: [PATCH 0769/1452] Trigger native compilation when loading bytecode Introduce a first mechanism to trigger compilation when lex elc files are loaded. This is off by default and has to be better tested. --- lisp/emacs-lisp/comp.el | 5 +++++ src/comp.c | 38 +++++++++++++++++++++++++++++++++++++- src/comp.h | 10 ++++++++++ src/data.c | 2 ++ src/lisp.h | 1 + src/lread.c | 2 +- 6 files changed, 56 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c00a68307b0..0728c4f0a81 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -40,6 +40,11 @@ "Emacs Lisp native compiler." :group 'lisp) +(defcustom comp-deferred-compilation nil + "If t compile asyncronously all lexically bound .elc files being loaded." + :type 'boolean + :group 'comp) + (defcustom comp-speed 2 "Compiler optimization level. From 0 to 3. - 0 no optimizations are performed, compile time is favored. diff --git a/src/comp.c b/src/comp.c index b9ecef07f32..74b74a83b77 100644 --- a/src/comp.c +++ b/src/comp.c @@ -492,7 +492,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, /* String containing the function ptr name. */ Lisp_Object f_ptr_name = - CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + CALLN (Ffuncall, intern_c_string ("comp-c-func-name"), subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = @@ -3359,6 +3359,40 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } + +/***********************************/ +/* Deferred compilation mechanism. */ +/***********************************/ + +void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{ + Lisp_Object src = Qnil; + Lisp_Object load_list = Vcurrent_load_list; + + FOR_EACH_TAIL (load_list) + { + src = XCAR (load_list); + if (!CONSP (src)) + break; + } + + if (!comp_deferred_compilation + || noninteractive + || !NILP (Vpurify_flag) + || !COMPILEDP (definition) + || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) + || !STRINGP (src) + || !suffix_p (src, ".elc")) + return; + + src = concat2 (CALL1I (file-name-sans-extension, src), + build_pure_c_string (".el")); + if (!NILP (Ffile_exists_p (src))) + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); +} + /**************************************/ /* Functions used to load eln files. */ @@ -3552,6 +3586,8 @@ void syms_of_comp (void) { /* Compiler control customizes. */ + DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, + doc: /* If t compile asyncronously every .elc file loaded. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); diff --git a/src/comp.h b/src/comp.h index 070ec4d5ca9..f3bcd4c09bc 100644 --- a/src/comp.h +++ b/src/comp.h @@ -68,5 +68,15 @@ extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); +extern void maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition); +#else + +static inline void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{} + #endif + #endif diff --git a/src/data.c b/src/data.c index 8a0546ce09b..173b92c5bf4 100644 --- a/src/data.c +++ b/src/data.c @@ -814,6 +814,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 diff --git a/src/lisp.h b/src/lisp.h index cd543f5047d..96959764879 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4102,6 +4102,7 @@ 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, diff --git a/src/lread.c b/src/lread.c index 32c83bfae8b..2d90bccdc07 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1077,7 +1077,7 @@ effective_load_path (void) } /* Return true if STRING ends with SUFFIX. */ -static bool +bool suffix_p (Lisp_Object string, const char *suffix) { ptrdiff_t suffix_len = strlen (suffix); From f2c437761f5b9f0256d9b2e2687e0ab889274c46 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 17 Mar 2020 21:35:11 +0000 Subject: [PATCH 0770/1452] * comp.el: Have the compiler generates 'late_top_level_run' --- lisp/emacs-lisp/comp.el | 43 ++++++++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0728c4f0a81..3a56876cc00 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1137,10 +1137,10 @@ the annotation emission." (comp-log-func func 2) func) -(cl-defgeneric comp-emit-for-top-level (form) +(cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) _) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) @@ -1159,16 +1159,19 @@ the annotation emission." ;; parameter. (make-comp-mvar :slot 0))))) -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) - (let ((form (byte-to-native-top-level-form form))) - (comp-emit (comp-call 'eval - (let ((comp-curr-allocation-class 'd-impure)) - (make-comp-mvar :constant form)) - (make-comp-mvar :constant t))))) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) + for-late-load) + (unless for-late-load + (let ((form (byte-to-native-top-level-form form))) + (comp-emit (comp-call 'eval + (let ((comp-curr-allocation-class 'd-impure)) + (make-comp-mvar :constant form)) + (make-comp-mvar :constant t)))))) -(defun comp-limplify-top-level () - "Create a limple function doing the business for top level forms. -This will be called at load-time. +(defun comp-limplify-top-level (for-late-load) + "Create a limple function to modify the global environment at load. +When FOR-LATE-LOAD is non nil the emitted function modifies only +function definition. Synthesize a function called 'top_level_run' that gets one single parameter (the compilation unit it-self). To define native @@ -1178,8 +1181,12 @@ into the C code forwarding the compilation unit." ;; reasons to be execute ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) - (func (make-comp-func :name 'top-level-run - :c-name "top_level_run" + (func (make-comp-func :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") :args (make-comp-args :min 1 :max 1) :frame-size 1)) (comp-func func) @@ -1187,10 +1194,13 @@ into the C code forwarding the compilation unit." :curr-block (make--comp-block -1 0 'top-level) :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) - (comp-emit-annotation "Top level") + (comp-emit-annotation (if for-late-load + "Late top level" + "Top level")) ;; Assign the compilation unit incoming as parameter to the slot frame 0. (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) - (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) + (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) + (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) @@ -1278,7 +1288,8 @@ into the C code forwarding the compilation unit." "Compute the LIMPLE ir for LAP-FUNCS. Top-level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) - (comp-add-func-to-ctxt (comp-limplify-top-level))) + (comp-add-func-to-ctxt (comp-limplify-top-level nil)) + (comp-add-func-to-ctxt (comp-limplify-top-level t))) ;;; SSA pass specific code. From 034d9b319c2d596d090364476a193fbc409026d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 17 Mar 2020 22:24:52 +0000 Subject: [PATCH 0771/1452] * comp.el: late-load support optional as `native-compile' parameter --- lisp/emacs-lisp/comp.el | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3a56876cc00..d077fa59991 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -214,7 +214,9 @@ This is to build the prev field.") :documentation "Relocated data that cannot be moved into pure space. This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container - :documentation "Relocated data not necessary after load.")) + :documentation "Relocated data not necessary after load.") + (with-late-load nil :type boolean + :documentation "When non nil support late load.")) (cl-defstruct comp-args-base (min nil :type number @@ -1289,7 +1291,8 @@ into the C code forwarding the compilation unit." Top-level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) (comp-add-func-to-ctxt (comp-limplify-top-level nil)) - (comp-add-func-to-ctxt (comp-limplify-top-level t))) + (when (comp-ctxt-with-late-load comp-ctxt) + (comp-add-func-to-ctxt (comp-limplify-top-level t)))) ;;; SSA pass specific code. @@ -2163,7 +2166,7 @@ display a message." ;;; Compiler entry points. ;;;###autoload -(defun native-compile (function-or-file) +(defun native-compile (function-or-file &optional with-late-load) "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. @@ -2188,7 +2191,8 @@ Return the compilation unit file name." (output-filename (file-name-sans-extension (file-name-nondirectory expanded-filename)))) - (expand-file-name output-filename output-dir)))))) + (expand-file-name output-filename output-dir))) + :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) From b53fc68535211a59fde7200713340d911b48ecec Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Mar 2020 19:48:50 +0000 Subject: [PATCH 0772/1452] Extend low level code for late load --- src/comp.c | 36 ++++++++++++++++-------------------- src/comp.h | 4 ++-- src/lread.c | 2 +- src/pdumper.c | 2 +- 4 files changed, 20 insertions(+), 24 deletions(-) diff --git a/src/comp.c b/src/comp.c index 74b74a83b77..3f2b45c85fd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3368,27 +3368,18 @@ void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) { - Lisp_Object src = Qnil; - Lisp_Object load_list = Vcurrent_load_list; - - FOR_EACH_TAIL (load_list) - { - src = XCAR (load_list); - if (!CONSP (src)) - break; - } - if (!comp_deferred_compilation || noninteractive || !NILP (Vpurify_flag) || !COMPILEDP (definition) || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) - || !STRINGP (src) - || !suffix_p (src, ".elc")) + || !STRINGP (Vload_file_name) + || !suffix_p (Vload_file_name, ".elc")) return; - src = concat2 (CALL1I (file-name-sans-extension, src), - build_pure_c_string (".el")); + Lisp_Object src = + concat2 (CALL1I (file-name-sans-extension, Vload_file_name), + build_pure_c_string (".el")); if (!NILP (Ffile_exists_p (src))) CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); } @@ -3413,7 +3404,8 @@ load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) } void -load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, + bool late_load) { dynlib_handle_ptr handle = comp_u->handle; Lisp_Object comp_u_lisp_obj; @@ -3447,7 +3439,9 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) freloc_check_fill (); - void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); + void (*top_level_run)(Lisp_Object) + = dynlib_sym (handle, + late_load ? "late_top_level_run" : "top_level_run"); if (!reloading_cu) { @@ -3564,9 +3558,11 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, } /* Load related routines. */ -DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, - doc: /* Load native elisp code FILE. */) - (Lisp_Object file) +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, + doc: /* Load native elisp code FILE. + LATE_LOAD has to be non nil when loading for deferred + compilation. */) + (Lisp_Object file, Lisp_Object late_load) { CHECK_STRING (file); @@ -3576,7 +3572,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; comp_u->data_vec = Qnil; - load_comp_unit (comp_u, false); + load_comp_unit (comp_u, false, !NILP (late_load)); return Qt; } diff --git a/src/comp.h b/src/comp.h index f3bcd4c09bc..f5baa88853e 100644 --- a/src/comp.h +++ b/src/comp.h @@ -64,8 +64,8 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void hash_native_abi (void); -extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, - bool loading_dump); +void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, + bool late_load); extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, diff --git a/src/lread.c b/src/lread.c index 2d90bccdc07..b2f437130ce 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1483,7 +1483,7 @@ Return t if the file exists and loads successfully. */) { specbind (Qcurrent_load_list, Qnil); LOADHIST_ATTACH (found); - Fnative_elisp_load (found); + Fnative_elisp_load (found, Qnil); build_load_history (found, true); } else diff --git a/src/pdumper.c b/src/pdumper.c index 2e2220a9b29..55f95fd0e75 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5303,7 +5303,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); - load_comp_unit (comp_u, true); + load_comp_unit (comp_u, true, false); break; } case RELOC_NATIVE_SUBR: From c3e640bfa6623234e6757e1ffef1b0d6a3144ff8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Mar 2020 19:52:36 +0000 Subject: [PATCH 0773/1452] * comp.el: Extend `native-compile-async' for load and late-load --- lisp/emacs-lisp/comp.el | 50 ++++++++++++++++++++++++++++------------- 1 file changed, 34 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d077fa59991..f1e99c5ee16 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -433,6 +433,21 @@ VERBOSITY is a number between 0 and 3." 2)) edges))) +(defun comp-output-base-filename (src) + "Output filename sans extention for SRC file being native compiled." + (let* ((expanded-filename (expand-file-name src)) + (output-dir (file-name-as-directory + (concat (file-name-directory expanded-filename) + comp-native-path-postfix))) + (output-filename + (file-name-sans-extension + (file-name-nondirectory expanded-filename)))) + (expand-file-name output-filename output-dir))) + +(defun comp-output-filename (src) + "Output filename for SRC file being native compiled." + (concat (comp-output-base-filename src) ".eln")) + ;;; spill-lap pass specific code. @@ -2122,7 +2137,7 @@ display a message." (> (comp-async-runnings) 0)) (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs)) (cl-loop - for source-file = (pop comp-files-queue) + for (source-file . load) = (pop comp-files-queue) while source-file do (cl-assert (string-match-p (rx ".el" eos) source-file) nil "`comp-files-queue' should be \".el\" files: %s" @@ -2136,7 +2151,9 @@ display a message." comp-verbose ,comp-verbose load-path ',load-path) (message "Compiling %s..." ,source-file) - (native-compile ,source-file))) + (native-compile ,source-file ,(and load t)))) + (source-file1 source-file) ;; Make the closure works :/ + (load1 load) (process (make-process :name (concat "Compiling: " source-file) :buffer (get-buffer-create comp-async-buffer-name) @@ -2149,6 +2166,10 @@ display a message." 'comp-async-cu-done-hook source-file) (accept-process-output process) + (when load1 + (native-elisp-load + (comp-output-filename source-file1) + load1)) (comp-run-async-workers))))) (push process comp-async-processes)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) @@ -2181,17 +2202,7 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output - (if (symbolp function-or-file) - (make-temp-file (concat (symbol-name function-or-file) "-")) - (let* ((expanded-filename (expand-file-name function-or-file)) - (output-dir (file-name-as-directory - (concat (file-name-directory expanded-filename) - comp-native-path-postfix))) - (output-filename - (file-name-sans-extension - (file-name-nondirectory expanded-filename)))) - (expand-file-name output-filename output-dir))) + :output (comp-output-base-filename function-or-file) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err @@ -2231,12 +2242,15 @@ Always generate elc files too and handle native compiler expected errors." (rename-file tempfile target-file t)))))) ;;;###autoload -(defun native-compile-async (paths recursively) +(defun native-compile-async (paths &optional recursively load) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. `comp-async-jobs-number' specifies the number of (commands) to run simultaneously. If RECURSIVELY, recurse into subdirectories -of given directories." +of given directories. +LOAD can be nil t or 'late." + (unless (member load '(nil t late)) + (error "LOAD must be nil t or 'late")) (unless (listp paths) (setf paths (list paths))) (let (files) @@ -2250,7 +2264,11 @@ of given directories." (t (signal 'native-compiler-error (list "Path not a file nor directory" path))))) (dolist (file files) - (add-to-list 'comp-files-queue file t)) + (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) + (cl-assert (eq load (cdr entry)) + nil "Incoherent load kind in compilation queue for %s" + file) + (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers)) (message "Compilation started."))) From 7565a4a1170bf36352ffd7283c18ac1843ae8123 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Mar 2020 21:20:52 +0000 Subject: [PATCH 0774/1452] Command late load when deferring compilation --- lisp/emacs-lisp/comp.el | 4 +++- src/comp.c | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f1e99c5ee16..44de2745c6c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -41,7 +41,9 @@ :group 'lisp) (defcustom comp-deferred-compilation nil - "If t compile asyncronously all lexically bound .elc files being loaded." + "If t compile asyncronously all lexically bound .elc files being loaded. +Once compilation happened each function definition is updated to +the native compiled one." :type 'boolean :group 'comp) diff --git a/src/comp.c b/src/comp.c index 3f2b45c85fd..d645b59590f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3381,7 +3381,8 @@ maybe_defer_native_compilation (Lisp_Object function_name, concat2 (CALL1I (file-name-sans-extension, Vload_file_name), build_pure_c_string (".el")); if (!NILP (Ffile_exists_p (src))) - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); } @@ -3639,6 +3640,7 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); + DEFSYM (Qlate, "late"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); From 0179d95630ff5864c14b8dfcefaa131ecd44c1e2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Mar 2020 20:00:43 +0000 Subject: [PATCH 0775/1452] * comp.c (native-elisp-load): Guard against misisng file. --- src/comp.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index d645b59590f..55e6e96ec81 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3566,7 +3566,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, (Lisp_Object file, Lisp_Object late_load) { CHECK_STRING (file); - + if (NILP (Ffile_exists_p (file))) + xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), + file); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); comp_u->handle = dynlib_open (SSDATA (file)); if (!comp_u->handle) From b070571f93def7892b71a711a59bbd065c554897 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Mar 2020 20:16:05 +0000 Subject: [PATCH 0776/1452] * comp.el (comp-run-async-workers): Load only if compilation succeed --- lisp/emacs-lisp/comp.el | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 44de2745c6c..00883a35680 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2163,16 +2163,18 @@ display a message." (expand-file-name invocation-name invocation-directory) "--batch" "--eval" (prin1-to-string expr)) - :sentinel (lambda (process _event) - (run-hook-with-args - 'comp-async-cu-done-hook - source-file) - (accept-process-output process) - (when load1 - (native-elisp-load - (comp-output-filename source-file1) - load1)) - (comp-run-async-workers))))) + :sentinel + (lambda (process _event) + (run-hook-with-args + 'comp-async-cu-done-hook + source-file) + (accept-process-output process) + (when (and load1 + (zerop (process-exit-status process))) + (native-elisp-load + (comp-output-filename source-file1) + load1)) + (comp-run-async-workers))))) (push process comp-async-processes)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) From 64a6709f648f4f6363e1d9d63cc4fc33ff5e0340 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Mar 2020 18:37:32 +0000 Subject: [PATCH 0777/1452] * comp.el (comp-async-jobs-number): Fix customize type. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 00883a35680..1e348c065b5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -95,7 +95,7 @@ performed at `comp-speed' > 0." (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'fixnum + :type 'number :group 'comp) (defcustom comp-async-cu-done-hook nil From e05a62a968e688533f014ac556a8b32662b32ed3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Mar 2020 14:11:41 +0000 Subject: [PATCH 0778/1452] Have a fast build option triggered by env var NATIVE_FAST_BOOT --- lisp/Makefile.in | 8 +++++--- lisp/emacs-lisp/comp.el | 22 ++++++++++++---------- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 8ba619656d8..035720b49b7 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -351,9 +351,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_DISABLE=$(NATIVE_FAST_BOOT) \ + TARGETS="$$chunk"; \ done .PHONY: native-compile-clean diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1e348c065b5..a316d741a26 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2234,16 +2234,18 @@ Ultra cheap impersonation of `batch-byte-compile'." (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." - (let ((byte-native-for-bootstrap t) - (byte-to-native-output-file nil)) - (unwind-protect - (condition-case _ - (batch-native-compile) - (native-compiler-error-dyn-func) - (native-compiler-error-empty-byte)) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t)))))) + (if (equal (getenv "NATIVE_DISABLE") "1") + (batch-byte-compile) + (let ((byte-native-for-bootstrap t) + (byte-to-native-output-file nil)) + (unwind-protect + (condition-case _ + (batch-native-compile) + (native-compiler-error-dyn-func) + (native-compiler-error-empty-byte)) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t))))))) ;;;###autoload (defun native-compile-async (paths &optional recursively load) From ab4fff52d41e62d0d05a195798cb167eedf84ba6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 21 Mar 2020 19:32:01 +0000 Subject: [PATCH 0779/1452] * .gitlab-ci.yml: CI test native bootstrap speed1 and speed2 Do just a fast bootstrap for these two. --- .gitlab-ci.yml | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fa613bb412c..ae46481e1af 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -69,8 +69,8 @@ test-filenotify-gio: - make bootstrap - make -C test autorevert-tests filenotify-tests -test-native-bootstrap: - # Test native bootstrap +test-native-bootstrap-speed0: + # Test a full native bootstrap # Run for now only speed 0 to limit memory usage and compilation time. stage: test # Uncomment the following to run it only when sceduled. @@ -82,3 +82,21 @@ test-native-bootstrap: - ./configure --without-makeinfo --with-nativecomp - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 timeout: 3 hours + +test-native-bootstrap-speed1: + stage: test + 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_FAST_BOOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + timeout: 6 hours + +test-native-bootstrap-speed2: + stage: test + 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_FAST_BOOT=1 + timeout: 6 hours From ef30feb554d29d9dd1514ceae1711938dae538b5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Mar 2020 09:35:55 +0000 Subject: [PATCH 0780/1452] * comp.el: Add missing require --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a316d741a26..273b41f5427 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -32,6 +32,7 @@ (require 'cl-extra) (require 'cl-lib) (require 'cl-macs) +(require 'cl-seq) (require 'gv) (require 'rx) (require 'subr-x) From 07e314569b743cfc38b8bb3599355161c576ff32 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Mar 2020 14:50:01 +0000 Subject: [PATCH 0781/1452] * comp.c (maybe_defer_native_compilation): Add some debug code --- src/comp.c | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/comp.c b/src/comp.c index 55e6e96ec81..f5961c7d2b6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3368,6 +3368,27 @@ void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) { +#if 0 +#include +#include + if (!NILP (function_name) && + STRINGP (Vload_file_name)) + { + static FILE *f; + if (!f) + { + char str[128]; + sprintf (str, "log_%d", getpid()); + f = fopen (str, "w"); + } + if (!f) + exit (1); + fprintf (f, "function %s file %s\n", + SSDATA (Fsymbol_name (function_name)), + SSDATA (Vload_file_name)); + fflush (f); + } +#endif if (!comp_deferred_compilation || noninteractive || !NILP (Vpurify_flag) From 855940df6bde5ed41ed55336a3ac6f6ae0c6267e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Mar 2020 15:08:58 +0000 Subject: [PATCH 0782/1452] * comp.c (maybe_defer_native_compilation): Fix Prevent recursive compilation while deferring compilation. --- src/comp.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index f5961c7d2b6..b563f27da8f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3402,8 +3402,13 @@ maybe_defer_native_compilation (Lisp_Object function_name, concat2 (CALL1I (file-name-sans-extension, Vload_file_name), build_pure_c_string (".el")); if (!NILP (Ffile_exists_p (src))) - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); + { + comp_deferred_compilation = false; + Frequire (intern_c_string ("comp"), Qnil, Qnil); + comp_deferred_compilation = true; + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); + } } From f8b07ff4f318d799a471c9363903e3929fd5c844 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Mar 2020 15:57:48 +0000 Subject: [PATCH 0783/1452] Guard against function redefinition during deferred load --- lisp/emacs-lisp/comp.el | 10 ++++++++-- src/comp.c | 39 +++++++++++++++++++++++++++++++-------- 2 files changed, 39 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 273b41f5427..c6f2ca13aab 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1160,12 +1160,15 @@ the annotation emission." (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) _) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) + for-late-load) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) (cl-assert (and name f)) - (comp-emit (comp-call 'comp--register-subr + (comp-emit (comp-call (if for-late-load + 'comp--late-register-subr + 'comp--register-subr) (make-comp-mvar :constant name) (make-comp-mvar :constant (comp-args-base-min args)) (make-comp-mvar :constant (if (comp-args-p args) @@ -2186,6 +2189,9 @@ display a message." (save-excursion (goto-char (point-max)) (insert msg "\n"))) + ;; `comp-deferred-pending-h' should be empty at this stage. + ;; Reset it anyway. + (setf comp-deferred-pending-h (make-hash-table :equal #'eq)) (message msg)))) diff --git a/src/comp.c b/src/comp.c index b563f27da8f..3205a29a104 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3401,14 +3401,16 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object src = concat2 (CALL1I (file-name-sans-extension, Vload_file_name), build_pure_c_string (".el")); - if (!NILP (Ffile_exists_p (src))) - { - comp_deferred_compilation = false; - Frequire (intern_c_string ("comp"), Qnil, Qnil); - comp_deferred_compilation = true; - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); - } + if (NILP (Ffile_exists_p (src))) + return; + + /* Really happening. */ + Fputhash (function_name, definition, Vcomp_deferred_pending_h); + comp_deferred_compilation = false; + Frequire (intern_c_string ("comp"), Qnil, Qnil); + comp_deferred_compilation = true; + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); } @@ -3584,6 +3586,21 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, return Qnil; } +DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, + Scomp__late_register_subr, 7, 7, 0, + doc: /* This gets called by late_top_level_run during load + phase to register each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) +{ + if (!NILP (Fequal (Fsymbol_function (name), + Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) + Fcomp__register_subr (name, minarg, maxarg, c_name, doc, intspec, comp_u); + Fremhash (name, Vcomp_deferred_pending_h); + return Qnil; +} + /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILE. @@ -3714,6 +3731,7 @@ syms_of_comp (void) defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Scomp__register_subr); + defsubr (&Scomp__late_register_subr); defsubr (&Snative_elisp_load); staticpro (&comp.exported_funcs_h); @@ -3742,6 +3760,11 @@ syms_of_comp (void) DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, doc: /* Postifix to be added to the .eln compilation path. */); Vcomp_native_path_postfix = Qnil; + + DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, + doc: /* Hash table symbol-name -> function-value. For + internal use during */); + Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); } #endif /* HAVE_NATIVE_COMP */ From 73ced8c23ec3d5cdfa6d926af649235104707d85 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Mar 2020 22:27:17 +0000 Subject: [PATCH 0784/1452] * comp.el : Fix typo introduced by f8b07ff4f3 --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c6f2ca13aab..dfa9658a36c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2191,7 +2191,7 @@ display a message." (insert msg "\n"))) ;; `comp-deferred-pending-h' should be empty at this stage. ;; Reset it anyway. - (setf comp-deferred-pending-h (make-hash-table :equal #'eq)) + (setf comp-deferred-pending-h (make-hash-table :test #'eq)) (message msg)))) From 4acc4ac66753ff1556be907f2611b48ffc3fc79c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Mar 2020 19:10:20 +0000 Subject: [PATCH 0785/1452] * comp.el (native-compile-async): Fix excessive messaging --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dfa9658a36c..c5c894f6607 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2283,8 +2283,8 @@ LOAD can be nil t or 'late." file) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) - (comp-run-async-workers)) - (message "Compilation started."))) + (comp-run-async-workers) + (message "Compilation started.")))) (provide 'comp) From bb0496e7e55a7fca89c51eb0b85dcfa6904ea3ec Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Mar 2020 18:47:39 +0000 Subject: [PATCH 0786/1452] * comp.c (emit_mvar_access): Fix speed 1 compilation At speed 1 propagate does not run and all mvars are allocated in array 0. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 3205a29a104..d72d6acc8ef 100644 --- a/src/comp.c +++ b/src/comp.c @@ -388,7 +388,7 @@ emit_mvar_access (Lisp_Object mvar) EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); EMACS_INT slot_n = XFIXNUM (mvar_slot); - if (comp.func_has_non_local || !SPEED) + if (comp.func_has_non_local || (SPEED < 2)) return comp.arrays[arr_idx][slot_n]; else { From 79483a5873a90bb28178af59acfdb00040c3d23d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Mar 2020 20:36:46 +0000 Subject: [PATCH 0787/1452] * .gitlab-ci.yml (test-native-bootstrap-speed*): Timeout to 8h Running in tests in parall takes longer. --- .gitlab-ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ae46481e1af..4522bb6bb4e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -81,7 +81,7 @@ test-native-bootstrap-speed0: - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 - timeout: 3 hours + timeout: 8 hours test-native-bootstrap-speed1: stage: test @@ -90,7 +90,7 @@ test-native-bootstrap-speed1: - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap NATIVE_FAST_BOOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' - timeout: 6 hours + timeout: 8 hours test-native-bootstrap-speed2: stage: test @@ -99,4 +99,4 @@ test-native-bootstrap-speed2: - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap NATIVE_FAST_BOOT=1 - timeout: 6 hours + timeout: 8 hours From 05f89e8ef4eb5fbcd04fcc9c0dcb92f90ad6b28c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Mar 2020 12:26:45 +0100 Subject: [PATCH 0788/1452] src/comp.c (Fcomp__init_ctxt): Aesthetic --- src/comp.c | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index d72d6acc8ef..60ef3bf0dcd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3123,7 +3123,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.unsigned_long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); - #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, @@ -3137,16 +3136,13 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.long_long_type, "obj"); #endif - comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, NULL, comp.emacs_int_type, "num"); - gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; comp.lisp_obj_type = @@ -3156,7 +3152,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, ARRAYELTS (lisp_obj_fields), lisp_obj_fields); comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); - comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.emacs_int_type, @@ -3173,16 +3168,13 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, INTTYPEBITS); - comp.lisp_int0 = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, Lisp_Int0); - comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (void *), true); - comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (void *), false); From 9d8ce520f03217e5aaf08b3e252a1bb82c3fc641 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 26 Mar 2020 15:47:36 +0000 Subject: [PATCH 0789/1452] * comp.c (maybe_defer_native_compilation): Compile comp dependecies. Make maybe_defer_native_compilation able to compile comp dependecies breaking circularity. --- src/comp.c | 40 +++++++++++++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 60ef3bf0dcd..563f6250730 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3356,6 +3356,10 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /* Deferred compilation mechanism. */ /***********************************/ +/* List of sources we'll compile and load after having conventionally + loaded the compiler and its dependencies. */ +static Lisp_Object delayed_sources; + void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) @@ -3396,13 +3400,32 @@ maybe_defer_native_compilation (Lisp_Object function_name, if (NILP (Ffile_exists_p (src))) return; - /* Really happening. */ - Fputhash (function_name, definition, Vcomp_deferred_pending_h); - comp_deferred_compilation = false; - Frequire (intern_c_string ("comp"), Qnil, Qnil); - comp_deferred_compilation = true; - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); + /* This is to have deferred compilaiton able to compile comp + dependecies breaking circularity. */ + if (!NILP (Ffeaturep (Qcomp, Qnil))) + { + /* Comp already loaded. */ + if (!NILP (delayed_sources)) + { + CALLN (Ffuncall, intern_c_string ("native-compile-async"), + delayed_sources, Qnil, Qlate); + delayed_sources = Qnil; + } + Fputhash (function_name, definition, Vcomp_deferred_pending_h); + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); + } + else + { + delayed_sources = Fcons (src, delayed_sources); + /* Require comp only once. */ + static bool comp_required = false; + if (!comp_required) + { + comp_required = true; + Frequire (Qcomp, Qnil, Qnil); + } + } } @@ -3675,6 +3698,7 @@ syms_of_comp (void) DEFSYM (Qd_ephemeral, "d-ephemeral"); /* Others. */ + DEFSYM (Qcomp, "comp"); DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); DEFSYM (Qlate, "late"); @@ -3733,6 +3757,8 @@ syms_of_comp (void) staticpro (&comp.func_blocks_h); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; + staticpro (&delayed_sources); + delayed_sources = Qnil; DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); From d5f6dc131b63d6bde096c03927c05a490c707c41 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 28 Mar 2020 20:56:47 +0000 Subject: [PATCH 0790/1452] Prevent collisions in C namespace and function shadowing This rework make functions being indexed by their unique C symbol name preventing multiple lisp function with the same name colliding. --- lisp/emacs-lisp/bytecomp.el | 14 ++++-- lisp/emacs-lisp/comp.el | 85 ++++++++++++++++++++++++------------- src/comp.c | 23 +++++++--- 3 files changed, 81 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fe5616be668..977f137b793 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,7 +565,7 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (cl-defstruct byte-to-native-function "Named or anonymous function defined a top level." - name data) + name c-name data) (cl-defstruct byte-to-native-top-level "All other top level forms." form) @@ -1094,6 +1094,8 @@ message buffer `default-directory'." (defvar byte-compile-current-file nil) (defvar byte-compile-current-group nil) (defvar byte-compile-current-buffer nil) +(defvar byte-compile-not-top-level nil ; We'll evolve this for naming lambdas + "Non nil if compiling something that is not top-level.") ;; Log something that isn't a warning. (defmacro byte-compile-log (format-string &rest args) @@ -2916,6 +2918,7 @@ for symbols generated by the byte compiler itself." ;; args of `list'. Actually, compile it to get warnings, ;; but don't use the result. (let* ((form (nth 1 int)) + (byte-compile-not-top-level t) (newform (byte-compile-top-level form))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) @@ -3116,7 +3119,8 @@ for symbols generated by the byte compiler itself." (let* ((byte-compile-vector (byte-compile-constants-vector)) (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) - (when byte-native-compiling + (when (and byte-native-compiling + (null byte-compile-not-top-level)) ;; Spill LAP for the native compiler here (push (cons byte-compile-current-form byte-compile-output) byte-to-native-lap)) @@ -3170,7 +3174,8 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect)) + (let ((byte-compile--for-effect for-effect) + (byte-compile-not-top-level t)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) @@ -3944,7 +3949,8 @@ discarding." ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (let ((f (nth 1 form))) + (let ((f (nth 1 form)) + (byte-compile-not-top-level t)) (when (and (symbolp f) (byte-compile-warning-enabled-p 'callargs f)) (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c5c894f6607..eca61c6bac5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -208,13 +208,15 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") :documentation "Target output file-name for the compilation.") (top-level-forms () :type list :documentation "List of spilled top level forms.") - (funcs-h (make-hash-table) :type hash-table - :documentation "lisp-func-name -> comp-func. -This is to build the prev field.") + (funcs-h (make-hash-table :test #'equal) :type hash-table + :documentation "c-name -> comp-func.") + (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table + :documentation "symbol-function -> c-name. +This is only for optimizing intra CU calls at speed 3.") (d-default (make-comp-data-container) :type comp-data-container - :documentation "Standard data relocated in use by functions.") + :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container - :documentation "Relocated data that cannot be moved into pure space. + :documentation "Relocated data that cannot be moved into pure space. This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") @@ -471,7 +473,14 @@ Put PREFIX in front of it." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - (concat prefix crypted "_" human-readable))) + ;; Prevent C namespace conflicts. + (cl-loop + with h = (comp-ctxt-funcs-h comp-ctxt) + for i from 0 + for c-sym = (concat prefix crypted "_" human-readable "_" + (number-to-string i)) + unless (gethash c-sym h) + return c-sym))) (defun comp-decrypt-arg-list (x function-name) "Decript argument list X for FUNCTION-NAME." @@ -492,14 +501,22 @@ Put PREFIX in front of it." "Given BYTE-COMPILED-FUNC return the frame size to be allocated." (aref byte-compiled-func 3)) +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (let ((name (comp-func-name func)) + (c-name (comp-func-c-name func))) + (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) + (cl-defgeneric comp-spill-lap-function (input) "Byte compile INPUT and spill lap for further stages.") (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) + (c-name (comp-c-func-name function-name "F")) (func (make-comp-func :name function-name - :c-name (comp-c-func-name function-name "F") + :c-name c-name :doc (documentation f) :int-spec (interactive-form f)))) (when (byte-code-function-p f) @@ -519,9 +536,10 @@ Put PREFIX in front of it." (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-function :name function-name))) + (setf (byte-to-native-function-c-name func) c-name) ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (list func)))) + (comp-add-func-to-ctxt func)))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." @@ -530,28 +548,39 @@ Put PREFIX in front of it." (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (comp-log byte-to-native-lap 3) (cl-loop - for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. + with lap-forms = (reverse byte-to-native-lap) + ;; All non anonymous functions. + for f in (cl-loop for x in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-function-p x) (byte-to-native-function-name x)) collect x) for name = (byte-to-native-function-name f) + for c-name = (comp-c-func-name name "F") + for lap-entry = (assoc name lap-forms) + for lap = (cdr lap-entry) for data = (byte-to-native-function-data f) - for lap = (alist-get name byte-to-native-lap) for func = (make-comp-func :name name :byte-func data :doc (documentation data) :int-spec (interactive-form data) - :c-name (comp-c-func-name name "F") + :c-name c-name :args (comp-decrypt-arg-list (aref data 0) name) - :lap (alist-get name byte-to-native-lap) + :lap lap :frame-size (comp-byte-frame-size data)) do - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1) - collect func)) + ;; Remove it form the original lap list to avoid multiple function + ;; definition with the same name shadowing each other. + (setf lap-forms (delete lap-entry lap-forms)) + ;; Store the c-name to have it retrivable from + ;; comp-ctxt-top-level-forms. + (setf (byte-to-native-function-c-name f) c-name) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1))) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. @@ -1163,7 +1192,8 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) for-late-load) (let* ((name (byte-to-native-function-name form)) - (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) + (c-name (byte-to-native-function-c-name form)) + (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) (cl-assert (and name f)) (comp-emit (comp-call (if for-late-load @@ -1174,7 +1204,7 @@ the annotation emission." (make-comp-mvar :constant (if (comp-args-p args) (comp-args-max args) 'many)) - (make-comp-mvar :constant (comp-func-c-name f)) + (make-comp-mvar :constant c-name) (make-comp-mvar :constant (comp-func-doc f)) (make-comp-mvar :constant (comp-func-int-spec f)) @@ -1301,16 +1331,10 @@ into the C code forwarding the compilation unit." (puthash addr t addr-h)) (comp-limplify-finalize-function func))) -(defun comp-add-func-to-ctxt (func) - "Add FUNC to the current compiler contex." - (puthash (comp-func-name func) - func - (comp-ctxt-funcs-h comp-ctxt))) - -(defun comp-limplify (lap-funcs) - "Compute the LIMPLE ir for LAP-FUNCS. -Top-level forms for the current context are rendered too." - (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) +(defun comp-limplify (_) + "Compute LIMPLE IR for forms in `comp-ctxt'." + (maphash (lambda (_ f) (comp-limplify-function f)) + (comp-ctxt-funcs-h comp-ctxt)) (comp-add-func-to-ctxt (comp-limplify-top-level nil)) (when (comp-ctxt-with-late-load comp-ctxt) (comp-add-func-to-ctxt (comp-limplify-top-level t)))) @@ -1843,7 +1867,8 @@ Backward propagate array placement properties." (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) - (callee-in-unit (gethash callee + (callee-in-unit (gethash (gethash callee + (comp-ctxt-sym-to-c-name-h comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt)))) (cond ((and subrp (not (subr-native-elisp-p f))) diff --git a/src/comp.c b/src/comp.c index 563f6250730..2aa0c472217 100644 --- a/src/comp.c +++ b/src/comp.c @@ -174,7 +174,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ - Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ + Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; /* Synthesized struct holding data relocs. */ @@ -518,9 +518,18 @@ static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue **args, bool direct) { - Lisp_Object func = - Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, - Qnil); + Lisp_Object func; + if (direct) + { + Lisp_Object c_name = + Fgethash (subr_sym, + CALL1I (comp-ctxt-sym-to-c-name-h, Vcomp_ctxt), + Qnil); + func = Fgethash (c_name, comp.exported_funcs_h, Qnil); + } + else + func = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); + if (NILP (func)) xsignal2 (Qnative_ice, build_string ("missing function declaration"), @@ -2926,7 +2935,7 @@ declare_function (Lisp_Object func) c_name, 2, param, 0); } - Fputhash (CALL1I (comp-func-name, func), + Fputhash (CALL1I (comp-func-c-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); @@ -2939,7 +2948,7 @@ compile_function (Lisp_Object func) USE_SAFE_ALLOCA; EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); - comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), comp.exported_funcs_h, Qnil)); comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); @@ -3179,7 +3188,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (void *), false); - comp.exported_funcs_h = CALLN (Fmake_hash_table); + comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal); /* Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. From 3c5e3ca2badeda8637e84586eace6ba619f0110a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Mar 2020 10:44:11 +0100 Subject: [PATCH 0791/1452] * test/src/comp-test-funcs.el (comp-test-big-interactive): New test --- test/src/comp-test-funcs.el | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 46d324bc42f..67b85753b8a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -403,6 +403,41 @@ (?< 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))) + (provide 'comp-test-funcs) ;;; comp-test-funcs.el ends here From 89cbff32e41771a64ba62e449ec797d55f86f15c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Mar 2020 10:51:12 +0100 Subject: [PATCH 0792/1452] * test/src/comp-tests.el (comp-tests-doc): Fix --- test/src/comp-tests.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e4b7a066cc0..c4f46b63dda 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -308,8 +308,7 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-doc () (should (string= (documentation #'comp-tests-doc-f) "A nice docstring")) - (should (string= (symbol-file #'comp-tests-doc-f) - (concat comp-test-src "n")))) + (should (string-match "\\.*.eln\\'" (symbol-file #'comp-tests-doc-f)))) (ert-deftest comp-test-interactive-form () (should (equal (interactive-form #'comp-test-interactive-form0-f) From c69c185109c90ecc486ab707ed32d7bb7aa467d5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Mar 2020 10:57:36 +0100 Subject: [PATCH 0793/1452] Add comp-test-40187 checking function shadowing. --- test/src/comp-test-funcs.el | 8 ++++++++ test/src/comp-tests.el | 6 ++++++ 2 files changed, 14 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 67b85753b8a..9fcc132b518 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -272,6 +272,14 @@ (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) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c4f46b63dda..4768e1a1ace 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -339,6 +339,12 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(ert-deftest comp-test-40187 () + "Check function name shadowing. +https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." + (should (eq (comp-test-40187-1-f) 'foo)) + (should (eq (comp-test-40187-2-f) 'bar))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; From 53f9bc6908a4da8f5c985e8f204a479c828c432d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Mar 2020 11:09:02 +0100 Subject: [PATCH 0794/1452] * comp.el (comp-output-base-filename): Handle src being a symbol --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eca61c6bac5..92d0655ffdc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -440,7 +440,8 @@ VERBOSITY is a number between 0 and 3." (defun comp-output-base-filename (src) "Output filename sans extention for SRC file being native compiled." - (let* ((expanded-filename (expand-file-name src)) + (let* ((src (if (symbolp src) (symbol-name src) src)) + (expanded-filename (expand-file-name src)) (output-dir (file-name-as-directory (concat (file-name-directory expanded-filename) comp-native-path-postfix))) From 530faee2752c7b316fa21f2ac4d1266d3e7a38e6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 29 Mar 2020 11:21:55 +0100 Subject: [PATCH 0795/1452] Fix free function compilation --- lisp/emacs-lisp/bytecomp.el | 3 ++- lisp/emacs-lisp/comp.el | 7 ++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 977f137b793..b3631074472 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3120,7 +3120,8 @@ for symbols generated by the byte compiler itself." (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) (when (and byte-native-compiling - (null byte-compile-not-top-level)) + (or (null byte-compile-not-top-level) + (eq byte-native-compiling 'free-func))) ;; Spill LAP for the native compiler here (push (cons byte-compile-current-form byte-compile-output) byte-to-native-lap)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 92d0655ffdc..d29e2f55f1f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -514,7 +514,8 @@ Put PREFIX in front of it." (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (let* ((f (symbol-function function-name)) + (let* ((byte-native-compiling 'free-func) + (f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func :name function-name :c-name c-name @@ -536,8 +537,8 @@ Put PREFIX in front of it." (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) - (list (make-byte-to-native-function :name function-name))) - (setf (byte-to-native-function-c-name func) c-name) + (list (make-byte-to-native-function :name function-name + :c-name c-name))) ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) From 63af801ed34c8dc59fb13c9e058c49203a1ae55d Mon Sep 17 00:00:00 2001 From: Ashish SHUKLA Date: Fri, 3 Apr 2020 02:07:05 +0530 Subject: [PATCH 0796/1452] configure.ac: switch to POSIX sh behaviour --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 393a53d7633..e8f46010910 100644 --- a/configure.ac +++ b/configure.ac @@ -3729,7 +3729,7 @@ if test "${with_nativecomp}" != "no"; then AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes)) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" - COMP_OBJ+=comp.o + COMP_OBJ="comp.o" AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) else AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. From 9bf9550836b526d1e72378b2a64385df8d47ac07 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 3 Apr 2020 15:35:28 +0100 Subject: [PATCH 0797/1452] src/comp.c: Fix i386 In i386 ABI parameter passing of structs (and unions) is done as pointer + size. Surprisingly this is done *always* even if the structure is known to be word size. --- src/comp.c | 35 +++++------------------------------ 1 file changed, 5 insertions(+), 30 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2aa0c472217..935b7aafda1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -107,7 +107,6 @@ typedef struct { gcc_jit_type *uintptr_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; - gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; /* struct Lisp_Cons */ gcc_jit_struct *lisp_cons_s; @@ -671,20 +670,14 @@ static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { emit_comment ("XLI"); - - return gcc_jit_rvalue_access_field (obj, - NULL, - comp.lisp_obj_as_num); + return obj; } static gcc_jit_lvalue * emit_lval_XLI (gcc_jit_lvalue *obj) { emit_comment ("lval_XLI"); - - return gcc_jit_lvalue_access_field (obj, - NULL, - comp.lisp_obj_as_num); + return obj; } /* @@ -3132,19 +3125,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.unsigned_long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); -#if EMACS_INT_MAX <= LONG_MAX - /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "obj"); -#else - /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "obj"); -#endif comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); @@ -3152,14 +3132,9 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, NULL, comp.emacs_int_type, "num"); - gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, - comp.lisp_obj_as_num }; - comp.lisp_obj_type = - gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "comp_Lisp_Object", - ARRAYELTS (lisp_obj_fields), - lisp_obj_fields); + /* No XLP is emitted for now so lets define this always as integer + disregarding LISP_WORDS_ARE_POINTERS value. */ + comp.lisp_obj_type = comp.emacs_int_type; comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, From 37a9d1e42b568b6a7b528ef40a209ab6658ff358 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 3 Apr 2020 20:09:02 +0100 Subject: [PATCH 0798/1452] * lisp/emacs-lisp/comp.el (native-compile): Better documentation. --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d29e2f55f1f..3f4dba6b1ff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2229,6 +2229,8 @@ display a message." "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. +When WITH-LATE-LOAD non Nil mark the compilation unit for late load +once finished compiling (internal use only). Return the compilation unit file name." (unless (or (functionp function-or-file) (stringp function-or-file)) From 70cb9644817ef59446d0705ba1362f200b3bd13d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 3 Apr 2020 21:19:45 +0100 Subject: [PATCH 0799/1452] * src/comp.c: Clean-up unnecessary field declaration. --- src/comp.c | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 935b7aafda1..f89414a3105 100644 --- a/src/comp.c +++ b/src/comp.c @@ -107,7 +107,6 @@ typedef struct { gcc_jit_type *uintptr_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; - gcc_jit_field *lisp_obj_as_num; /* struct Lisp_Cons */ gcc_jit_struct *lisp_cons_s; gcc_jit_field *lisp_cons_u; @@ -3128,10 +3127,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.emacs_int_type, - "num"); /* No XLP is emitted for now so lets define this always as integer disregarding LISP_WORDS_ARE_POINTERS value. */ comp.lisp_obj_type = comp.emacs_int_type; From 49a3790e684213a6247f20e8029947f82fefdb5b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 4 Apr 2020 23:33:52 +0100 Subject: [PATCH 0800/1452] * src/comp.c: Add MSB TAG and wide int support. --- src/comp.c | 226 +++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 194 insertions(+), 32 deletions(-) diff --git a/src/comp.c b/src/comp.c index f89414a3105..605e92680c7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -101,6 +101,7 @@ typedef struct { gcc_jit_type *long_long_type; gcc_jit_type *unsigned_long_long_type; gcc_jit_type *emacs_int_type; + gcc_jit_type *emacs_uint_type; gcc_jit_type *void_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; @@ -155,8 +156,6 @@ typedef struct { gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ - gcc_jit_rvalue *most_positive_fixnum; - gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; @@ -631,6 +630,85 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) dest_field); } + +/* Should come with libgccjit. */ + +static gcc_jit_rvalue * +emit_rvalue_from_long_long (long long n) +{ +#ifndef WIDE_EMACS_INT + xsignal1 (Qnative_ice, + build_string ("emit_rvalue_from_long_long called in non wide int" + " configuration")); +#endif + + emit_comment (format_string ("emit long long: %lld", n)); + + gcc_jit_rvalue *high = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.unsigned_long_long_type, + (unsigned long long)n >> 32); + gcc_jit_rvalue *low = + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_long_long_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + gcc_jit_context_new_rvalue_from_long ( + comp.ctxt, + comp.unsigned_long_long_type, + n), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)); + + return + emit_cast (comp.long_long_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_OR, + comp.unsigned_long_long_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), + low)); +} + +static gcc_jit_rvalue * +emit_most_positive_fixnum (void) +{ +#if EMACS_INT_MAX > LONG_MAX + return emit_rvalue_from_long_long (MOST_POSITIVE_FIXNUM); +#else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_POSITIVE_FIXNUM); +#endif +} + +static gcc_jit_rvalue * +emit_most_negative_fixnum (void) +{ +#if EMACS_INT_MAX > LONG_MAX + return emit_rvalue_from_long_long (MOST_NEGATIVE_FIXNUM); +#else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_NEGATIVE_FIXNUM); +#endif +} + /* Emit the equivalent of: (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) @@ -700,22 +778,38 @@ emit_lval_XLP (gcc_jit_lvalue *obj) comp.lisp_obj_as_ptr); } */ static gcc_jit_rvalue * -emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, ptrdiff_t lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ emit_comment ("XUNTAG"); - return emit_cast (gcc_jit_type_get_pointer (type), +#ifndef WIDE_EMACS_INT + return emit_cast ( + gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_MINUS, comp.emacs_int_type, emit_XLI (a), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, - lisp_word_tag))); + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_int_type, + lisp_word_tag))); +#else + return emit_cast ( + gcc_jit_type_get_pointer (type), + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_long_long_type, + /* FIXME Should be XLP. */ + emit_cast (comp.unsigned_long_long_type, emit_XLI (a)), + emit_cast (comp.unsigned_long_long_type, + emit_rvalue_from_long_long (lisp_word_tag)))); +#endif } static gcc_jit_rvalue * @@ -886,13 +980,31 @@ static gcc_jit_rvalue * emit_XFIXNUM (gcc_jit_rvalue *obj) { emit_comment ("XFIXNUM"); + gcc_jit_rvalue *i = emit_cast (comp.emacs_uint_type, emit_XLI (obj)); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - comp.inttypebits); + if (!USE_LSB_TAG) + { + i = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + emit_cast (comp.emacs_uint_type, i), + comp.inttypebits); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); + } + else + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } static gcc_jit_rvalue * @@ -924,16 +1036,20 @@ emit_NUMBERP (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_make_fixnum (gcc_jit_rvalue *obj) +emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) { - emit_comment ("make_fixnum"); + /* + EMACS_UINT u = n; + n = u << INTTYPEBITS; + n += int0; + */ gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_int_type, - obj, + emit_cast (comp.emacs_uint_type, n), comp.inttypebits); tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -956,6 +1072,55 @@ emit_make_fixnum (gcc_jit_rvalue *obj) return gcc_jit_lvalue_as_rvalue (res); } +static gcc_jit_rvalue * +emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) +{ + /* + n &= INTMASK; + n += (int0 << VALBITS); + return XIL (n); + */ + + gcc_jit_rvalue *intmask = + emit_cast (comp.emacs_uint_type, + emit_rvalue_from_long_long ((EMACS_INT_MAX + >> (INTTYPEBITS - 1)))); + n = gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.emacs_uint_type, + intmask, + emit_cast (comp.emacs_uint_type, n)); + + n = gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_uint_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + emit_cast (comp.emacs_uint_type, comp.lisp_int0), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_uint_type, + VALBITS)), + n); + return emit_XLI (emit_cast (comp.emacs_int_type, n)); +} + + +static gcc_jit_rvalue * +emit_make_fixnum (gcc_jit_rvalue *obj) +{ + emit_comment ("make_fixnum"); + return USE_LSB_TAG + ? emit_make_fixnum_LSB_TAG (obj) + : emit_make_fixnum_MSB_TAG (obj); +} + static gcc_jit_rvalue * emit_const_lisp_obj (Lisp_Object obj) { @@ -1188,9 +1353,11 @@ emit_mvar_val (Lisp_Object mvar) word (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - constant); + (sizeof (MOST_POSITIVE_FIXNUM) > sizeof (void *)) + ? emit_rvalue_from_long_long (constant) + : gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.void_ptr_type, + constant); return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ @@ -2574,8 +2741,6 @@ define_add1_sub1 (void) gcc_jit_function *func[2]; char const *f_name[] = { "add1", "sub1" }; char const *fall_back_func[] = { "1+", "1-" }; - gcc_jit_rvalue *compare[] = - { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; for (ptrdiff_t i = 0; i < 2; i++) @@ -2630,7 +2795,9 @@ define_add1_sub1 (void) NULL, GCC_JIT_COMPARISON_NE, n_fixnum, - compare[i])), + i == 0 + ? emit_most_positive_fixnum () + : emit_most_negative_fixnum ())), inline_block, fcall_block); @@ -2712,7 +2879,7 @@ define_negate (void) NULL, GCC_JIT_COMPARISON_NE, n_fixnum, - comp.most_negative_fixnum)), + emit_most_negative_fixnum ())), inline_block, fcall_block); @@ -3127,25 +3294,20 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); + comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_UINT), + false); /* No XLP is emitted for now so lets define this always as integer disregarding LISP_WORDS_ARE_POINTERS value. */ comp.lisp_obj_type = comp.emacs_int_type; comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); - comp.most_positive_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_POSITIVE_FIXNUM); - comp.most_negative_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, 1); comp.inttypebits = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, + comp.emacs_uint_type, INTTYPEBITS); comp.lisp_int0 = gcc_jit_context_new_rvalue_from_int (comp.ctxt, From e3dff709b75c83c3939727538aa0bd072c268687 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Apr 2020 14:24:00 +0100 Subject: [PATCH 0801/1452] * src/comp.c: Emit cast only when necessary. Coerce only when the destination type is different from the current one. --- src/comp.c | 89 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 47 insertions(+), 42 deletions(-) diff --git a/src/comp.c b/src/comp.c index 605e92680c7..75a2534b2ee 100644 --- a/src/comp.c +++ b/src/comp.c @@ -605,12 +605,17 @@ emit_cond_jump (gcc_jit_rvalue *test, } static gcc_jit_rvalue * -emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { static ptrdiff_t i; + gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj); + + if (new_type == old_type) + return obj; + gcc_jit_field *orig_field = - type_to_cast_field (gcc_jit_rvalue_get_type (obj)); + type_to_cast_field (old_type); gcc_jit_field *dest_field = type_to_cast_field (new_type); gcc_jit_lvalue *tmp_u = @@ -667,7 +672,7 @@ emit_rvalue_from_long_long (long long n) 32)); return - emit_cast (comp.long_long_type, + emit_coerce (comp.long_long_type, gcc_jit_context_new_binary_op ( comp.ctxt, NULL, @@ -729,17 +734,17 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, size_of_ptr_ref), - emit_cast (comp.uintptr_type, i)); + emit_coerce (comp.uintptr_type, i)); return - emit_cast ( + emit_coerce ( ptr_type, gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_PLUS, comp.uintptr_type, - emit_cast (comp.uintptr_type, ptr), + emit_coerce (comp.uintptr_type, ptr), offset)); } @@ -785,7 +790,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) emit_comment ("XUNTAG"); #ifndef WIDE_EMACS_INT - return emit_cast ( + return emit_coerce ( gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, @@ -798,7 +803,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) comp.emacs_int_type, lisp_word_tag))); #else - return emit_cast ( + return emit_coerce ( gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, @@ -806,9 +811,9 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) GCC_JIT_BINARY_OP_MINUS, comp.unsigned_long_long_type, /* FIXME Should be XLP. */ - emit_cast (comp.unsigned_long_long_type, emit_XLI (a)), - emit_cast (comp.unsigned_long_long_type, - emit_rvalue_from_long_long (lisp_word_tag)))); + emit_coerce (comp.unsigned_long_long_type, emit_XLI (a)), + emit_coerce (comp.unsigned_long_long_type, + emit_rvalue_from_long_long (lisp_word_tag)))); #endif } @@ -859,7 +864,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - emit_cast (comp.unsigned_type, sh_res), + emit_coerce (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -951,7 +956,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - emit_cast (comp.unsigned_type, sh_res), + emit_coerce (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -980,7 +985,7 @@ static gcc_jit_rvalue * emit_XFIXNUM (gcc_jit_rvalue *obj) { emit_comment ("XFIXNUM"); - gcc_jit_rvalue *i = emit_cast (comp.emacs_uint_type, emit_XLI (obj)); + gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); if (!USE_LSB_TAG) { @@ -988,7 +993,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_uint_type, - emit_cast (comp.emacs_uint_type, i), + emit_coerce (comp.emacs_uint_type, i), comp.inttypebits); return gcc_jit_context_new_binary_op (comp.ctxt, @@ -1016,8 +1021,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (obj)), + emit_coerce (comp.bool_type, + emit_FIXNUMP (obj)), emit_BIGNUMP (obj)); } @@ -1031,8 +1036,8 @@ emit_NUMBERP (gcc_jit_rvalue *obj) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, emit_INTEGERP (obj), - emit_cast (comp.bool_type, - emit_FLOATP (obj))); + emit_coerce (comp.bool_type, + emit_FLOATP (obj))); } static gcc_jit_rvalue * @@ -1049,7 +1054,7 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_int_type, - emit_cast (comp.emacs_uint_type, n), + emit_coerce (comp.emacs_uint_type, n), comp.inttypebits); tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -1082,16 +1087,16 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) */ gcc_jit_rvalue *intmask = - emit_cast (comp.emacs_uint_type, - emit_rvalue_from_long_long ((EMACS_INT_MAX - >> (INTTYPEBITS - 1)))); + emit_coerce (comp.emacs_uint_type, + emit_rvalue_from_long_long ((EMACS_INT_MAX + >> (INTTYPEBITS - 1)))); n = gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_BITWISE_AND, comp.emacs_uint_type, intmask, - emit_cast (comp.emacs_uint_type, n)); + emit_coerce (comp.emacs_uint_type, n)); n = gcc_jit_context_new_binary_op ( comp.ctxt, @@ -1103,12 +1108,12 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_uint_type, - emit_cast (comp.emacs_uint_type, comp.lisp_int0), + emit_coerce (comp.emacs_uint_type, comp.lisp_int0), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_uint_type, VALBITS)), n); - return emit_XLI (emit_cast (comp.emacs_int_type, n)); + return emit_XLI (emit_coerce (comp.emacs_int_type, n)); } @@ -1128,10 +1133,10 @@ emit_const_lisp_obj (Lisp_Object obj) SSDATA (Fprin1_to_string (obj, Qnil)))); if (NIL_IS_ZERO && EQ (obj, Qnil)) - return emit_cast (comp.lisp_obj_type, - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - NULL)); + return emit_coerce (comp.lisp_obj_type, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL)); imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_lvalue_as_rvalue ( @@ -1321,10 +1326,10 @@ emit_PURE_P (gcc_jit_rvalue *ptr) NULL, GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, - emit_cast (comp.uintptr_type, ptr), - emit_cast (comp.uintptr_type, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), + emit_coerce (comp.uintptr_type, ptr), + emit_coerce (comp.uintptr_type, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -1358,7 +1363,7 @@ emit_mvar_val (Lisp_Object mvar) : gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.void_ptr_type, constant); - return emit_cast (comp.lisp_obj_type, word); + return emit_coerce (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ return emit_const_lisp_obj (constant); @@ -1861,7 +1866,7 @@ static gcc_jit_rvalue * emit_consp (Lisp_Object insn) { gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); - gcc_jit_rvalue *res = emit_cast (comp.bool_type, + gcc_jit_rvalue *res = emit_coerce (comp.bool_type, emit_CONSP (x)); return gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2622,8 +2627,8 @@ define_CAR_CDR (void) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, gcc_jit_param_as_rvalue (param[1]), - emit_cast (comp.bool_type, - emit_CONSP (c))), + emit_coerce (comp.bool_type, + emit_CONSP (c))), is_cons_b, not_a_cons_b); comp.block = is_cons_b; @@ -2781,8 +2786,8 @@ define_add1_sub1 (void) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, gcc_jit_param_as_rvalue (param[1]), - emit_cast (comp.bool_type, - emit_FIXNUMP (n))); + emit_coerce (comp.bool_type, + emit_FIXNUMP (n))); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2865,8 +2870,8 @@ define_negate (void) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, gcc_jit_param_as_rvalue (param[1]), - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); + emit_coerce (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); emit_cond_jump ( gcc_jit_context_new_binary_op ( From 7009e8af055afcef85c30d8a3866689bd4e49a4a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Apr 2020 15:40:01 +0100 Subject: [PATCH 0802/1452] * src/comp.c (emit_binary_op): New function. Wrap gcc_jit_context_new_binary_op within emit_binary_op to make sure input type are coherent and save a slew of code. --- src/comp.c | 395 ++++++++++++++++++++++------------------------------- 1 file changed, 166 insertions(+), 229 deletions(-) diff --git a/src/comp.c b/src/comp.c index 75a2534b2ee..b56d0afaa3a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -635,6 +635,18 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) dest_field); } +static gcc_jit_rvalue * +emit_binary_op (enum gcc_jit_binary_op op, + gcc_jit_type *result_type, + gcc_jit_rvalue *a, gcc_jit_rvalue *b) +{ + /* FIXME Check here for possible UB. */ + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, + op, + result_type, + emit_coerce (result_type, a), + emit_coerce (result_type, b)); +} /* Should come with libgccjit. */ @@ -673,20 +685,16 @@ emit_rvalue_from_long_long (long long n) return emit_coerce (comp.long_long_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_BITWISE_OR, comp.unsigned_long_long_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.unsigned_long_long_type, - high, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.unsigned_long_long_type, - 32)), + emit_binary_op ( + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), low)); } @@ -726,25 +734,21 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, emit_comment ("ptr_arithmetic"); gcc_jit_rvalue *offset = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_MULT, comp.uintptr_type, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, size_of_ptr_ref), - emit_coerce (comp.uintptr_type, i)); + i); return emit_coerce ( ptr_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_PLUS, comp.uintptr_type, - emit_coerce (comp.uintptr_type, ptr), + ptr, offset)); } @@ -792,9 +796,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) #ifndef WIDE_EMACS_INT return emit_coerce ( gcc_jit_type_get_pointer (type), - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_MINUS, comp.emacs_int_type, emit_XLI (a), @@ -805,15 +807,12 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) #else return emit_coerce ( gcc_jit_type_get_pointer (type), - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_long_long_type, - /* FIXME Should be XLP. */ - emit_coerce (comp.unsigned_long_long_type, emit_XLI (a)), - emit_coerce (comp.unsigned_long_long_type, - emit_rvalue_from_long_long (lisp_word_tag)))); + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_long_long_type, + /* FIXME Should be XLP. */ + emit_XLI (a), + emit_rvalue_from_long_long (lisp_word_tag))); #endif } @@ -849,9 +848,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) emit_comment ("TAGGEDP"); gcc_jit_rvalue *sh_res = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, emit_XLI (obj), @@ -860,15 +857,14 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) (USE_LSB_TAG ? 0 : VALBITS))); gcc_jit_rvalue *minus_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_type, - emit_coerce (comp.unsigned_type, sh_res), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - tag)); + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + sh_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + tag)); gcc_jit_rvalue *res = gcc_jit_context_new_unary_op ( @@ -876,15 +872,14 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.int_type, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.unsigned_type, - minus_res, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - ((1 << GCTYPEBITS) - 1)))); + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << GCTYPEBITS) - 1)))); return res; } @@ -941,9 +936,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) emit_comment ("FIXNUMP"); gcc_jit_rvalue *sh_res = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, emit_XLI (obj), @@ -952,15 +945,14 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) (USE_LSB_TAG ? 0 : FIXNUM_BITS))); gcc_jit_rvalue *minus_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_type, - emit_coerce (comp.unsigned_type, sh_res), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - (Lisp_Int0 >> !USE_LSB_TAG))); + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + sh_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); gcc_jit_rvalue *res = gcc_jit_context_new_unary_op ( @@ -968,15 +960,14 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.int_type, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.unsigned_type, - minus_res, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - ((1 << INTTYPEBITS) - 1)))); + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); return res; } @@ -989,27 +980,21 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) if (!USE_LSB_TAG) { - i = gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_uint_type, - emit_coerce (comp.emacs_uint_type, i), - comp.inttypebits); + i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } else - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + return emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } static gcc_jit_rvalue * @@ -1017,13 +1002,10 @@ emit_INTEGERP (gcc_jit_rvalue *obj) { emit_comment ("INTEGERP"); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_coerce (comp.bool_type, - emit_FIXNUMP (obj)), - emit_BIGNUMP (obj)); + return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_FIXNUMP (obj), + emit_BIGNUMP (obj)); } static gcc_jit_rvalue * @@ -1031,13 +1013,10 @@ emit_NUMBERP (gcc_jit_rvalue *obj) { emit_comment ("NUMBERP"); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_INTEGERP (obj), - emit_coerce (comp.bool_type, - emit_FLOATP (obj))); + return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP (obj), + emit_FLOATP (obj)); } static gcc_jit_rvalue * @@ -1050,19 +1029,13 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) */ gcc_jit_rvalue *tmp = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - emit_coerce (comp.emacs_uint_type, n), - comp.inttypebits); + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + n, comp.inttypebits); - tmp = gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tmp, - comp.lisp_int0); + tmp = emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + tmp, comp.lisp_int0); gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, NULL, @@ -1090,29 +1063,21 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) emit_coerce (comp.emacs_uint_type, emit_rvalue_from_long_long ((EMACS_INT_MAX >> (INTTYPEBITS - 1)))); - n = gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.emacs_uint_type, - intmask, - emit_coerce (comp.emacs_uint_type, n)); + n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND, + comp.emacs_uint_type, + intmask, n); - n = gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_uint_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_uint_type, - emit_coerce (comp.emacs_uint_type, comp.lisp_int0), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_uint_type, - VALBITS)), - n); + n = + emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.emacs_uint_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + comp.lisp_int0, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_uint_type, + VALBITS)), + n); return emit_XLI (emit_coerce (comp.emacs_int_type, n)); } @@ -1321,15 +1286,12 @@ emit_PURE_P (gcc_jit_rvalue *ptr) comp.ctxt, NULL, GCC_JIT_COMPARISON_LE, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, - emit_coerce (comp.uintptr_type, ptr), - emit_coerce (comp.uintptr_type, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), + ptr, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL))), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -1611,7 +1573,7 @@ emit_limple_insn (Lisp_Object insn) */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue ( + gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), NULL, comp.m_handlerlist); @@ -1630,7 +1592,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qfetch_handler)) { gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field ( + gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), NULL, @@ -1641,18 +1603,18 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue (m_handlerlist)); gcc_jit_block_add_assignment ( - comp.block, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_next_field))); emit_frame_assignment ( - arg[0], - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( + arg[0], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_val_field))); @@ -1745,12 +1707,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - n), + { emit_binary_op (GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + n), gcc_jit_lvalue_as_rvalue (args) }; res = emit_call (Qlist, comp.lisp_obj_type, 2, @@ -2124,31 +2084,31 @@ emit_ctxt_code (void) comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.thread_state_ptr_type), - CURRENT_THREAD_RELOC_SYM)); + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.thread_state_ptr_type), + CURRENT_THREAD_RELOC_SYM)); comp.pure_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.void_ptr_type), - PURE_RELOC_SYM)); + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.void_ptr_type), + PURE_RELOC_SYM)); gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), - COMP_UNIT_SYM); + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), + COMP_UNIT_SYM); declare_imported_data (); - /* Functions imported from Lisp code. */ + /* Functions imported from Lisp code. */ freloc_check_fill (); gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); ptrdiff_t n_frelocs = 0; @@ -2621,16 +2581,12 @@ define_CAR_CDR (void) DECL_BLOCK (not_a_cons_b, func[i]); comp.block = entry_block; comp.func = func[i]; - emit_cond_jump ( - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - gcc_jit_param_as_rvalue (param[1]), - emit_coerce (comp.bool_type, - emit_CONSP (c))), - is_cons_b, - not_a_cons_b); + emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); comp.block = is_cons_b; if (i == 0) gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); @@ -2780,19 +2736,12 @@ define_add1_sub1 (void) gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); gcc_jit_rvalue *sure_fixnum = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - gcc_jit_param_as_rvalue (param[1]), - emit_coerce (comp.bool_type, - emit_FIXNUMP (n))); - + emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_FIXNUMP (n)); emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, sure_fixnum, @@ -2808,12 +2757,7 @@ define_add1_sub1 (void) comp.block = inline_block; gcc_jit_rvalue *inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - op[i], - comp.emacs_int_type, - n_fixnum, - comp.one); + emit_binary_op (op[i], comp.emacs_int_type, n_fixnum, comp.one); gcc_jit_block_end_with_return (inline_block, NULL, @@ -2864,29 +2808,22 @@ define_negate (void) gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); gcc_jit_rvalue *sure_fixnum = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - gcc_jit_param_as_rvalue (param[1]), - emit_coerce (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); + emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))); - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - sure_fixnum, - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - n_fixnum, - emit_most_negative_fixnum ())), - inline_block, - fcall_block); + emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + sure_fixnum, + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + emit_most_negative_fixnum ())), + inline_block, + fcall_block); comp.block = inline_block; gcc_jit_rvalue *inline_res = From 598380416cf5bb6bd0cae45ddb3bb03c74da21bb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Apr 2020 16:55:09 +0100 Subject: [PATCH 0803/1452] * src/comp.c (hash_native_abi): Fix assertion. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index b56d0afaa3a..904869d99c9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -258,7 +258,7 @@ hash_native_abi (void) hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); /* Check runs once. */ - eassert (Vcomp_abi_hash); + eassert (NILP (Vcomp_abi_hash)); Vcomp_abi_hash = digest; /* If 10 characters are usually sufficient for git I guess 16 are fine for us here. */ From 346d50989a446285d38d411f8f77350ba4af5222 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Apr 2020 19:40:51 +0100 Subject: [PATCH 0804/1452] * src/comp.c (emit_const_lisp_obj, emit_mvar_val): Fix. --- src/comp.c | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 904869d99c9..44de1f5fbcb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1098,10 +1098,19 @@ emit_const_lisp_obj (Lisp_Object obj) SSDATA (Fprin1_to_string (obj, Qnil)))); if (NIL_IS_ZERO && EQ (obj, Qnil)) - return emit_coerce (comp.lisp_obj_type, - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - NULL)); + { + gcc_jit_rvalue *n; +#ifdef WIDE_EMACS_INT + eassert (NIL_IS_ZERO); + n = emit_rvalue_from_long_long (0); +#else + n = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL); +#endif + return emit_coerce (comp.lisp_obj_type, n); + } + imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_lvalue_as_rvalue ( @@ -1319,12 +1328,15 @@ emit_mvar_val (Lisp_Object mvar) /* We can still emit directly objects that are self-contained in a word (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); - gcc_jit_rvalue *word = - (sizeof (MOST_POSITIVE_FIXNUM) > sizeof (void *)) - ? emit_rvalue_from_long_long (constant) - : gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.void_ptr_type, - constant); + gcc_jit_rvalue *word; +#ifdef WIDE_EMACS_INT + word = emit_rvalue_from_long_long (constant); +#else + word = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + constant); +#endif return emit_coerce (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ From 4263f2fd15e8439b8e8676ebeb6ab2f7f9339025 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Apr 2020 20:42:49 +0100 Subject: [PATCH 0805/1452] * src/comp.c (emit_XFIXNUM): Fix for LSB_TAG plus annotate a FIXME. --- src/comp.c | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 44de1f5fbcb..0a803545e59 100644 --- a/src/comp.c +++ b/src/comp.c @@ -985,16 +985,19 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) i, comp.inttypebits); - return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + return emit_coerce (comp.emacs_int_type, + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits)); } else - return emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + /* FIXME: Implementation dependent (wants arithmetic shift). */ + return emit_coerce (comp.emacs_int_type, + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits)); } static gcc_jit_rvalue * From a04c960a358811b598434c62528d2cac8a2a1cb7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 6 Apr 2020 19:04:43 +0100 Subject: [PATCH 0806/1452] * src/comp.c (emit_FIXNUMP): Don't emit a shift when unnecessary. --- src/comp.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0a803545e59..32fc7f23c4e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -936,13 +936,14 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) emit_comment ("FIXNUMP"); gcc_jit_rvalue *sh_res = - emit_binary_op ( - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, - (USE_LSB_TAG ? 0 : FIXNUM_BITS))); + USE_LSB_TAG ? obj + : emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_int_type, + FIXNUM_BITS)); gcc_jit_rvalue *minus_res = emit_binary_op ( From 32a079aef290fdc8913c1ce4e8910e63e6ff6dcc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 6 Apr 2020 20:03:34 +0100 Subject: [PATCH 0807/1452] * lisp/emacs-lisp/comp.el (comp-c-func-name): Fix for M-x disassemble --- lisp/emacs-lisp/comp.el | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3f4dba6b1ff..9dc775bb6ac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -474,14 +474,18 @@ Put PREFIX in front of it." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - ;; Prevent C namespace conflicts. - (cl-loop - with h = (comp-ctxt-funcs-h comp-ctxt) - for i from 0 - for c-sym = (concat prefix crypted "_" human-readable "_" - (number-to-string i)) - unless (gethash c-sym h) - return c-sym))) + (if comp-ctxt + ;; Prevent C namespace conflicts. + (cl-loop + with h = (comp-ctxt-funcs-h comp-ctxt) + for i from 0 + for c-sym = (concat prefix crypted "_" human-readable "_" + (number-to-string i)) + unless (gethash c-sym h) + return c-sym) + ;; When called out of a compilation context (ex disassembling) + ;; pick the first one. + (concat prefix crypted "_" human-readable "_0")))) (defun comp-decrypt-arg-list (x function-name) "Decript argument list X for FUNCTION-NAME." From 62f956970f5fe4b180ca57b290594530386d8b02 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 6 Apr 2020 18:03:34 +0100 Subject: [PATCH 0808/1452] * src/comp.c (native-comp-unit-file): Better parameter name. --- src/data.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/data.c b/src/data.c index b53b8409b59..2040e4eaecd 100644 --- a/src/data.c +++ b/src/data.c @@ -883,11 +883,12 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, 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 object) + (Lisp_Object comp_unit) { - CHECK_TYPE (NATIVE_COMP_UNITP (object), Qnative_comp_unit, object); - return XNATIVE_COMP_UNIT (object)->file; + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + XNATIVE_COMP_UNIT (comp_unit)->file = new_file; } + #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, From d85b803b78bc2a9b0424f0caac62a4e9de49b3e4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 10 Apr 2020 22:24:07 +0100 Subject: [PATCH 0809/1452] * src/comp.c (native-comp-unit-set-file): New function. --- src/data.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/data.c b/src/data.c index 2040e4eaecd..1809d58c2c7 100644 --- a/src/data.c +++ b/src/data.c @@ -884,9 +884,19 @@ 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 @@ -4007,6 +4017,7 @@ syms_of_data (void) defsubr (&Ssubr_native_elisp_p); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); + defsubr (&Snative_comp_unit_set_file); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); From f4156b452fd45ed4a706a2083755212c16ef88bb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 10 Apr 2020 22:30:34 +0100 Subject: [PATCH 0810/1452] Implement position independent dump. Set the filename for every compilation unit as realtive to obtain a position independent dump. * lisp/loadup.el: Modify filename for every compilation unit as position independent. * src/pdumper.c (dump_do_dump_relocation): Update to be invocation directory relative. --- lisp/loadup.el | 15 +++++++++++++++ src/pdumper.c | 3 ++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/lisp/loadup.el b/lisp/loadup.el index 97525b27086..bda9919cbbc 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,6 +449,21 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +(when (boundp 'comp-ctxt) ; FIXME better native-comp build discriminant? + ;; Set the filename for every compilation unit as realtive + ;; to obtain a position independent dump. + (let ((h (make-hash-table :test #'eq))) + (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 _) + (native-comp-unit-set-file + cu + (file-relative-name (native-comp-unit-file cu) + invocation-directory))) + h))) + (when (hash-table-p purify-flag) (let ((strings 0) (vectors 0) diff --git a/src/pdumper.c b/src/pdumper.c index 03c31681cd5..7fbacfe4a1a 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5298,7 +5298,8 @@ dump_do_dump_relocation (const uintptr_t dump_base, { struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); - comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + comp_u->handle = + dynlib_open (SSDATA (concat2 (Vinvocation_directory, comp_u->file))); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); From 7f5d1e9aa8e3ad27700dbce2b8951ffde1054aaf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Apr 2020 12:38:46 +0100 Subject: [PATCH 0811/1452] Set invocation variables during dump load. Vinvocation_directory must be set during dump load process to support .eln load. * src/pdumper.h: (pdumper_load): Add argv0 and original_pwd parameters. * src/pdumper.c (pdumper_load): Add argv0 and original_pwd parameter plus call 'set_invocation_vars'. * src/lisp.h (set_invocation_vars): New function. * src/emacs.c (set_invocation_vars): New function. (init_cmdargs): Move logic into 'set_invocation_vars' and call it. (load_pdump): Add 'original_pwd' parameter and update calls to 'pdumper_load'. (main): Set emacs_wd earlier and update call to 'pdumper_load'. --- src/emacs.c | 67 +++++++++++++++++++++++++++++++-------------------- src/lisp.h | 1 + src/pdumper.c | 5 +++- src/pdumper.h | 3 ++- 4 files changed, 48 insertions(+), 28 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index fcc02a3a874..2c908257422 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -403,34 +403,35 @@ 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) +/* Set `invocation-name' `invocation-directory'. */ + +void +set_invocation_vars (char *argv0, char const *original_pwd) { - int i; - Lisp_Object name, dir, handler; - ptrdiff_t count = SPECPDL_INDEX (); - Lisp_Object raw_name; + /* This function can be called from within pdumper or later during + boot. No need to run it twice. */ + static bool double_run_guard; + if (double_run_guard) + return; + double_run_guard = true; + + Lisp_Object raw_name, handler; AUTO_STRING (slash_colon, "/:"); - initial_argv = argv; - initial_argc = argc; - #ifdef WINDOWSNT - /* Must use argv[0] converted to UTF-8, as it begets many standard + /* Must use argv0 converted to UTF-8, as it begets many standard file and directory names. */ { - char argv0[MAX_UTF8_PATH]; + char argv0_1[MAX_UTF8_PATH]; - if (filename_from_ansi (argv[0], argv0) == 0) - raw_name = build_unibyte_string (argv0); + if (filename_from_ansi (argv0, argv0_1) == 0) + raw_name = build_unibyte_string (argv0_1); else - raw_name = build_unibyte_string (argv[0]); + raw_name = build_unibyte_string (argv0); } #else - raw_name = build_unibyte_string (argv[0]); + raw_name = build_unibyte_string (argv0); #endif /* Add /: to the front of the name @@ -442,7 +443,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); - /* If we got no directory in argv[0], search PATH to find where + /* If we got no directory in argv0, search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) { @@ -470,6 +471,21 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) Vinvocation_directory = Fexpand_file_name (Vinvocation_directory, odir); } +} + + +/* 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) +{ + int i; + Lisp_Object name, dir; + ptrdiff_t count = SPECPDL_INDEX (); + + initial_argv = argv; + initial_argc = argc; + + set_invocation_vars (argv[0], original_pwd); Vinstallation_directory = Qnil; @@ -758,7 +774,7 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) } static void -load_pdump (int argc, char **argv) +load_pdump (int argc, char **argv, char const *original_pwd) { const char *const suffix = ".pdmp"; int result; @@ -793,7 +809,7 @@ load_pdump (int argc, char **argv) if (dump_file) { - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result != PDUMPER_LOAD_SUCCESS) fatal ("could not load dump file \"%s\": %s", @@ -842,7 +858,7 @@ load_pdump (int argc, char **argv) if (bufsize < needed) dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1); strcpy (dump_file + exenamelen, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result == PDUMPER_LOAD_SUCCESS) goto out; @@ -873,7 +889,7 @@ 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); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result == PDUMPER_LOAD_FILE_NOT_FOUND) { @@ -908,7 +924,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, argv[0], original_pwd); } if (result != PDUMPER_LOAD_SUCCESS) @@ -929,7 +945,6 @@ main (int argc, char **argv) /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ void *stack_bottom_variable; - bool no_loadup = false; char *junk = 0; char *dname_arg = 0; @@ -1048,9 +1063,10 @@ main (int argc, char **argv) w32_init_main_thread (); #endif + emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (attempt_load_pdump) - load_pdump (argc, argv); + load_pdump (argc, argv, emacs_wd); #endif argc = maybe_disable_address_randomization (argc, argv); @@ -1122,7 +1138,6 @@ main (int argc, char **argv) exit (0); } - emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) pdumper_record_wd (emacs_wd); diff --git a/src/lisp.h b/src/lisp.h index 9eccbd2f794..5456b9cce8f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4423,6 +4423,7 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); +extern void set_invocation_vars (char *argv0, char const *original_pwd); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif diff --git a/src/pdumper.c b/src/pdumper.c index 7fbacfe4a1a..69594b51c59 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5428,7 +5428,7 @@ enum dump_section 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, char const *original_pwd) { intptr_t dump_size; struct stat stat; @@ -5574,6 +5574,9 @@ pdumper_load (const char *dump_filename) for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + /* Once we can allocate and before loading .eln files we must set + Vinvocation_directory (.eln paths are relative to it). */ + set_invocation_vars (argv0, original_pwd); 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); initialized = true; diff --git a/src/pdumper.h b/src/pdumper.h index 6a99b511f2f..b92958e12bc 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -127,7 +127,8 @@ 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, + char const *original_pwd); struct pdumper_loaded_dump { From 3dd6cf813953ffda1a581243faa098f3b8f7c12b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 11 Apr 2020 13:59:59 +0100 Subject: [PATCH 0812/1452] Implement working make install for native build. --- Makefile.in | 3 ++- lisp/loadup.el | 27 ++++++++++++++++++++------- src/Makefile.in | 3 ++- src/pdumper.c | 5 +++++ 4 files changed, 29 insertions(+), 9 deletions(-) diff --git a/Makefile.in b/Makefile.in index 67e15cfecd2..2f6a68fd9d7 100644 --- a/Makefile.in +++ b/Makefile.in @@ -421,7 +421,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='$(DESTDIR)${bindir}/' \ + LISP_DESTDIR='$(DESTDIR)${lispdir}/' all blessmail: Makefile src $(MAKE) -C lib-src maybe-blessmail diff --git a/lisp/loadup.el b/lisp/loadup.el index bda9919cbbc..3cc47bc91fa 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,19 +449,32 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (boundp 'comp-ctxt) ; FIXME better native-comp build discriminant? - ;; Set the filename for every compilation unit as realtive - ;; to obtain a position independent dump. - (let ((h (make-hash-table :test #'eq))) +(when (boundp 'comp-ctxt) ; FIXME better native-comp feature discriminant? + ;; Fix the compilation unit filename to have it working when + ;; when installed or if the source directory got moved. This is set to be + ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). + (let ((h (make-hash-table :test #'eq)) + (lisp-src-dir (expand-file-name (concat default-directory "../lisp"))) + (bin-dest-dir (cadr (member "--bin-dest" command-line-args))) + (lisp-dest-dir (cadr (member "--lisp-dest" command-line-args)))) (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 _) - (native-comp-unit-set-file + (native-comp-unit-set-file cu - (file-relative-name (native-comp-unit-file cu) - invocation-directory))) + (cons + ;; Relative path from the installed binary. + (file-relative-name + (concat lisp-dest-dir + (replace-regexp-in-string + (regexp-quote lisp-src-dir) "" + (native-comp-unit-file cu))) + bin-dest-dir) + ;; Relative path from the built uninstalled binary. + (file-relative-name (native-comp-unit-file cu) + invocation-directory)))) h))) (when (hash-table-p purify-flag) diff --git a/src/Makefile.in b/src/Makefile.in index 429f7035443..7f86e96cdb4 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -588,7 +588,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) --lisp-dest $(LISP_DESTDIR) cp -f $@ $(bootstrap_pdmp) endif diff --git a/src/pdumper.c b/src/pdumper.c index 69594b51c59..490f357219d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5298,6 +5298,11 @@ dump_do_dump_relocation (const uintptr_t dump_base, { struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); + if (!CONSP (comp_u->file)) + error ("Trying to load incoherent dumped .eln"); + comp_u->file = + NILP (Ffile_exists_p (XCAR (comp_u->file))) + ? XCDR (comp_u->file) : XCAR (comp_u->file); comp_u->handle = dynlib_open (SSDATA (concat2 (Vinvocation_directory, comp_u->file))); if (!comp_u->handle) From b56de5dda235599c0dcb26c9d4936aaf8be46db3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Apr 2020 13:06:14 +0100 Subject: [PATCH 0813/1452] * src/pdumper.c (dump_do_dump_relocation): Optimize native dump load. Check just once if is a local build or Emacs got installed. --- src/pdumper.c | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 490f357219d..bf6bc3a3bc3 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5296,15 +5296,25 @@ dump_do_dump_relocation (const uintptr_t dump_base, #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); + if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); + + if (installation_state == UNKNOWN) + /* Check just once if is a local build or Emacs got installed. */ + installation_state = + NILP (Ffile_exists_p (concat2 (Vinvocation_directory, + XCAR (comp_u->file)))) + ? LOCAL_BUILD : INSTALLED; + comp_u->file = - NILP (Ffile_exists_p (XCAR (comp_u->file))) - ? XCDR (comp_u->file) : XCAR (comp_u->file); - comp_u->handle = - dynlib_open (SSDATA (concat2 (Vinvocation_directory, comp_u->file))); + concat2 (Vinvocation_directory, + installation_state == LOCAL_BUILD + ? XCDR (comp_u->file) : XCAR (comp_u->file)); + comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); From 6e09597e27fd769e734ddacca8824abd6769257d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Apr 2020 21:15:52 +0100 Subject: [PATCH 0814/1452] Introduce load-true-file-name * src/comp.c (maybe_defer_native_compilation): Use `load-true-file-name' instead of `load-file-name'. * src/lread.c (Fload, end_of_file_error, read1, read_list) (init_lread, syms_of_lread): Add new `load-true-file-name' and fake `load-file-name' value when loading .eln files. --- src/comp.c | 10 +++++----- src/lread.c | 35 ++++++++++++++++++++++++++++------- 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 32fc7f23c4e..4bd271402c2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3467,7 +3467,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, #include #include if (!NILP (function_name) && - STRINGP (Vload_file_name)) + STRINGP (Vload_true_file_name)) { static FILE *f; if (!f) @@ -3480,7 +3480,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, exit (1); fprintf (f, "function %s file %s\n", SSDATA (Fsymbol_name (function_name)), - SSDATA (Vload_file_name)); + SSDATA (Vload_true_file_name)); fflush (f); } #endif @@ -3489,12 +3489,12 @@ maybe_defer_native_compilation (Lisp_Object function_name, || !NILP (Vpurify_flag) || !COMPILEDP (definition) || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) - || !STRINGP (Vload_file_name) - || !suffix_p (Vload_file_name, ".elc")) + || !STRINGP (Vload_true_file_name) + || !suffix_p (Vload_true_file_name, ".elc")) return; Lisp_Object src = - concat2 (CALL1I (file-name-sans-extension, Vload_file_name), + concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name), build_pure_c_string (".el")); if (NILP (Ffile_exists_p (src))) return; diff --git a/src/lread.c b/src/lread.c index 2b1ac93aa91..937b4566851 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1467,7 +1467,20 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - specbind (Qload_file_name, found); + if (is_native_elisp) + { + Lisp_Object dir = Ffile_name_directory (found); + Lisp_Object parent_dir = + Ffile_name_directory (Fsubstring (dir, + make_fixnum (0), + Fsub1 (Flength (dir)))); + specbind (Qload_file_name, + concat2 (parent_dir, + Ffile_name_nondirectory (found))); + } + else + specbind (Qload_file_name, found); + specbind (Qload_true_file_name, found); specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); @@ -1928,8 +1941,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); } @@ -3161,7 +3174,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; } if (c == '$') - return Vload_file_name; + return Vload_true_file_name; if (c == '\'') return list2 (Qfunction, read0 (readcharfun)); /* #:foo is the uninterned symbol named foo. */ @@ -3960,7 +3973,7 @@ read_list (bool flag, Lisp_Object readcharfun) first_in_list = 0; /* While building, if the list starts with #$, treat it specially. */ - if (EQ (elt, Vload_file_name) + if (EQ (elt, Vload_true_file_name) && ! NILP (elt) && !NILP (Vpurify_flag)) { @@ -3981,7 +3994,7 @@ read_list (bool flag, Lisp_Object readcharfun) elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); } } - else if (EQ (elt, Vload_file_name) + else if (EQ (elt, Vload_true_file_name) && ! NILP (elt) && load_force_doc_strings) doc_reference = 2; @@ -4737,6 +4750,7 @@ init_lread (void) load_in_progress = 0; Vload_file_name = Qnil; + Vload_true_file_name = Qnil; Vstandard_input = Qt; Vloads_in_progress = Qnil; } @@ -4938,9 +4952,15 @@ 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 a .eln file is being loaded this is unreliable and `load-true-file-name' +should be used instead. */); 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 @@ -5082,6 +5102,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"); From c8b7e07553a77d9c57e2022a06c651513109ea5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Apr 2020 22:17:08 +0100 Subject: [PATCH 0815/1452] Revert "Fix org for eln new compilation folder layout" This reverts commit f77f6ca77054ca6122df2742345710b7493ad293. --- lisp/org/org.el | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/lisp/org/org.el b/lisp/org/org.el index a9303e880b8..f1a7f61a9a1 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -78,10 +78,8 @@ (or (eq this-command 'eval-buffer) (condition-case nil - (load (expand-file-name "org-loaddefs.el" - (if (string-match "[.]eln$" load-file-name) - (concat (file-name-directory load-file-name) "..") - (file-name-directory load-file-name))) + (load (concat (file-name-directory load-file-name) + "org-loaddefs.el") nil t t t) (error (message "WARNING: No org-loaddefs.el file could be found from where org.el is loaded.") From 1c5548f1c51b44b78d05deb11a31b8678df7b4e7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 13 Apr 2020 11:07:11 +0100 Subject: [PATCH 0816/1452] * src/lread.c (Fload): Add comment. --- src/lread.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/lread.c b/src/lread.c index 937b4566851..18a56d0969c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1469,6 +1469,11 @@ Return t if the file exists and loads successfully. */) if (is_native_elisp) { + /* Many packages use `load-file-name' as a way to obtain the + package location (see bug#40099). .eln files are not in the + same folder of their respective sources therfore not to break + packages we fake `load-file-name' here. The non faked + version of it is `load-true-file-name'. */ Lisp_Object dir = Ffile_name_directory (found); Lisp_Object parent_dir = Ffile_name_directory (Fsubstring (dir, From 05adf0353faf0bff3da60230a691b381de297843 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 13 Apr 2020 16:54:03 +0100 Subject: [PATCH 0817/1452] Fix function find mechanism for installed instance. * src/lread.c (parent_directory): New function. (Fload): Make use of 'parent_directory' and fix load-history build-up with relative paths. --- src/lread.c | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/lread.c b/src/lread.c index 18a56d0969c..9bd60b9b386 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1102,6 +1102,14 @@ close_infile_unwind (void *arg) infile = prev_infile; } +static Lisp_Object +parent_directory (Lisp_Object directory) +{ + return Ffile_name_directory (Fsubstring (directory, + make_fixnum (0), + Fsub1 (Flength (directory)))); +} + 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 @@ -1474,13 +1482,8 @@ Return t if the file exists and loads successfully. */) same folder of their respective sources therfore not to break packages we fake `load-file-name' here. The non faked version of it is `load-true-file-name'. */ - Lisp_Object dir = Ffile_name_directory (found); - Lisp_Object parent_dir = - Ffile_name_directory (Fsubstring (dir, - make_fixnum (0), - Fsub1 (Flength (dir)))); specbind (Qload_file_name, - concat2 (parent_dir, + concat2 (parent_directory (Ffile_name_directory (found)), Ffile_name_nondirectory (found))); } else @@ -1506,9 +1509,15 @@ Return t if the file exists and loads successfully. */) if (NATIVE_COMP_FLAG) { specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (found); + if (!NILP (Vpurify_flag)) + { + Lisp_Object base = parent_directory (Ffile_name_directory (found)); + Lisp_Object offset = Flength (base); + hist_file_name = Fsubstring (found, offset, Qnil); + } + LOADHIST_ATTACH (hist_file_name); Fnative_elisp_load (found, Qnil); - build_load_history (found, true); + build_load_history (hist_file_name, true); } else /* This cannot happen. */ From 97873235523dd6fc236b3ebc7bf34a53fb5a528a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 13 Apr 2020 16:57:27 +0100 Subject: [PATCH 0818/1452] * src/lread.c (Fload): Clean-up unnecessary sanity check. 'is_native_elisp' can't be non zero if NATIVE_COMP_FLAG is not set. --- src/lread.c | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/src/lread.c b/src/lread.c index 9bd60b9b386..1e05ac69320 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1506,22 +1506,16 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { - if (NATIVE_COMP_FLAG) + specbind (Qcurrent_load_list, Qnil); + if (!NILP (Vpurify_flag)) { - specbind (Qcurrent_load_list, Qnil); - if (!NILP (Vpurify_flag)) - { - Lisp_Object base = parent_directory (Ffile_name_directory (found)); - Lisp_Object offset = Flength (base); - hist_file_name = Fsubstring (found, offset, Qnil); - } - LOADHIST_ATTACH (hist_file_name); - Fnative_elisp_load (found, Qnil); - build_load_history (hist_file_name, true); + Lisp_Object base = parent_directory (Ffile_name_directory (found)); + Lisp_Object offset = Flength (base); + hist_file_name = Fsubstring (found, offset, Qnil); } - else - /* This cannot happen. */ - emacs_abort (); + LOADHIST_ATTACH (hist_file_name); + Fnative_elisp_load (found, Qnil); + build_load_history (hist_file_name, true); } else { From 9f42f35418c568ae22eca65ecec773ff40f2fc0e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 13 Apr 2020 20:39:15 +0100 Subject: [PATCH 0819/1452] * Fix native-compile-async for bug#40602. * lisp/emacs-lisp/comp.el (native-compile-async): Relax coherency condition. --- lisp/emacs-lisp/comp.el | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9dc775bb6ac..a4764f91c3a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2311,9 +2311,13 @@ LOAD can be nil t or 'late." (list "Path not a file nor directory" path))))) (dolist (file files) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - (cl-assert (eq load (cdr entry)) - nil "Incoherent load kind in compilation queue for %s" - file) + (when load + ;; When no load is specified (plain async compilation) we + ;; consider valid the one previously queued, otherwise we + ;; check for coherence (bug#40602). + (cl-assert (eq load (cdr entry)) + nil "Incoherent load kind in compilation queue for %s" + file)) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) From b7678cf10e13727dab300c7162649cafc488e27e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 13 Apr 2020 20:43:21 +0100 Subject: [PATCH 0820/1452] * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Better commentary. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a4764f91c3a..fda8f7dc780 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2082,11 +2082,11 @@ Update all insn accordingly." (d-impure-idx (comp-data-container-idx d-impure)) (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) - ;; Remove things in d-impure that are already in d-default. + ;; Remove entries in d-impure already present in d-default. (cl-loop for obj being each hash-keys of d-impure-idx when (gethash obj d-default-idx) do (remhash obj d-impure-idx)) - ;; Remove things in d-ephemeral that are already in d-default or + ;; Remove entries in d-ephemeral already present in d-default or ;; d-impure. (cl-loop for obj being each hash-keys of d-ephemeral-idx when (or (gethash obj d-default-idx) (gethash obj d-impure-idx)) From 8decfbe4d75b538707fa794c395d712bfde407f4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 14 Apr 2020 08:48:24 +0100 Subject: [PATCH 0821/1452] * lisp/emacs-lisp/comp.el (native-compile-async): Better error message. --- lisp/emacs-lisp/comp.el | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fda8f7dc780..788ffb5b776 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2311,13 +2311,14 @@ LOAD can be nil t or 'late." (list "Path not a file nor directory" path))))) (dolist (file files) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - (when load - ;; When no load is specified (plain async compilation) we - ;; consider valid the one previously queued, otherwise we - ;; check for coherence (bug#40602). - (cl-assert (eq load (cdr entry)) - nil "Incoherent load kind in compilation queue for %s" - file)) + ;; When no load is specified (plain async compilation) we + ;; consider valid the one previously queued, otherwise we + ;; check for coherence (bug#40602). + (cl-assert (or (null load) + (eq load (cdr entry))) + nil "Trying to queue %s with LOAD %s but this is already \ +queued with LOAD %" + file load (cdr entry)) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) From 8db8c851ad1568d61ed50a4d087e6de2b475cf5f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 14 Apr 2020 19:58:41 +0100 Subject: [PATCH 0822/1452] Always set `load-true-file-name' where `load-file-name' is set too. Fix bug#40620. * lisp/cus-dep.el (custom-make-dependencies): Set load-true-file-name. * lisp/emacs-lisp/package.el (package-quickstart-refresh): Likewise. * lisp/international/mule.el (load-with-code-conversion): Likewise. * lisp/loadup.el (load-true-file-name): Likewise. --- lisp/cus-dep.el | 1 + lisp/emacs-lisp/autoload.el | 4 +++- lisp/emacs-lisp/package.el | 3 ++- lisp/international/mule.el | 5 +++-- lisp/loadup.el | 1 + 5 files changed, 10 insertions(+), 4 deletions(-) diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index fd307a5c04e..e2c2ebe5f42 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -90,6 +90,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 diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 6180bee2aa7..d9a43c23299 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -167,7 +167,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. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4312ab9ca9a..b33e4897a01 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3965,7 +3965,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) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 72e8cad9d62..363df13dfe6 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -320,8 +320,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 diff --git a/lisp/loadup.el b/lisp/loadup.el index 3cc47bc91fa..7cf2cb01c33 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -566,6 +566,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) From c5ed3a72a8a70931ef9b0f9d69f73ff0fd40cadb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 15 Apr 2020 22:55:30 +0100 Subject: [PATCH 0823/1452] * lisp/subr.el (eval-after-load): Make use of load-true-file-name bug#40638 --- lisp/subr.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index f7445d8c25e..c8eb12760c4 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4600,10 +4600,10 @@ This function makes or adds to an entry on `after-load-alist'." ;; So add an indirection to make sure that `func' is really run ;; "after-load" in case the provide call happens early. (lambda () - (if (not load-file-name) + (if (not load-true-file-name) ;; Not being provided from a file, run func right now. (funcall func) - (let ((lfn load-file-name) + (let ((lfn load-true-file-name) ;; Don't use letrec, because equal (in ;; add/remove-hook) would get trapped in a cycle. (fun (make-symbol "eval-after-load-helper"))) From 886ded1b70f24c52ee526f0c4a69ca06829fb2a3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 16 Apr 2020 18:59:40 +0100 Subject: [PATCH 0824/1452] * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Add yes-or-no-p --- lisp/emacs-lisp/comp.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 788ffb5b776..2cc7dfd17f7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,8 +85,11 @@ This intended for debugging the compiler itself. :group 'comp) (defcustom comp-never-optimize-functions - '(macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer - make-indirect-buffer delete-file top-level abort-recursive-edit) + '(;; Mandatory for Emacs to be working correctly + macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer + make-indirect-buffer delete-file top-level abort-recursive-edit + ;; For user convenience + yes-or-no-p) "Primitive functions for which we do not perform trampoline optimization. This is especially usefull for primitives known to be advised if bootstrap is performed at `comp-speed' > 0." From 65cc8efa333bbb66acd7b19f4b39c3138995e864 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 16 Apr 2020 19:03:54 +0100 Subject: [PATCH 0825/1452] * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Better doc fix --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cc7dfd17f7..7486e807492 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -91,8 +91,8 @@ This intended for debugging the compiler itself. ;; For user convenience yes-or-no-p) "Primitive functions for which we do not perform trampoline optimization. -This is especially usefull for primitives known to be advised if bootstrap is -performed at `comp-speed' > 0." +This is especially useful for primitives known to be advised or +redefined when compilation is performed at `comp-speed' > 0." :type 'list :group 'comp) From 81389d5f2dcb41730dcbc76874cc14eadb53ae75 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 23 Apr 2020 08:54:46 +0100 Subject: [PATCH 0826/1452] * lisp/emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded): Add comp.eln --- lisp/emacs-lisp/bytecomp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ff84d94897c..9a5491b10fc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5148,7 +5148,8 @@ Use with caution." (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) - (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) + (when (string-match "el[cn]\\'" f) + (setq f (substring f 0 -1))) (when (and (file-readable-p f) (file-newer-than-file-p f emacs-file) ;; Don't reload the source version of the files below @@ -5157,7 +5158,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) From b380451c6a6f1464520e2cb431aacea84f933b32 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 Apr 2020 19:02:55 +0100 Subject: [PATCH 0827/1452] * lisp/emacs-lisp/comp.el (comp-run-async-workers): Fix non late load. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7486e807492..1693e06018a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2211,7 +2211,7 @@ display a message." (zerop (process-exit-status process))) (native-elisp-load (comp-output-filename source-file1) - load1)) + (eq load1 'late))) (comp-run-async-workers))))) (push process comp-async-processes)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) From c120dbc73a0c7f17f6dab190544c0b43f56ec206 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 Apr 2020 19:23:34 +0100 Subject: [PATCH 0828/1452] * lisp/subr.el (subr-primitive-p): New inline function. --- lisp/subr.el | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lisp/subr.el b/lisp/subr.el index 006766587bc..1dd768c3a61 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -233,6 +233,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 From 3ac3ba22be5fa08434ef7e2e37ad2376798f61ef Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 24 Apr 2020 19:24:07 +0100 Subject: [PATCH 0829/1452] * lisp/subr.el (called-interactively-p): Fix for native code bug#40694. --- lisp/subr.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/subr.el b/lisp/subr.el index 1dd768c3a61..5cf80f8e4b8 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -5131,7 +5131,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 # without going through the ;; `funcall-interactively' symbol (bug#3984). (`(,_ . (t ,(pred (lambda (f) From e208de9d259cb50c19d1f2a5086fd8301ac71781 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 14:39:11 +0100 Subject: [PATCH 0830/1452] Store ongoing compilations processes as hash table. * lisp/emacs-lisp/comp.el (comp-async-processes): Rename as `comp-async-compilations'. (comp-async-runnings): Make use as `comp-async-compilations'. (comp-run-async-workers): Likewise. --- lisp/emacs-lisp/comp.el | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1693e06018a..1369dd115dd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2146,16 +2146,21 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-files-queue () "List of Elisp files to be compiled.") -(defvar comp-async-processes () - "List of running async compilation processes.") +(defvar comp-async-compilations (make-hash-table :test #'equal) + "Hash table file-name -> async compilation process.") (defun comp-async-runnings () "Return the number of async compilations currently running. This function has the side effect of cleaning-up finished -processes from `comp-async-processes'" - (setf comp-async-processes - (cl-delete-if-not #'process-live-p comp-async-processes)) - (length comp-async-processes)) +processes from `comp-async-compilations'" + (cl-loop + for file-name in (cl-loop + for file-name being each hash-key of comp-async-compilations + for prc = (gethash file-name comp-async-compilations) + unless (process-live-p prc) + collect file-name) + do (remhash file-name comp-async-compilations)) + (hash-table-count comp-async-compilations)) (let (num-cpus) (defun comp-effective-async-max-jobs () @@ -2213,7 +2218,7 @@ display a message." (comp-output-filename source-file1) (eq load1 'late))) (comp-run-async-workers))))) - (push process comp-async-processes)) + (puthash source-file process comp-async-compilations)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) ;; No files left to compile and all processes finished. From bab36619fb26059e3ac7c794738be4314c681e08 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 14:45:21 +0100 Subject: [PATCH 0831/1452] Fix deferred-compilation for double compilation (bug#40838). * lisp/emacs-lisp/comp.el (native-compile-async): Prevent double compilation (bug#40838). --- lisp/emacs-lisp/comp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1369dd115dd..42c40aaa43a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2327,7 +2327,9 @@ LOAD can be nil t or 'late." nil "Trying to queue %s with LOAD %s but this is already \ queued with LOAD %" file load (cdr entry)) - (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) + ;; Make sure we are not already compiling `file' (bug#40838). + (unless (gethash file comp-async-compilations) + (setf comp-files-queue (append comp-files-queue `((,file . ,load))))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) (message "Compilation started.")))) From 9c4c0af89d88f5b4a9124741f64915c5378f1283 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 15:43:10 +0100 Subject: [PATCH 0832/1452] * lisp/emacs-lisp/comp.el (comp-run-async-workers): Use `clrhash'. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 42c40aaa43a..e96de273359 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2230,7 +2230,7 @@ display a message." (insert msg "\n"))) ;; `comp-deferred-pending-h' should be empty at this stage. ;; Reset it anyway. - (setf comp-deferred-pending-h (make-hash-table :test #'eq)) + (clrhash comp-deferred-pending-h) (message msg)))) From d73e64076e08cf0bcb81ea9d161fb7409e1bf896 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 16:13:03 +0100 Subject: [PATCH 0833/1452] Store function documentations in a hash table. * src/pdumper.c (dump_subr): Update Lisp_Subr hash. (dump_subr): Update for new compilation unit layout. (dump_vectorlike): Update pvec_type hash. * src/lisp.h (struct Lisp_Subr): Remove 'native_doc' index. (DEFUN): Update macro for new compilation unit layout. * src/doc.c (Fdocumentation): Update for new compilation unit layout. * src/comp.h (struct Lisp_Native_Comp_Unit): Add 'data_fdoc_h' field. * src/comp.c (TEXT_FDOC_SYM): New macro. (emit_ctxt_code): Emit function documentations. (load_comp_unit): Load function documentation. (Fcomp__register_subr): Rename parameter. (Fcomp__register_subr): Update for new compilation unit layout. * src/alloc.c (mark_object): Update for new compilation unit layout. (syms_of_alloc): Likewise. * lisp/emacs-lisp/comp.el (comp-ctxt): Add doc-index-h slot. (comp-emit-for-top-level): Emit doc index as 'comp--register-subr' doc parameter. --- lisp/emacs-lisp/comp.el | 9 ++++++++- src/alloc.c | 5 ++--- src/comp.c | 12 ++++++++++-- src/comp.h | 2 ++ src/doc.c | 5 ++++- src/lisp.h | 7 ++----- src/pdumper.c | 7 +++---- 7 files changed, 31 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e96de273359..5096a143a0f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -216,6 +216,8 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") + (doc-index-h (make-hash-table :test #'eql) :type hash-table + :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container @@ -1214,7 +1216,12 @@ the annotation emission." (comp-args-max args) 'many)) (make-comp-mvar :constant c-name) - (make-comp-mvar :constant (comp-func-doc f)) + (make-comp-mvar + :constant + (let* ((h (comp-ctxt-doc-index-h comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i)) (make-comp-mvar :constant (comp-func-int-spec f)) ;; This is the compilation unit it-self passed as diff --git a/src/alloc.c b/src/alloc.c index 147e018095b..f2b80fac882 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6638,7 +6638,6 @@ mark_object (Lisp_Object arg) set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); - mark_object (subr->native_doc); mark_object (subr->native_comp_u[0]); } break; @@ -7529,14 +7528,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); } diff --git a/src/comp.c b/src/comp.c index 4bd271402c2..2f59164b770 100644 --- a/src/comp.c +++ b/src/comp.c @@ -41,13 +41,17 @@ along with GNU Emacs. If not, see . */ #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" #define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph" + #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" #define COMP_UNIT_SYM "comp_unit" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" + #define TEXT_OPTIM_QLY "text_optim_qly" +#define TEXT_FDOC_SYM "text_data_fdoc" + #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -2097,6 +2101,9 @@ emit_ctxt_code (void) Fsymbol_value (Qcomp_debug)) }; emit_static_object (TEXT_OPTIM_QLY, Flist (2, opt_qly)); + emit_static_object (TEXT_FDOC_SYM, + CALL1I (comp-ctxt-doc-index-h, Vcomp_ctxt)); + comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -3619,6 +3626,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + comp_u->data_fdoc_h = load_static_obj (comp_u, TEXT_FDOC_SYM); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3668,7 +3676,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, Lisp_Object comp_u) { dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; @@ -3688,7 +3696,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; - x->s.native_doc = doc; + x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); diff --git a/src/comp.h b/src/comp.h index f5baa88853e..6710227b44d 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,6 +37,8 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; + /* Hash doc-idx -> function documentaiton. */ + Lisp_Object data_fdoc_h; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Same but for data that cannot be moved to pure space. diff --git a/src/doc.c b/src/doc.c index 1b6aa01ef04..8191a914c6e 100644 --- a/src/doc.c +++ b/src/doc.c @@ -337,7 +337,10 @@ string is passed through `substitute-command-keys'. */) fun = XCDR (fun); #ifdef HAVE_NATIVE_COMP if (!NILP (Fsubr_native_elisp_p (fun))) - doc = XSUBR (fun)->native_doc; + doc = + Fgethash (make_fixnum (XSUBR (fun)->doc), + XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (fun))->data_fdoc_h, + Qnil); else #endif if (SUBRP (fun)) diff --git a/src/lisp.h b/src/lisp.h index 1cec62a853c..3d082911f54 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2098,10 +2098,7 @@ struct Lisp_Subr const char *intspec; Lisp_Object native_intspec; }; - union { - EMACS_INT doc; - Lisp_Object native_doc; - }; + EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr @@ -3077,7 +3074,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); diff --git a/src/pdumper.c b/src/pdumper.c index bf6bc3a3bc3..702b3ffced9 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2938,7 +2938,7 @@ static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { #if CHECK_STRUCTS && ((defined (HAVE_NATIVE_COMP) \ - && !defined (HASH_Lisp_Subr_D4F15794AF)) \ + && !defined (HASH_Lisp_Subr_99B6674034)) \ || (!defined (HAVE_NATIVE_COMP) \ && !defined (HASH_Lisp_Subr_594AB72B54))) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." @@ -2959,14 +2959,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) COLD_OP_NATIVE_SUBR, make_lisp_ptr ((void *) subr, Lisp_Vectorlike)); dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); - dump_field_lv (ctx, &out, subr, &subr->native_doc, 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); } + DUMP_FIELD_COPY (&out, subr, doc); if (NATIVE_COMP_FLAG) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); @@ -3023,7 +3022,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); From d3984becca4111d55c540ecab93c5075efa5afba Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 16:50:50 +0100 Subject: [PATCH 0834/1452] * src/comp.c (declare_function): fix missing NILP. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 2f59164b770..e95ab51cb56 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3016,7 +3016,7 @@ declare_function (Lisp_Object func) gcc_jit_function *gcc_func; char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); Lisp_Object args = CALL1I (comp-func-args, func); - bool nargs = (CALL1I (comp-nargs-p, args)); + bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; if (!nargs) From e95dca6683e9c8cd08f38bb4f73cbade06cfb209 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 17:33:58 +0100 Subject: [PATCH 0835/1452] * Rename TEXT_OPTIM_QLY into TEXT_OPTIM_QLY_SYM. * src/comp.c (TEXT_OPTIM_QLY): Rename into TEXT_OPTIM_QLY_SYM. (emit_ctxt_code): Update TEXT_OPTIM_QLY naming. (load_comp_unit): Likewise. --- src/comp.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index e95ab51cb56..70b0a25a9c0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -49,7 +49,7 @@ along with GNU Emacs. If not, see . */ #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" -#define TEXT_OPTIM_QLY "text_optim_qly" +#define TEXT_OPTIM_QLY_SYM "text_optim_qly" #define TEXT_FDOC_SYM "text_data_fdoc" @@ -2099,7 +2099,7 @@ emit_ctxt_code (void) Fsymbol_value (Qcomp_speed)), Fcons (Qcomp_debug, Fsymbol_value (Qcomp_debug)) }; - emit_static_object (TEXT_OPTIM_QLY, Flist (2, opt_qly)); + emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, opt_qly)); emit_static_object (TEXT_FDOC_SYM, CALL1I (comp-ctxt-doc-index-h, Vcomp_ctxt)); @@ -3622,7 +3622,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* Imported data. */ if (!loading_dump) { - comp_u->optimize_qualities = load_static_obj (comp_u, TEXT_OPTIM_QLY); + comp_u->optimize_qualities = + load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM); comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); From f691af80f1c2073e610a382029790f7c6f97dd5d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 18:10:06 +0100 Subject: [PATCH 0836/1452] * src/comp.h (load_comp_unit): Fix declaration style. --- src/comp.h | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/comp.h b/src/comp.h index 6710227b44d..c0598468117 100644 --- a/src/comp.h +++ b/src/comp.h @@ -66,8 +66,9 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void hash_native_abi (void); -void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, - bool late_load); +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump, bool late_load); + extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, From a7fac2e91fb424fcf47ea8a23c218c272dd83434 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 18:16:17 +0100 Subject: [PATCH 0837/1452] Lazy load function documentation. * src/comp.c (native_function_doc): New function. (load_comp_unit): Do not load function doc during load. * src/comp.h: Extern 'native_function_doc'. * src/doc.c (Fdocumentation): Call 'native_function_doc' to retrive function doc. * src/pdumper.c (dump_native_comp_unit): Zero 'data_fdoc_h' before dumping. --- src/comp.c | 17 ++++++++++++++++- src/comp.h | 2 ++ src/doc.c | 5 +---- src/pdumper.c | 4 +++- 4 files changed, 22 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 70b0a25a9c0..b33ef92f72b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3627,7 +3627,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); - comp_u->data_fdoc_h = load_static_obj (comp_u, TEXT_FDOC_SYM); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3672,6 +3671,22 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, return; } +Lisp_Object +native_function_doc (Lisp_Object function) +{ + struct Lisp_Native_Comp_Unit *cu = + XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function)); + + if (NILP (cu->data_fdoc_h)) + cu->data_fdoc_h = load_static_obj (cu, TEXT_FDOC_SYM); + + eassert (!NILP (cu->data_fdoc_h)); + + return Fgethash (make_fixnum (XSUBR (function)->doc), + cu->data_fdoc_h, + Qnil); +} + DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 7, 7, 0, doc: /* This gets called by top_level_run during load phase to register diff --git a/src/comp.h b/src/comp.h index c0598468117..5beedcfc280 100644 --- a/src/comp.h +++ b/src/comp.h @@ -69,6 +69,8 @@ extern void hash_native_abi (void); extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load); +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, diff --git a/src/doc.c b/src/doc.c index 8191a914c6e..31ccee8079b 100644 --- a/src/doc.c +++ b/src/doc.c @@ -337,10 +337,7 @@ string is passed through `substitute-command-keys'. */) fun = XCDR (fun); #ifdef HAVE_NATIVE_COMP if (!NILP (Fsubr_native_elisp_p (fun))) - doc = - Fgethash (make_fixnum (XSUBR (fun)->doc), - XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (fun))->data_fdoc_h, - Qnil); + doc = native_function_doc (fun); else #endif if (SUBRP (fun)) diff --git a/src/pdumper.c b/src/pdumper.c index 702b3ffced9..39adaf3ea21 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2982,8 +2982,10 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) #ifdef HAVE_NATIVE_COMP static dump_off dump_native_comp_unit (struct dump_context *ctx, - const struct Lisp_Native_Comp_Unit *comp_u) + struct Lisp_Native_Comp_Unit *comp_u) { + /* Have function documentation always lazy loaded to optimize load-time. */ + comp_u->data_fdoc_h = 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; From 57fa590aa6d4aecef84e548fd17a7178cf3365f0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 20:07:40 +0100 Subject: [PATCH 0838/1452] * src/pdumper.c (dump_subr): Clean-up now unnecessary kludge. --- src/pdumper.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 39adaf3ea21..c9015d503cd 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,10 +2937,7 @@ 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 (HAVE_NATIVE_COMP) \ - && !defined (HASH_Lisp_Subr_99B6674034)) \ - || (!defined (HAVE_NATIVE_COMP) \ - && !defined (HASH_Lisp_Subr_594AB72B54))) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_99B6674034) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; From 9f5b7eb5e05948ccdd7fa2a473e5a55889f5e4ee Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 20:22:17 +0100 Subject: [PATCH 0839/1452] * src/comp.h (Fnative_elisp_load): Add fake inline for stock build. --- src/comp.h | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/comp.h b/src/comp.h index 5beedcfc280..73baa27276e 100644 --- a/src/comp.h +++ b/src/comp.h @@ -82,6 +82,12 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) {} +static inline Lisp_Object +Fnative_elisp_load (Lisp_Object file, Lisp_Object late_load) +{ + eassume (false); +} + #endif #endif From 64af8f941fb7ec50460f47997109e757cb7af94c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 22:08:11 +0100 Subject: [PATCH 0840/1452] * src/data.c (syms_of_data): Fix #ifdef HAVE_NATIVE_COMP position. --- src/data.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data.c b/src/data.c index 1809d58c2c7..56ea7aabb04 100644 --- a/src/data.c +++ b/src/data.c @@ -4013,8 +4013,8 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); -#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); +#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); From bb4cf13c47a1a24ce83233cc7b77dc87fc274d52 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 26 Apr 2020 09:11:33 +0100 Subject: [PATCH 0841/1452] Convert before final function doc hash into a vector. * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Convert doc hash table into vector befor final. (comp-emit-for-top-level): Rename `comp-ctxt-doc-index-h' -> `comp-ctxt-function-docs'. (comp-ctxt): Likewise. * src/comp.c (native_function_doc): Update logic for documentation being a vector. (emit_ctxt_code): Update for 'comp-ctxt-doc-index-h' slot rename. * src/comp.h (struct Lisp_Native_Comp_Unit): Rename 'data_fdoc_h' into data_fdoc_v. * src/pdumper.c (dump_native_comp_unit): Likewise. --- lisp/emacs-lisp/comp.el | 14 +++++++++++--- src/comp.c | 16 +++++++--------- src/comp.h | 2 +- src/pdumper.c | 2 +- 4 files changed, 20 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5096a143a0f..f8e30f0047a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -216,7 +216,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") - (doc-index-h (make-hash-table :test #'eql) :type hash-table + (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") @@ -1218,7 +1218,7 @@ the annotation emission." (make-comp-mvar :constant c-name) (make-comp-mvar :constant - (let* ((h (comp-ctxt-doc-index-h comp-ctxt)) + (let* ((h (comp-ctxt-function-docs comp-ctxt)) (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i)) @@ -2103,7 +2103,15 @@ Update all insn accordingly." do (remhash obj d-ephemeral-idx)) ;; Fix-up indexes in each relocation class and fill corresponding ;; reloc lists. - (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)))) + (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)) + ;; Make a vector from the function documentation hash table. + (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) + with v = (make-vector (hash-table-count h) nil) + for idx being each hash-keys of h + for doc = (gethash idx h) + do (setf (aref v idx) doc) + finally + do (setf (comp-ctxt-function-docs comp-ctxt) v)))) (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. diff --git a/src/comp.c b/src/comp.c index b33ef92f72b..d021be479b0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2102,7 +2102,7 @@ emit_ctxt_code (void) emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, opt_qly)); emit_static_object (TEXT_FDOC_SYM, - CALL1I (comp-ctxt-doc-index-h, Vcomp_ctxt)); + CALL1I (comp-ctxt-function-docs, Vcomp_ctxt)); comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( @@ -3677,14 +3677,12 @@ native_function_doc (Lisp_Object function) struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function)); - if (NILP (cu->data_fdoc_h)) - cu->data_fdoc_h = load_static_obj (cu, TEXT_FDOC_SYM); - - eassert (!NILP (cu->data_fdoc_h)); - - return Fgethash (make_fixnum (XSUBR (function)->doc), - cu->data_fdoc_h, - Qnil); + if (NILP (cu->data_fdoc_v)) + cu->data_fdoc_v = load_static_obj (cu, TEXT_FDOC_SYM); + if (!VECTORP (cu->data_fdoc_v)) + xsignal2 (Qnative_lisp_file_inconsistent, cu->file, + build_string ("missing documentation vector")); + return AREF (cu->data_fdoc_v, XSUBR (function)->doc); } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, diff --git a/src/comp.h b/src/comp.h index 73baa27276e..cbdcaccd5fe 100644 --- a/src/comp.h +++ b/src/comp.h @@ -38,7 +38,7 @@ struct Lisp_Native_Comp_Unit Lisp_Object file; Lisp_Object optimize_qualities; /* Hash doc-idx -> function documentaiton. */ - Lisp_Object data_fdoc_h; + Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Same but for data that cannot be moved to pure space. diff --git a/src/pdumper.c b/src/pdumper.c index c9015d503cd..f837dfc38d2 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2982,7 +2982,7 @@ 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_h = Qnil; + 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; From f8b254d1957a86645bfcc6ce452d97b9286910a2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 26 Apr 2020 19:55:26 +0100 Subject: [PATCH 0842/1452] Rework spill LAP mechanism in preparation of compiling lambdas. * lisp/emacs-lisp/comp.el (comp-spill-lap-function): No need anymore to have `byte-native-compiling' bound to free-func. (comp-spill-lap-function): Make use of `byte-to-native-lap-h' and clean-up. (comp-spill-lap-function): Likewise. * lisp/emacs-lisp/bytecomp.el (byte-to-native-function): Add lap slot. (byte-to-native-lap): Rename into byte-to-native-lap-h. (byte-compile-lapcode): Spill lap after having int assembled and store it into `byte-to-native-lap-h'. (byte-compile-not-top-level): Remove. (byte-compile-file-form-defmumble): Fill directly lap slot. (byte-compile-lambda): Remove `byte-compile-not-top-level'. (byte-compile-out-toplevel): Restore original code. (byte-compile-form): Remove `byte-compile-not-top-level'. (byte-compile-function-form): Likewise. (byte-compile-flush-pending): No need anymore to set `byte-compile-current-form' so restore orignal code. --- lisp/emacs-lisp/bytecomp.el | 43 ++++++++++++++++--------------------- lisp/emacs-lisp/comp.el | 19 ++++++---------- 2 files changed, 24 insertions(+), 38 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9a5491b10fc..8f85c928399 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,7 +565,7 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (cl-defstruct byte-to-native-function "Named or anonymous function defined a top level." - name c-name data) + name c-name data lap) (cl-defstruct byte-to-native-top-level "All other top level forms." form) @@ -577,9 +577,8 @@ Each element is (INDEX . VALUE)") ;; Because the make target is the later this has to be produced as ;; last to be resilient against build interruptions. ) -(defvar byte-to-native-lap nil - "A-list to accumulate LAP. -Each pair is (NAME . LAP)") +(defvar byte-to-native-lap-h nil + "Hash byte-code -> LAP.") (defvar byte-to-native-top-level-forms nil "List of top level forms.") (defvar byte-to-native-output-file nil @@ -977,7 +976,11 @@ 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 lap byte-to-native-lap-h)) + bytecode))) ;;; compile-time evaluation @@ -1094,8 +1097,6 @@ message buffer `default-directory'." (defvar byte-compile-current-file nil) (defvar byte-compile-current-group nil) (defvar byte-compile-current-buffer nil) -(defvar byte-compile-not-top-level nil ; We'll evolve this for naming lambdas - "Non nil if compiling something that is not top-level.") ;; Log something that isn't a warning. (defmacro byte-compile-log (format-string &rest args) @@ -2363,8 +2364,7 @@ list that represents a doc string reference. (defun byte-compile-flush-pending () (if byte-compile-output - (let* ((byte-compile-current-form nil) - (form (byte-compile-out-toplevel t 'file))) + (let ((form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) (mapc 'byte-compile-output-file-form (cdr form))) (form @@ -2689,7 +2689,10 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (make-byte-to-native-function :name name :data code)) + (make-byte-to-native-function :name name + :data code + :lap (gethash (aref code 1) + byte-to-native-lap-h))) 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. @@ -2918,7 +2921,6 @@ for symbols generated by the byte compiler itself." ;; args of `list'. Actually, compile it to get warnings, ;; but don't use the result. (let* ((form (nth 1 int)) - (byte-compile-not-top-level t) (newform (byte-compile-top-level form))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) @@ -3116,16 +3118,9 @@ for symbols generated by the byte compiler itself." (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) - (let* ((byte-compile-vector (byte-compile-constants-vector)) - (out (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) - (when (and byte-native-compiling - (or (null byte-compile-not-top-level) - (eq byte-native-compiling 'free-func))) - ;; Spill LAP for the native compiler here - (push (cons byte-compile-current-form byte-compile-output) - byte-to-native-lap)) - out)) + (let ((byte-compile-vector (byte-compile-constants-vector))) + (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) ((car body))))) @@ -3175,8 +3170,7 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect) - (byte-compile-not-top-level t)) + (let ((byte-compile--for-effect for-effect)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) @@ -3950,8 +3944,7 @@ discarding." ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (let ((f (nth 1 form)) - (byte-compile-not-top-level t)) + (let ((f (nth 1 form))) (when (and (symbolp f) (byte-compile-warning-enabled-p 'callargs f)) (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f8e30f0047a..1dbafbe1ae1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -523,8 +523,7 @@ Put PREFIX in front of it." (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (let* ((byte-native-compiling 'free-func) - (f (symbol-function function-name)) + (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func :name function-name :c-name c-name @@ -535,7 +534,8 @@ Put PREFIX in front of it." "can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-name func))) - (let ((lap (alist-get nil byte-to-native-lap))) + (let ((lap (gethash (aref (comp-func-byte-func func) 1) + byte-to-native-lap-h))) (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) @@ -559,9 +559,7 @@ Put PREFIX in front of it." (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) - (comp-log byte-to-native-lap 3) (cl-loop - with lap-forms = (reverse byte-to-native-lap) ;; All non anonymous functions. for f in (cl-loop for x in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-function-p x) @@ -569,8 +567,6 @@ Put PREFIX in front of it." collect x) for name = (byte-to-native-function-name f) for c-name = (comp-c-func-name name "F") - for lap-entry = (assoc name lap-forms) - for lap = (cdr lap-entry) for data = (byte-to-native-function-data f) for func = (make-comp-func :name name :byte-func data @@ -578,12 +574,9 @@ Put PREFIX in front of it." :int-spec (interactive-form data) :c-name c-name :args (comp-decrypt-arg-list (aref data 0) name) - :lap lap + :lap (byte-to-native-function-lap f) :frame-size (comp-byte-frame-size data)) do - ;; Remove it form the original lap list to avoid multiple function - ;; definition with the same name shadowing each other. - (setf lap-forms (delete lap-entry lap-forms)) ;; Store the c-name to have it retrivable from ;; comp-ctxt-top-level-forms. (setf (byte-to-native-function-c-name f) c-name) @@ -591,14 +584,14 @@ Put PREFIX in front of it." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1))) + (comp-log (byte-to-native-function-lap f) 1))) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-lap ()) + (byte-to-native-lap-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ())) (comp-spill-lap-function input))) From 02e3ffad6d9f757599bb441704b6cf6494183174 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 29 Apr 2020 21:21:42 +0100 Subject: [PATCH 0843/1452] * Fix async compilation non respecting `comp-always-compile' nil value. * lisp/emacs-lisp/comp.el (comp-run-async-workers): Fix missing `comp-output-filename' usage. --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1dbafbe1ae1..05417fdc31c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2196,7 +2196,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or comp-always-compile - (file-newer-than-file-p source-file (concat source-file "n"))) + (file-newer-than-file-p source-file + (comp-output-filename source-file))) do (let* ((expr `(progn (require 'comp) (setf comp-speed ,comp-speed From 8d372201904bcb5fe6cb14aa5c45f33e6e1cd815 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 May 2020 14:35:50 +0100 Subject: [PATCH 0844/1452] * Introduce `comp-output-directory' * lisp/emacs-lisp/comp.el (comp-output-directory): New function. (comp-output-base-filename): Use `comp-output-directory'. --- lisp/emacs-lisp/comp.el | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 05417fdc31c..f027bad65cf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -443,13 +443,19 @@ VERBOSITY is a number between 0 and 3." 2)) edges))) +(defun comp-output-directory (src) + "Return the compilation direcotry for source SRC." + (let* ((src (if (symbolp src) (symbol-name src) src)) + (expanded-filename (expand-file-name src))) + (file-name-as-directory + (concat (file-name-directory expanded-filename) + comp-native-path-postfix)))) + (defun comp-output-base-filename (src) "Output filename sans extention for SRC file being native compiled." (let* ((src (if (symbolp src) (symbol-name src) src)) (expanded-filename (expand-file-name src)) - (output-dir (file-name-as-directory - (concat (file-name-directory expanded-filename) - comp-native-path-postfix))) + (output-dir (comp-output-directory src)) (output-filename (file-name-sans-extension (file-name-nondirectory expanded-filename)))) From 1ec7499e59a8724cb9f3d8688a7c922acad3be27 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 May 2020 13:37:38 +0100 Subject: [PATCH 0845/1452] * Add a warning for missing write privilege * lisp/emacs-lisp/comp.el (native-compile-async): Check for write privilege and raise a warning in case. --- lisp/emacs-lisp/comp.el | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f027bad65cf..bd4c25a1f57 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2344,7 +2344,16 @@ queued with LOAD %" file load (cdr entry)) ;; Make sure we are not already compiling `file' (bug#40838). (unless (gethash file comp-async-compilations) - (setf comp-files-queue (append comp-files-queue `((,file . ,load))))))) + (let ((out-dir (comp-output-directory file)) + (out-filename (comp-output-filename file))) + (if (or (file-writable-p out-filename) + (and (not (file-exists-p out-dir)) + (file-writable-p (substring out-dir 0 -1)))) + (setf comp-files-queue + (append comp-files-queue `((,file . ,load)))) + (display-warning 'comp + (format "No write access for %s skipping." + out-filename))))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) (message "Compilation started.")))) From 766f4b96ee148adf8f4bbbf5fa4f1c47555d46de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 May 2020 21:01:48 +0100 Subject: [PATCH 0846/1452] * configure.ac: Add a better libgccjit test plus some morw err message * configure.ac (libgccjit_smoke_test, libgccjit_not_found) (libgccjit_broken): New functions. --- configure.ac | 66 +++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 57 insertions(+), 9 deletions(-) diff --git a/configure.ac b/configure.ac index c4d19e0e287..af12f20500d 100644 --- a/configure.ac +++ b/configure.ac @@ -3729,22 +3729,70 @@ emacs_major_version="${PACKAGE_VERSION%%.*}" AC_SUBST(emacs_major_version) ### Emacs Lisp native compiler support + +AC_DEFUN([libgccjit_smoke_test], [ + AC_LANG_SOURCE( + [[#include + #include + #include + 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. +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. +Please report the issue to your distribution. +Here instructions on how to compile from source: https://gcc.gnu.org/wiki/JIT.])]) + HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_HEADER(libgccjit.h, - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes)) - if test "${HAVE_NATIVE_COMP}" = "yes"; then + emacs_save_LDFLAGS=$LDFLAGS + LDFLAGS="-lgccjit -ldl" + AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], + [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) + LDFLAGS=$emacs_save_LDFLAGS + HAVE_NATIVE_COMP=yes LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ="comp.o" AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) - else - AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. -If you are sure you want Emacs compiled without elisp native compiler, pass - --without-nativecomp -to configure.]) - fi fi if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) From a261db171166246eaee523cd3b3687b39bce4dca Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 5 May 2020 08:47:51 +0100 Subject: [PATCH 0847/1452] * configure.ac: Better messaging when libgccjit fails smoke test * configure.ac: Fix libgccjit test LDFLAGS plus better messaging in case of its fail. --- configure.ac | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index af12f20500d..62fb274d3bb 100644 --- a/configure.ac +++ b/configure.ac @@ -3777,15 +3777,18 @@ to configure.])]) AC_DEFUN([libgccjit_broken], [ AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test. +You can verify it yourself compiling: +. Please report the issue to your distribution. -Here instructions on how to compile from source: https://gcc.gnu.org/wiki/JIT.])]) +Here instructions on how to compile from source: +.])]) HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then emacs_save_LDFLAGS=$LDFLAGS - LDFLAGS="-lgccjit -ldl" + LDFLAGS="-lgccjit" AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) LDFLAGS=$emacs_save_LDFLAGS From 6d25de46f77909f3adb108786052995151082c56 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 5 May 2020 15:50:30 +0100 Subject: [PATCH 0848/1452] * configure.ac: Fix var usage + better messaging. --- configure.ac | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/configure.ac b/configure.ac index 62fb274d3bb..23b94cf6ca1 100644 --- a/configure.ac +++ b/configure.ac @@ -3780,18 +3780,18 @@ AC_DEFUN([libgccjit_broken], [ You can verify it yourself compiling: . Please report the issue to your distribution. -Here instructions on how to compile from source: +Here instructions on how to compile and install libgccjit from source: .])]) HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - emacs_save_LDFLAGS=$LDFLAGS - LDFLAGS="-lgccjit" + emacs_save_LIBS=$LIBS + LIBS="-lgccjit" AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) - LDFLAGS=$emacs_save_LDFLAGS + LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ="comp.o" From f8df3320b1ceffca8d5ee7cbc566ba3cdf761e21 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 6 May 2020 18:55:33 +0100 Subject: [PATCH 0849/1452] * Add native compilation unit black list * lisp/emacs-lisp/comp.el (comp-bootstrap-black-list): New customize. (batch-native-compile): Rework to make use of 'comp-bootstrap-black-list'. (batch-byte-native-compile-for-bootstrap): Add assertion to make logic assumption explicit. --- lisp/emacs-lisp/comp.el | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bd4c25a1f57..60b41f95bda 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -84,6 +84,13 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) +(defcustom comp-bootstrap-black-list + '("^leim/") + "List of regexps to exclude files from native compilation during bootstrap. +Skip if any is matching." + :type 'list + :group 'comp) + (defcustom comp-never-optimize-functions '(;; Mandatory for Emacs to be working correctly macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer @@ -2291,7 +2298,13 @@ Return the compilation unit file name." (defun batch-native-compile () "Run `native-compile' on remaining command-line arguments. Ultra cheap impersonation of `batch-byte-compile'." - (mapc #'native-compile command-line-args-left)) + (cl-loop for file in command-line-args-left + if (or (null byte-native-for-bootstrap) + (cl-notany (lambda (re) (string-match re file)) + comp-bootstrap-black-list)) + do (native-compile file) + else + do (byte-compile-file file))) ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () @@ -2299,6 +2312,7 @@ Ultra cheap impersonation of `batch-byte-compile'." Always generate elc files too and handle native compiler expected errors." (if (equal (getenv "NATIVE_DISABLE") "1") (batch-byte-compile) + (cl-assert (= 1 (length command-line-args-left))) (let ((byte-native-for-bootstrap t) (byte-to-native-output-file nil)) (unwind-protect From cf105f604413d270c956adf375217960e3945e2a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 7 May 2020 08:10:50 +0100 Subject: [PATCH 0850/1452] * Fix bug#41112 * lisp/emacs-lisp/comp.el (comp-jump-table-optimizable): New function. (comp-emit-switch): Make use of 'comp-jump-table-optimizable'. --- lisp/emacs-lisp/comp.el | 72 ++++++++++++++++++++++++----------------- 1 file changed, 42 insertions(+), 30 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60b41f95bda..616410375ed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -850,44 +850,56 @@ Return value is the fall through block name." (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) +(defun comp-jump-table-optimizable (jmp-table) + "Return t if JMP-TABLE can be optimized out." + (cl-loop + with labels = (cl-loop for target-label being each hash-value of jmp-table + collect target-label) + with x = (car labels) + for l in (cdr-safe labels) + unless (= l x) + return nil + finally return t)) + (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn (`(setimm ,_ ,jmp-table) - (cl-loop - for test being each hash-keys of jmp-table - using (hash-value target-label) - with len = (hash-table-count jmp-table) - with test-func = (hash-table-test jmp-table) - for n from 1 - for last = (= n len) - for m-test = (make-comp-mvar :constant test) - for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) - (comp-sp))) - for ff-bb = (if last - (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)) - (make--comp-block nil - (comp-sp) - (comp-new-block-sym))) - for ff-bb-name = (comp-block-name ff-bb) - if (eq test-func 'eq) - do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) - else + (unless (comp-jump-table-optimizable jmp-table) + (cl-loop + for test being each hash-keys of jmp-table + using (hash-value target-label) + with len = (hash-table-count jmp-table) + with test-func = (hash-table-test jmp-table) + for n from 1 + for last = (= n len) + for m-test = (make-comp-mvar :constant test) + for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) + (comp-sp))) + for ff-bb = (if last + (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)) + (make--comp-block nil + (comp-sp) + (comp-new-block-sym))) + for ff-bb-name = (comp-block-name ff-bb) + if (eq test-func 'eq) + do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. - do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) - (comp-call test-func var m-test))) - (comp-emit (list 'cond-jump - (make-comp-mvar :slot 'scratch) - (make-comp-mvar :constant nil) - target-name ff-bb-name)) - do (unless last - ;; All fall through are artificially created here except the last one. - (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) - (setf (comp-limplify-curr-block comp-pass) ff-bb)))) + do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) + (comp-call test-func var m-test))) + (comp-emit (list 'cond-jump + (make-comp-mvar :slot 'scratch) + (make-comp-mvar :constant nil) + target-name ff-bb-name)) + unless last + ;; All fall through are artificially created here except the last one. + do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (signal 'native-ice "missing previous setimm while creating a switch")))) From 40f655e0505d954e507ead5f5bda7dc7113adc06 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 May 2020 13:52:30 +0100 Subject: [PATCH 0851/1452] * Add 'comp-deferred-compilation-black-list' customize * lisp/emacs-lisp/comp.el (comp-deferred-compilation-black-list): New customize. (native-compile-async): Make use of 'comp-deferred-compilation-black-list'. --- lisp/emacs-lisp/comp.el | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 616410375ed..e6a43b85afb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -84,6 +84,13 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) +(defcustom comp-deferred-compilation-black-list + '() + "List of regexps to exclude files from deferred native compilation. +Skip if any is matching." + :type 'list + :group 'comp) + (defcustom comp-bootstrap-black-list '("^leim/") "List of regexps to exclude files from native compilation during bootstrap. @@ -2369,7 +2376,12 @@ LOAD can be nil t or 'late." queued with LOAD %" file load (cdr entry)) ;; Make sure we are not already compiling `file' (bug#40838). - (unless (gethash file comp-async-compilations) + (unless (and (gethash file comp-async-compilations) + ;; Exclude some file from deferred compilation if + ;; `comp-deferred-compilation-black-list' says so. + (or (not (eq load 'late)) + (cl-notany (lambda (re) (string-match re file)) + comp-deferred-compilation-black-list))) (let ((out-dir (comp-output-directory file)) (out-filename (comp-output-filename file))) (if (or (file-writable-p out-filename) From bd8be64ce3f314c152d009f5bf88bcfadf6daef7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 May 2020 19:07:35 +0100 Subject: [PATCH 0852/1452] * Fix --enable-check-lisp-object-type GNU/Linux X86_64 build * src/comp.c (emit_mvar_val): Fix missing use of XLP macro. (load_comp_unit): Fix missing use of NILP macro. --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index d021be479b0..768172b3aa1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1343,7 +1343,7 @@ emit_mvar_val (Lisp_Object mvar) word = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, - constant); + XLP (constant)); #endif return emit_coerce (comp.lisp_obj_type, word); } @@ -3564,7 +3564,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - bool reloading_cu = *saved_cu ? true : false; + bool reloading_cu = !NILP (*saved_cu) ? true : false; Lisp_Object *data_eph_relocs = dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); From 49def706f361754a3e374c105328a3eec892beff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 May 2020 08:58:53 +0100 Subject: [PATCH 0853/1452] * src/comp.c (load_comp_unit): Style fix. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 768172b3aa1..e3a80adfa95 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3564,7 +3564,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - bool reloading_cu = !NILP (*saved_cu) ? true : false; + bool reloading_cu = !NILP (*saved_cu); Lisp_Object *data_eph_relocs = dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); From 9bc0a7c408237f7dc6846544e647da7b08988ab9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 May 2020 08:48:50 +0100 Subject: [PATCH 0854/1452] * Fix `comp-deferred-compilation-black-list' effectiveness * lisp/emacs-lisp/comp.el (native-compile-async): Fix logic for 'comp-deferred-compilation-black-list' effectiveness. --- lisp/emacs-lisp/comp.el | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e6a43b85afb..c2a95feec10 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2376,12 +2376,13 @@ LOAD can be nil t or 'late." queued with LOAD %" file load (cdr entry)) ;; Make sure we are not already compiling `file' (bug#40838). - (unless (and (gethash file comp-async-compilations) - ;; Exclude some file from deferred compilation if - ;; `comp-deferred-compilation-black-list' says so. - (or (not (eq load 'late)) - (cl-notany (lambda (re) (string-match re file)) - comp-deferred-compilation-black-list))) + (unless (or (gethash file comp-async-compilations) + ;; Also exclude files from deferred compilation if + ;; any of the regexps in + ;; `comp-deferred-compilation-black-list' matches. + (and (eq load 'late) + (cl-some (lambda (re) (string-match re file)) + comp-deferred-compilation-black-list))) (let ((out-dir (comp-output-directory file)) (out-filename (comp-output-filename file))) (if (or (file-writable-p out-filename) From 28df049b8d43586d5a91a7b3e1d9e05131572afc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 13 May 2020 19:48:57 +0100 Subject: [PATCH 0855/1452] * test/src/comp-tests.el (comp-tests-bootstrap): Fix test. --- test/src/comp-tests.el | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4768e1a1ace..ce98227162f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -44,21 +44,20 @@ Check that the resulting binaries do not differ." "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) (comp2-src (make-temp-file "stage2-" nil ".el")) - (comp1 (concat comp1-src "n")) - (comp2 (concat comp2-src "n")) ;; Can't use debug symbols. (comp-debug 0)) (copy-file comp-src comp1-src t) (copy-file comp-src comp2-src t) (load (concat comp-src "c") nil nil t t) - (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) + (should-not (subr-native-elisp-p (symbol-function #'native-compile))) (message "Compiling stage1...") - (load (native-compile comp1-src) nil nil t t) - (should (subr-native-elisp-p (symbol-function 'native-compile))) - (message "Compiling stage2...") - (native-compile comp2-src) - (message "Comparing %s %s" comp1 comp2) - (should (= (call-process "cmp" nil nil nil comp1 comp2) 0)))) + (let ((comp1-eln (native-compile comp1-src))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((comp2-eln (native-compile comp2-src))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) (ert-deftest comp-tests-provide () "Testing top level provide." From a335f7eeacd5381af1d8ef38a4c2b8e832ca96fa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 May 2020 17:32:39 +0100 Subject: [PATCH 0856/1452] Update spill LAP machinery and compile anonymous lambdas * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Make use of byte-to-native-lambdas-h and update for 'byte-to-native-func-def'. (comp-spill-lap-function): Rework logic to retrive LAP using 'byte-to-native-lambdas-h'. (comp-emit-for-top-level): Update for 'byte-to-native-function'. * lisp/emacs-lisp/bytecomp.el: Add commentary on new spill LAP mechanism. (byte-to-native-lambda, byte-to-native-func-def): New structures. (byte-to-native-top-level): Indent. (byte-to-native-lambdas-h): Update doc. (byte-compile-lapcode): Add a 'byte-to-native-lambda' instance into byte-to-native-lambdas-h instead of just LAP. (byte-compile-file-form-defmumble): Store into 'byte-to-native-func-def' only the byte compiled function, the LAP will be retrived through 'byte-to-native-lambdas-h'. (byte-compile-lambda): Return the byte compiled function. --- lisp/emacs-lisp/bytecomp.el | 86 ++++++++++++++++++++++++------------- lisp/emacs-lisp/comp.el | 67 ++++++++++++++++++----------- 2 files changed, 97 insertions(+), 56 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c0662a6d280..f33c30e5742 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -562,13 +562,31 @@ 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.") -;; These are use by comp.el to spill data out of here -(cl-defstruct byte-to-native-function - "Named or anonymous function defined a top level." - name c-name data lap) +;; 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) + "All other top-level forms." + form) + (defvar byte-native-compiling nil "Non nil while native compiling.") (defvar byte-native-for-bootstrap nil @@ -577,8 +595,8 @@ Each element is (INDEX . VALUE)") ;; Because the make target is the later this has to be produced as ;; last to be resilient against build interruptions. ) -(defvar byte-to-native-lap-h nil - "Hash byte-code -> LAP.") +(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 @@ -978,8 +996,9 @@ CONST2 may be evaluated multiple times." hash-table)) (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) (when byte-native-compiling - ;; Spill LAP for the native compiler here - (puthash bytecode lap byte-to-native-lap-h)) + ;; Spill LAP for the native compiler here. + (puthash bytecode (make-byte-to-native-lambda :lap lap) + byte-to-native-lambdas-h)) bytecode))) @@ -2689,10 +2708,8 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (make-byte-to-native-function :name name - :data code - :lap (gethash (aref code 1) - byte-to-native-lap-h))) + (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. @@ -2950,23 +2967,30 @@ 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. - (if 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. + (if 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) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c2a95feec10..3977580fc8e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,6 +230,9 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") + (byte-func-to-func-h (make-hash-table :test #'eq) :type hash-table + :documentation "byte-function -> comp-func. +Needed to replace immediate byte-compiled lambdas with the compiled reference.") (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container @@ -311,7 +314,7 @@ Is in use to help the SSA rename pass.")) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." (name nil :type symbol - :documentation "Function symbol name.") + :documentation "Function symbol name. Nil indicates anonymous.") (c-name nil :type string :documentation "The function name in the native world.") (byte-func nil @@ -554,8 +557,9 @@ Put PREFIX in front of it." "can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-name func))) - (let ((lap (gethash (aref (comp-func-byte-func func) 1) - byte-to-native-lap-h))) + (let ((lap (byte-to-native-lambda-lap + (gethash (aref (comp-func-byte-func func) 1) + byte-to-native-lambdas-h)))) (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) @@ -566,7 +570,7 @@ Put PREFIX in front of it." (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) - (list (make-byte-to-native-function :name function-name + (list (make-byte-to-native-func-def :name function-name :c-name c-name))) ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) @@ -580,38 +584,47 @@ Put PREFIX in front of it." (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop - ;; All non anonymous functions. - for f in (cl-loop for x in (comp-ctxt-top-level-forms comp-ctxt) - when (and (byte-to-native-function-p x) - (byte-to-native-function-name x)) - collect x) - for name = (byte-to-native-function-name f) - for c-name = (comp-c-func-name name "F") - for data = (byte-to-native-function-data f) + for x being each hash-value of byte-to-native-lambdas-h + for byte-func = (byte-to-native-lambda-byte-func x) + for lap = (byte-to-native-lambda-lap x) + for top-l-form = (cl-loop + for form in (comp-ctxt-top-level-forms comp-ctxt) + when (and (byte-to-native-func-def-p form) + (eq (byte-to-native-func-def-byte-func form) + byte-func)) + return form) + for name = (when top-l-form + (byte-to-native-func-def-name top-l-form)) + for c-name = (comp-c-func-name (or name "anonymous-lambda") + "F") for func = (make-comp-func :name name - :byte-func data - :doc (documentation data) - :int-spec (interactive-form data) + :byte-func byte-func + :doc (documentation byte-func) + :int-spec (interactive-form byte-func) :c-name c-name - :args (comp-decrypt-arg-list (aref data 0) name) - :lap (byte-to-native-function-lap f) - :frame-size (comp-byte-frame-size data)) - do + :args (comp-decrypt-arg-list (aref byte-func 0) + name) + :lap lap + :frame-size (comp-byte-frame-size byte-func)) ;; Store the c-name to have it retrivable from ;; comp-ctxt-top-level-forms. - (setf (byte-to-native-function-c-name f) c-name) + when top-l-form + do (setf (byte-to-native-func-def-c-name top-l-form) c-name) + unless name + do (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)) + do ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) - (comp-log (byte-to-native-function-lap f) 1))) + (comp-log lap 1))) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-lap-h (make-hash-table :test #'eq)) + (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ())) (comp-spill-lap-function input))) @@ -1225,10 +1238,10 @@ the annotation emission." (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def) for-late-load) - (let* ((name (byte-to-native-function-name form)) - (c-name (byte-to-native-function-c-name form)) + (let* ((name (byte-to-native-func-def-name form)) + (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) (cl-assert (and name f)) @@ -1293,6 +1306,9 @@ into the C code forwarding the compilation unit." "Top level")) ;; Assign the compilation unit incoming as parameter to the slot frame 0. (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) + (maphash (lambda (_ func) + (comp-emit-lambda-for-top-level func)) + (comp-ctxt-byte-func-to-func-h comp-ctxt)) (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) @@ -2142,6 +2158,7 @@ Update all insn accordingly." "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) + ;; FIXME: Strip bytecompiled functions here. (comp-finalize-relocs) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. From 3ab6a756671f95213d5bf083cf9852e0c61af1db Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 May 2020 21:17:29 +0100 Subject: [PATCH 0857/1452] * Indentation fix * src/comp.c (Fcomp__init_ctxt, Fcomp__release_ctxt) (Fcomp__compile_ctxt_to_file, Fcomp__register_subr): Indentation fix. --- src/comp.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index e3a80adfa95..c85181f626a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3182,7 +3182,7 @@ compile_function (Lisp_Object func) DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) - (void) + (void) { if (comp.ctxt) { @@ -3306,7 +3306,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, 0, 0, 0, doc: /* Release the native compiler context. */) - (void) + (void) { if (comp.ctxt) gcc_jit_context_release (comp.ctxt); @@ -3322,7 +3322,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) - (Lisp_Object base_name) + (Lisp_Object base_name) { CHECK_STRING (base_name); @@ -3689,9 +3689,9 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 7, 7, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) { dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; if (!handle) @@ -3726,9 +3726,9 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, Scomp__late_register_subr, 7, 7, 0, doc: /* This gets called by late_top_level_run during load phase to register each exported subr. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) From 5bf685f17cd9e8875cb117a086a75c32d832f4f7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 May 2020 20:12:41 +0100 Subject: [PATCH 0858/1452] * Rename emit_mvar_val -> emit_mvar_rval * src/comp.c (emit_mvar_val): Rename into 'emit_mvar_rval'. (emit_set_internal, emit_simple_limple_call, emit_limple_insn) (emit_call_with_type_hint, emit_call2_with_type_hint) (emit_consp, emit_numperp, emit_integerp): Update for 'emit_mvar_val' rename. --- src/comp.c | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/comp.c b/src/comp.c index c85181f626a..4ba7e400bc3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1324,7 +1324,7 @@ emit_PURE_P (gcc_jit_rvalue *ptr) from frame. */ static gcc_jit_rvalue * -emit_mvar_val (Lisp_Object mvar) +emit_mvar_rval (Lisp_Object mvar) { Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); @@ -1382,7 +1382,7 @@ emit_set_internal (Lisp_Object args) int i = 0; gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) - gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[i++] = emit_mvar_rval (XCAR (args)); gcc_args[2] = emit_const_lisp_obj (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1403,7 +1403,7 @@ emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) ptrdiff_t nargs = list_length (args); gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args)); FOR_EACH_TAIL (args) - gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[i++] = emit_mvar_rval (XCAR (args)); SAFE_FREE (); return emit_call (callee, ret_type, nargs, gcc_args, direct); @@ -1531,8 +1531,8 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *a = emit_mvar_val (arg[0]); - gcc_jit_rvalue *b = emit_mvar_val (arg[1]); + gcc_jit_rvalue *a = emit_mvar_rval (arg[0]); + gcc_jit_rvalue *b = emit_mvar_rval (arg[1]); gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); @@ -1569,7 +1569,7 @@ emit_limple_insn (Lisp_Object insn) /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ int h_num UNINIT; Lisp_Object handler_spec = arg[0]; - gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); + gcc_jit_rvalue *handler = emit_mvar_rval (arg[1]); if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; else if (EQ (handler_spec, Qcondition_case)) @@ -1665,7 +1665,7 @@ emit_limple_insn (Lisp_Object insn) Lisp_Object arg1 = arg[1]; if (EQ (Ftype_of (arg1), Qcomp_mvar)) - res = emit_mvar_val (arg1); + res = emit_mvar_rval (arg1); else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) @@ -1778,7 +1778,7 @@ emit_limple_insn (Lisp_Object insn) { gcc_jit_block_end_with_return (comp.block, NULL, - emit_mvar_val (arg[0])); + emit_mvar_rval (arg[0])); } else { @@ -1799,7 +1799,7 @@ emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, { bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), + { emit_mvar_rval (SECOND (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, type_hint) }; @@ -1814,8 +1814,8 @@ emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, { bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), - emit_mvar_val (THIRD (insn)), + { emit_mvar_rval (SECOND (insn)), + emit_mvar_rval (THIRD (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, type_hint) }; @@ -1845,7 +1845,7 @@ emit_negate (Lisp_Object insn) static gcc_jit_rvalue * emit_consp (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); gcc_jit_rvalue *res = emit_coerce (comp.bool_type, emit_CONSP (x)); return gcc_jit_context_new_call (comp.ctxt, @@ -1881,7 +1881,7 @@ emit_setcdr (Lisp_Object insn) static gcc_jit_rvalue * emit_numperp (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); gcc_jit_rvalue *res = emit_NUMBERP (x); return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, &res); @@ -1890,7 +1890,7 @@ emit_numperp (Lisp_Object insn) static gcc_jit_rvalue * emit_integerp (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); gcc_jit_rvalue *res = emit_INTEGERP (x); return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, &res); From acf7e129ea13b4650983135c8c92447b230a0c99 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 May 2020 20:14:13 +0100 Subject: [PATCH 0859/1452] * Rename emit_mvar_access -> emit_mvar_lval * src/comp.c (emit_mvar_access): Rename into 'emit_mvar_lval'. (emit_mvar_rval, emit_frame_assignment): Update for 'emit_mvar_access' rename. --- src/comp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 4ba7e400bc3..45d293db859 100644 --- a/src/comp.c +++ b/src/comp.c @@ -373,7 +373,7 @@ declare_block (Lisp_Object block_name) } static gcc_jit_lvalue * -emit_mvar_access (Lisp_Object mvar) +emit_mvar_lval (Lisp_Object mvar) { Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); @@ -1351,7 +1351,7 @@ emit_mvar_rval (Lisp_Object mvar) return emit_const_lisp_obj (constant); } - return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); + return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); } static void @@ -1361,7 +1361,7 @@ emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) gcc_jit_block_add_assignment ( comp.block, NULL, - emit_mvar_access (dst_mvar), + emit_mvar_lval (dst_mvar), val); } From 392a6f9bab5eb2a872380cfaff3a7ab6f809dac6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 May 2020 20:33:42 +0100 Subject: [PATCH 0860/1452] * Split emit_const_lisp_obj logic * src/comp.c (emit_lisp_obj_reloc_lval): New function. (emit_const_lisp_obj): Rename into 'emit_lisp_obj_rval' and strip logic for 'emit_lisp_obj_reloc_lval'. (emit_NILP, emit_CHECK_CONS, emit_mvar_rval, emit_set_internal) (define_CAR_CDR, define_bool_to_lisp_obj): Update for 'emit_const_lisp_obj' being renamed. --- src/comp.c | 41 ++++++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/src/comp.c b/src/comp.c index 45d293db859..c88c9f3f481 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1099,8 +1099,21 @@ emit_make_fixnum (gcc_jit_rvalue *obj) : emit_make_fixnum_MSB_TAG (obj); } +static gcc_jit_lvalue * +emit_lisp_obj_reloc_lval (Lisp_Object obj) +{ + emit_comment (format_string ("l-value for lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil)))); + + imm_reloc_t reloc = obj_to_reloc (obj); + return gcc_jit_context_new_array_access (comp.ctxt, + NULL, + reloc.array, + reloc.idx); +} + static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj) +emit_lisp_obj_rval (Lisp_Object obj) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -1119,20 +1132,14 @@ emit_const_lisp_obj (Lisp_Object obj) return emit_coerce (comp.lisp_obj_type, n); } - imm_reloc_t reloc = obj_to_reloc (obj); - return - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_array_access (comp.ctxt, - NULL, - reloc.array, - reloc.idx)); + return gcc_jit_lvalue_as_rvalue (emit_lisp_obj_reloc_lval (obj)); } static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil)); + return emit_EQ (x, emit_lisp_obj_rval (Qnil)); } static gcc_jit_rvalue * @@ -1235,7 +1242,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp), + emit_lisp_obj_rval (Qconsp), x }; gcc_jit_block_add_eval ( @@ -1348,7 +1355,7 @@ emit_mvar_rval (Lisp_Object mvar) return emit_coerce (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant); + return emit_lisp_obj_rval (constant); } return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); @@ -1383,7 +1390,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_rval (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil); + gcc_args[2] = emit_lisp_obj_rval (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -2626,11 +2633,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_lisp_obj_rval (Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp), c }; + { emit_lisp_obj_rval (Qlistp), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2639,7 +2646,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_lisp_obj_rval (Qnil)); } comp.car = func[0]; comp.cdr = func[1]; @@ -3000,12 +3007,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt)); + emit_lisp_obj_rval (Qt)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil)); + emit_lisp_obj_rval (Qnil)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ From c12831a6b6fd445950300d33c95747ac923e1ebf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 May 2020 15:11:07 +0100 Subject: [PATCH 0861/1452] * Rework comp-spill-lap-function * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Move code from to comp-intern-func-in-ctxt. (comp-intern-func-in-ctxt): New function, this guard in case byte-to-native-lambda-byte-func is nil. --- lisp/emacs-lisp/comp.el | 71 +++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 35 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3977580fc8e..705225d82f3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -576,6 +576,41 @@ Put PREFIX in front of it." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) +(defun comp-intern-func-in-ctxt (_ obj) + "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." + (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) + (let* ((byte-func (byte-to-native-lambda-byte-func obj)) + (lap (byte-to-native-lambda-lap obj)) + (top-l-form (cl-loop + for form in (comp-ctxt-top-level-forms comp-ctxt) + when (and (byte-to-native-func-def-p form) + (eq (byte-to-native-func-def-byte-func form) + byte-func)) + return form)) + (name (when top-l-form + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (make-comp-func :name name + :byte-func byte-func + :doc (documentation byte-func) + :int-spec (interactive-form byte-func) + :c-name c-name + :args (comp-decrypt-arg-list (aref byte-func 0) + name) + :lap lap + :frame-size (comp-byte-frame-size byte-func)))) + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))) + (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) @@ -583,41 +618,7 @@ Put PREFIX in front of it." (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) - (cl-loop - for x being each hash-value of byte-to-native-lambdas-h - for byte-func = (byte-to-native-lambda-byte-func x) - for lap = (byte-to-native-lambda-lap x) - for top-l-form = (cl-loop - for form in (comp-ctxt-top-level-forms comp-ctxt) - when (and (byte-to-native-func-def-p form) - (eq (byte-to-native-func-def-byte-func form) - byte-func)) - return form) - for name = (when top-l-form - (byte-to-native-func-def-name top-l-form)) - for c-name = (comp-c-func-name (or name "anonymous-lambda") - "F") - for func = (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)) - ;; Store the c-name to have it retrivable from - ;; comp-ctxt-top-level-forms. - when top-l-form - do (setf (byte-to-native-func-def-c-name top-l-form) c-name) - unless name - do (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)) - do - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. From 2ee2fb5a86a8933b1105a1dc5b597ebb8ce57e40 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 May 2020 20:26:35 +0100 Subject: [PATCH 0862/1452] * Prune now unnecessary byte-code objects * lisp/emacs-lisp/comp.el (comp-finalize-container): Prune byte-code that was lambdas. (comp-compile-ctxt-to-file): Remove fixme. --- lisp/emacs-lisp/comp.el | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 705225d82f3..3bcfdc9420b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2117,7 +2117,16 @@ These are substituted with a normal 'set' op." for obj each hash-keys of h for i from 0 do (puthash obj i h) - collect obj))) + ;; Prune byte-code objects coming from lambdas. + ;; These are not anymore necessary as they will be + ;; replaced at load time by native-elisp-subrs. + ;; Note: we leave the objects in the idx hash table + ;; to still be able to retrieve the correct index + ;; from the corresponding m-var. + collect (if (gethash obj + (comp-ctxt-byte-func-to-func-h comp-ctxt)) + nil + obj)))) (defun comp-finalize-relocs () "Finalize data containers for each relocation class. @@ -2159,7 +2168,6 @@ Update all insn accordingly." "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) - ;; FIXME: Strip bytecompiled functions here. (comp-finalize-relocs) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. From 6eb14daccf0e3045fbbc858b4d3aeb3006f14e60 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 May 2020 20:34:03 +0100 Subject: [PATCH 0863/1452] * Dump log and intemediate GCC IRs only at comp-debug 3 * src/comp.c (Fcomp__init_ctxt): Increase threshold for dumping really everything to 'comp-debug' 3. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index c88c9f3f481..e18bace6683 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3233,7 +3233,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); } - if (COMP_DEBUG > 1) + if (COMP_DEBUG > 2) { logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, From 49f0331f53fb9eaa2039538a983eb7b6dbcd206f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 3 May 2020 20:55:23 +0100 Subject: [PATCH 0864/1452] * Render all immediates as comments at comp-debug > 2 * src/comp.c (emit_mvar_rval): No reason to emit only fixnums. --- src/comp.c | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index e18bace6683..947da9a8e27 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1338,11 +1338,23 @@ emit_mvar_rval (Lisp_Object mvar) if (!NILP (const_vld)) { + if (COMP_DEBUG > 1) + { + Lisp_Object func = + Fgethash (constant, + CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), + Qnil); + + emit_comment ( + SSDATA ( + Fprin1_to_string ( + NILP (func) ? constant : CALL1I (comp-func-c-name, func), + Qnil))); + } if (FIXNUMP (constant)) { /* We can still emit directly objects that are self-contained in a word (read fixnums). */ - emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word; #ifdef WIDE_EMACS_INT word = emit_rvalue_from_long_long (constant); From 44b0ce6e38f06df10b60ffdd9d9ade4b7e229088 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 May 2020 17:29:11 +0100 Subject: [PATCH 0865/1452] Add anonymous lambdas reload mechanism * src/pdumper.c (dump_do_dump_relocation): Initialize 'lambda_gc_guard' while resurrecting. (dump_do_dump_relocation): Revive lambdas and fixup them. * src/comp.h (struct Lisp_Native_Comp_Unit): Define new 'lambda_gc_guard' 'lambda_c_name_idx_h' 'data_imp_relocs' 'loaded_once' fields. * src/comp.c (load_comp_unit): Use compilaiton unit 'loaded_once' field. (make_subr, Fcomp__register_lambda): New functions. (Fcomp__register_subr): Make use of 'make_subr'. (Fnative_elisp_load): Indent. (Fnative_elisp_load): Initialize 'lambda_gc_guard' 'lambda_c_name_idx_h' fields. (syms_of_comp): Add Scomp__register_lambda. * lisp/emacs-lisp/comp.el (comp-ctxt): Change 'byte-func-to-func-h' hash key test. (comp-ctxt): Add 'lambda-fixups-h' slot. (comp-emit-lambda-for-top-level): New function. (comp-finalize-relocs): Never emit lambdas in pure space. (comp-finalize-relocs): Fixup relocation indexes. --- lisp/emacs-lisp/comp.el | 55 +++++++++++++++++++++++++- src/comp.c | 88 ++++++++++++++++++++++++++++++++--------- src/comp.h | 14 +++++-- src/pdumper.c | 18 ++++++++- 4 files changed, 150 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3bcfdc9420b..94ffc2d1778 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,9 +230,11 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") - (byte-func-to-func-h (make-hash-table :test #'eq) :type hash-table + (byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table :documentation "byte-function -> comp-func. Needed to replace immediate byte-compiled lambdas with the compiled reference.") + (lambda-fixups-h (make-hash-table :test #'equal) :type hash-table + :documentation "Hash table byte-func -> mvar to fixup.") (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container @@ -1276,6 +1278,36 @@ the annotation emission." (make-comp-mvar :constant form)) (make-comp-mvar :constant t)))))) +(defun comp-emit-lambda-for-top-level (func) + "Emit the creation of subrs for lambda FUNC. +These are stored in the reloc data array." + (let ((args (comp-func-args func))) + (let ((comp-curr-allocation-class 'd-impure)) + (comp-add-const-to-relocs (comp-func-byte-func func))) + (comp-emit + (comp-call 'comp--register-lambda + ;; mvar to be fixed-up when containers are + ;; finalized. + (or (gethash (comp-func-byte-func func) + (comp-ctxt-lambda-fixups-h comp-ctxt)) + (puthash (comp-func-byte-func func) + (make-comp-mvar :constant nil) + (comp-ctxt-lambda-fixups-h comp-ctxt))) + (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many)) + (make-comp-mvar :constant (comp-func-c-name func)) + (make-comp-mvar + :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc func) h) + i)) + (make-comp-mvar :constant (comp-func-int-spec func)) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0))))) + (defun comp-limplify-top-level (for-late-load) "Create a limple function to modify the global environment at load. When FOR-LATE-LOAD is non nil the emitted function modifies only @@ -2143,6 +2175,12 @@ Update all insn accordingly." (d-impure-idx (comp-data-container-idx d-impure)) (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) + ;; We never want compiled lambdas ending up in pure space. A copy must + ;; be already present in impure (see `comp-emit-lambda-for-top-level'). + (cl-loop for obj being each hash-keys of d-default-idx + when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) + do (cl-assert (gethash obj d-impure-idx)) + (remhash obj d-default-idx)) ;; Remove entries in d-impure already present in d-default. (cl-loop for obj being each hash-keys of d-impure-idx when (gethash obj d-default-idx) @@ -2162,7 +2200,20 @@ Update all insn accordingly." for doc = (gethash idx h) do (setf (aref v idx) doc) finally - do (setf (comp-ctxt-function-docs comp-ctxt) v)))) + do (setf (comp-ctxt-function-docs comp-ctxt) v)) + ;; And now we conclude with the following: We need to pass to + ;; `comp--register-lambda' the index in the impure relocation + ;; array to store revived lambdas, but given we know it only now + ;; we fix it up as last. + (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt) + using (hash-value mvar) + with reverse-h = (make-hash-table) ;; Make sure idx is unique. + for idx = (gethash f d-impure-idx) + do + (cl-assert (null (gethash idx reverse-h))) + (cl-assert (fixnump idx)) + (setf (comp-mvar-constant mvar) idx) + (puthash idx t reverse-h)))) (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. diff --git a/src/comp.c b/src/comp.c index 947da9a8e27..5ace2d28052 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3583,15 +3583,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - bool reloading_cu = !NILP (*saved_cu); + comp_u->loaded_once = !NILP (*saved_cu); Lisp_Object *data_eph_relocs = dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); /* While resurrecting from an image dump loading more than once the same compilation unit does not make any sense. */ - eassert (!(loading_dump && reloading_cu)); + eassert (!(loading_dump && comp_u->loaded_once)); - if (reloading_cu) + if (comp_u->loaded_once) /* 'dlopen' returns the same handle when trying to load two times the same shared. In this case touching 'd_reloc' etc leads to fails in case a frame with a reference to it in a live reg is @@ -3612,13 +3612,17 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, = dynlib_sym (handle, late_load ? "late_top_level_run" : "top_level_run"); - if (!reloading_cu) + /* Always set data_imp_relocs pointer in the compilation unit (in can be + used in 'dump_do_dump_relocation'). */ + comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + + if (!comp_u->loaded_once) { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); if (!(current_thread_reloc @@ -3704,15 +3708,13 @@ native_function_doc (Lisp_Object function) return AREF (cu->data_fdoc_v, XSUBR (function)->doc); } -DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 7, 7, 0, - doc: /* This gets called by top_level_run during load phase to register - each exported subr. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) +static Lisp_Object +make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) { - dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); + dynlib_handle_ptr handle = cu->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); @@ -3727,18 +3729,63 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; - x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); + x->s.symbol_name = xstrdup (SSDATA (symbol_name)); x->s.native_intspec = intspec; x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); + + return tem; +} + +DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, + 7, 7, 0, + doc: /* This gets called by top_level_run during load phase to register + anonymous lambdas. */) + (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) +{ + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); + if (cu->loaded_once) + return Qnil; + + Lisp_Object tem = + make_subr (c_name, minarg, maxarg, c_name, doc_idx, intspec, comp_u); + + /* We must protect it against GC because the function is not + reachable through symbols. */ + Fputhash (tem, Qt, cu->lambda_gc_guard); + /* This is for fixing up the value in d_reloc while resurrecting + from dump. See 'dump_do_dump_relocation'. */ + Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); + /* The key is not really important as long is the same as + symbol_name so use c_name. */ + Fputhash (Fintern (c_name, Qnil), c_name, Vcomp_sym_subr_c_name_h); + /* Do the real relocation fixup. */ + cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem; + + return tem; +} + +DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, + 7, 7, 0, + doc: /* This gets called by top_level_run during load phase to register + each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) +{ + Lisp_Object tem = + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, + comp_u); + set_symbol_function (name, tem); - - Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); LOADHIST_ATTACH (Fcons (Qdefun, name)); + Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); - return Qnil; + return tem; } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, @@ -3759,8 +3806,8 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILE. - LATE_LOAD has to be non nil when loading for deferred - compilation. */) + LATE_LOAD has to be non nil when loading for deferred + compilation. */) (Lisp_Object file, Lisp_Object late_load) { CHECK_STRING (file); @@ -3773,6 +3820,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; comp_u->data_vec = Qnil; + comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); load_comp_unit (comp_u, false, !NILP (late_load)); return Qt; @@ -3886,6 +3935,7 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp__register_lambda); defsubr (&Scomp__register_subr); defsubr (&Scomp__late_register_subr); defsubr (&Snative_elisp_load); diff --git a/src/comp.h b/src/comp.h index cbdcaccd5fe..b03a8055142 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,13 +37,21 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; - /* Hash doc-idx -> function documentaiton. */ + /* Guard anonymous lambdas against Garbage Collection and make them + dumpable. */ + Lisp_Object lambda_gc_guard; + /* Hash c_name -> d_reloc_imp index. */ + Lisp_Object lambda_c_name_idx_h; + /* Hash doc-idx -> function documentaiton. */ Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; - /* Same but for data that cannot be moved to pure space. - Must be the last lisp object here. */ + /* '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; dynlib_handle_ptr handle; }; diff --git a/src/pdumper.c b/src/pdumper.c index f837dfc38d2..a1b71e87ac6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5297,7 +5297,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, 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 = CALLN (Fmake_hash_table, QCtest, Qeq); if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); @@ -5320,6 +5320,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } case RELOC_NATIVE_SUBR: { + /* 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); Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = @@ -5333,6 +5337,18 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!func) error ("can't find function in compilation unit"); subr->function.a0 = func; + Lisp_Object lambda_data_idx = + Fgethash (c_name, comp_u->lambda_c_name_idx_h, Qnil); + if (!NILP (lambda_data_idx)) + { + /* This is an anonymous lambda. + We must fixup data_vec so the lambda can be referenced + by code. */ + Lisp_Object tem; + XSETSUBR (tem, subr); + comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)] = tem; + Fputhash (tem, Qnil, comp_u->lambda_gc_guard); + } break; } #endif From 27b80ae94c677a41f0ca67afe2c36f9e77380390 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 May 2020 16:04:48 +0100 Subject: [PATCH 0866/1452] * Better Vcomp_sym_subr_c_name_h test function + doc * src/comp.c (syms_of_comp): 'Vcomp_sym_subr_c_name_h' need only 'eq' as test + fix doc for 'comp-sym-subr-c-name-h'. --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5ace2d28052..3a362fd0957 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3960,8 +3960,8 @@ syms_of_comp (void) doc: /* List of all defined subrs. */); DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, doc: /* Hash table symbol-function -> function-c-name. For - internal use during */); - Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + internal use during dump reload */); + Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table, QCtest, Qeq); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, doc: /* String signing the ABI exposed to .eln files. */); Vcomp_abi_hash = Qnil; From e5b24b85a25000499186fc3a48f39eed586d5a3f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 May 2020 17:29:43 +0100 Subject: [PATCH 0867/1452] * Native compiler test update * test/src/comp-tests.el (comp-tests-lambda-return): Add a test verifying that the returned lambda is actually native compiled. --- test/src/comp-tests.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ce98227162f..c07c92a1065 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -277,7 +277,9 @@ Check that the resulting binaries do not differ." (should (string= (comp-tests-buff0-f) "foo"))) (ert-deftest comp-tests-lambda-return () - (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) + (let ((f (comp-tests-lambda-return-f))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 3) 4)))) (ert-deftest comp-tests-recursive () (should (= (comp-tests-fib-f 10) 55))) From 2b064c780cdcb4a7bb832e11d4a166954c485ac5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 11 May 2020 19:21:01 +0100 Subject: [PATCH 0868/1452] * Fix speed 2 bootstrap (comp-call-optim-func): Do nothing if the function name is unknown. --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 94ffc2d1778..d546218940b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1994,6 +1994,7 @@ Backward propagate array placement properties." (cl-loop with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) + when self ;; FIXME add proper anonymous lambda support. do (cl-loop for insn-cell on (comp-block-insns b) for insn = (car insn-cell) From e351a12216519d3ed09892752ce0b137f6672986 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 13 May 2020 08:52:47 +0100 Subject: [PATCH 0869/1452] Sanity check on lambdas fixups * src/pdumper.c (dump_do_dump_relocation): While fixing up lambda relocation verify placeholder coherency. * src/comp.c (syms_of_comp): Define symbol 'lambda-fixup'. * lisp/emacs-lisp/comp.el (comp-finalize-container): Leave a lambda-fixup as placeholder in the relocation as a sanity check. --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 1 + src/pdumper.c | 7 +++++-- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d546218940b..7de8e0177c1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2158,7 +2158,7 @@ These are substituted with a normal 'set' op." ;; from the corresponding m-var. collect (if (gethash obj (comp-ctxt-byte-func-to-func-h comp-ctxt)) - nil + 'lambda-fixup obj)))) (defun comp-finalize-relocs () diff --git a/src/comp.c b/src/comp.c index 3a362fd0957..d1f8fe23f0d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3891,6 +3891,7 @@ syms_of_comp (void) DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); DEFSYM (Qlate, "late"); + DEFSYM (Qlambda_fixup, "lambda-fixup"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); diff --git a/src/pdumper.c b/src/pdumper.c index a1b71e87ac6..a6d12b6ea0c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5342,11 +5342,14 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!NILP (lambda_data_idx)) { /* This is an anonymous lambda. - We must fixup data_vec so the lambda can be referenced + We must fixup d_reloc_imp so the lambda can be referenced by code. */ Lisp_Object tem; XSETSUBR (tem, subr); - comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)] = tem; + Lisp_Object *fixup = + &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); + eassert (EQ (*fixup, Qlambda_fixup)); + *fixup = tem; Fputhash (tem, Qnil, comp_u->lambda_gc_guard); } break; From ff9e40e9fefacfda9cce38d8884694b1c5207b1c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 13 May 2020 22:43:48 +0100 Subject: [PATCH 0870/1452] * Add check_comp_unit_relocs * src/comp.c (check_comp_unit_relocs): Add function to verify relocation coherency. (load_comp_unit): Call it. --- src/comp.c | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/comp.c b/src/comp.c index d1f8fe23f0d..dab102cccd9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3572,6 +3572,37 @@ load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) return Fread (make_string (res->data, res->len)); } +/* Return false when something is wrong or true otherwise. */ + +static bool +check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) +{ + dynlib_handle_ptr handle = comp_u->handle; + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i))) + return false; + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + { + Lisp_Object x = data_imp_relocs[i]; + if (EQ (x, Qlambda_fixup)) + return false; + else if (SUBR_NATIVE_COMPILEDP (x)) + { + if (NILP (Fgethash (x, comp_u->lambda_gc_guard, Qnil))) + return false; + } + else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i))) + return false; + } + return true; +} + void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load) @@ -3691,6 +3722,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, data_ephemeral_vec = data_ephemeral_vec; } + eassert (check_comp_unit_relocs (comp_u)); + return; } From 9a64585c126200d0f4b65fd45f6380244fe1d26c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 May 2020 09:11:55 +0100 Subject: [PATCH 0871/1452] * Allow for logging async compilation command line * lisp/emacs-lisp/comp.el (comp-run-async-workers): When non zero verbose log async compilation command line invocation. --- lisp/emacs-lisp/comp.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7de8e0177c1..38c89ec263b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2317,6 +2317,9 @@ display a message." (message "Compiling %s..." ,source-file) (native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ + (_ (progn + (comp-log "\n") + (comp-log (prin1-to-string expr)))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) From d6f6353cfdbbea5501915675081265b4dc4591e3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 15 May 2020 11:43:31 +0100 Subject: [PATCH 0872/1452] * Do not refuse to compile if a dynamic lambda is encountered * lisp/emacs-lisp/comp.el (comp-lex-byte-func-p): New subst. (comp-intern-func-in-ctxt): Do not crash if we still encounter a non lexical scoped lambda. --- lisp/emacs-lisp/comp.el | 52 ++++++++++++++++++++++++----------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 38c89ec263b..662cfe2d4e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -487,6 +487,11 @@ VERBOSITY is a number between 0 and 3." ;;; spill-lap pass specific code. +(defsubst comp-lex-byte-func-p (f) + "Return t if F is a lexical scoped byte compiled function." + (and (byte-code-function-p f) + (fixnump (aref f 0)))) + (defun comp-c-func-name (name prefix) "Given NAME return a name suitable for the native code. Put PREFIX in front of it." @@ -590,28 +595,31 @@ Put PREFIX in front of it." byte-func)) return form)) (name (when top-l-form - (byte-to-native-func-def-name top-l-form))) - (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)))) - ;; Store the c-name to have it retrivable from - ;; `comp-ctxt-top-level-forms'. - (when top-l-form - (setf (byte-to-native-func-def-c-name top-l-form) c-name)) - (unless name - (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))) + (byte-to-native-func-def-name top-l-form)))) + ;; Do not refuse to compile if a dynamic byte-compiled lambda + ;; leaks here (advice). + (when (or name (comp-lex-byte-func-p byte-func)) + (let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (make-comp-func :name name + :byte-func byte-func + :doc (documentation byte-func) + :int-spec (interactive-form byte-func) + :c-name c-name + :args (comp-decrypt-arg-list (aref byte-func 0) + name) + :lap lap + :frame-size (comp-byte-frame-size byte-func)))) + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." From 9e9421c7eecd74c9f163253ab760044fca53f26b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 May 2020 08:48:26 +0100 Subject: [PATCH 0873/1452] * Fix bug#41346 assertion triggered while loading dump * src/comp.c (load_comp_unit): While loading from dump lambda fixups are still to happen here. Verify relocation coherency only after 'top_level_run' execution. --- src/comp.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index dab102cccd9..c9426d1990e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3720,10 +3720,9 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* Make sure data_ephemeral_vec still exists after top_level_run has run. Guard against sibling call optimization (or any other). */ data_ephemeral_vec = data_ephemeral_vec; + eassert (check_comp_unit_relocs (comp_u)); } - eassert (check_comp_unit_relocs (comp_u)); - return; } From 6d850b50c536d558252017d4daea5d5718dcc8b2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 18 May 2020 19:04:07 +0100 Subject: [PATCH 0874/1452] * Make the Evil happy (Bug#41374) * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Blacklist all primitives advised by evil-mode from trampoline optimization. (comp-call-optim-form-call): Prevent trampoline optimization for recursive calls at speed 2 to respect elisp original semantic. --- lisp/emacs-lisp/comp.el | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 662cfe2d4e8..cd1e4dbd92e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -103,7 +103,10 @@ Skip if any is matching." macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer make-indirect-buffer delete-file top-level abort-recursive-edit ;; For user convenience - yes-or-no-p) + yes-or-no-p + ;; Make the Evil happy :/ + read-key-sequence select-window set-window-buffer split-window-internal + use-global-map use-local-map) "Primitive functions for which we do not perform trampoline optimization. This is especially useful for primitives known to be advised or redefined when compilation is performed at `comp-speed' > 0." @@ -1983,10 +1986,9 @@ Backward propagate array placement properties." (fill-args args maxarg)))) `(,call-type ,callee ,@args))) ;; Intra compilation unit procedure call optimization. - ;; Attention speed 3 triggers that for non self calls too!! - ((or (eq callee self) - (and (>= comp-speed 3) - callee-in-unit)) + ;; Attention speed 3 triggers this for non self calls too!! + ((and (>= comp-speed 3) + callee-in-unit) (let* ((func-args (comp-func-args callee-in-unit)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) From 2ac619458520f1399088740e5e13751d362e55a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 18 May 2020 20:45:29 +0100 Subject: [PATCH 0875/1452] * Add new customize `comp-async-env-modifier-form' (Bug#40838) * lisp/emacs-lisp/comp.el (comp-async-env-modifier-form): New customize. (comp-run-async-workers): Make use of `comp-async-env-modifier-form'. --- lisp/emacs-lisp/comp.el | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cd1e4dbd92e..f23a0b29afc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -133,6 +133,12 @@ finishes compiling all input files." :type 'hook :group 'comp) +(defcustom comp-async-env-modifier-form nil + "Form to be evaluated by each asyncronous compilation worker +before compilation. Usable to modify the compiler environment." + :type 'list + :group 'comp) + (defvar comp-dry-run nil "When non nil run everything but the C back-end.") @@ -2324,6 +2330,7 @@ display a message." comp-debug ,comp-debug comp-verbose ,comp-verbose load-path ',load-path) + ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) (native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ From 2aec16ab754aa803efd2e23a54485e34a56bf76c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 18 May 2020 20:51:46 +0100 Subject: [PATCH 0876/1452] * Pacify with the byte-compiler * lisp/emacs-lisp/comp.el (comp-num-cpus): New special variable. (comp-effective-async-max-jobs): Make use of `comp-num-cpus'. (comp-call-optim-form-call): Remove unnecessary parameter. (comp-call-optim-func): Reflect `comp-call-optim-form-call' parameter removal. --- lisp/emacs-lisp/comp.el | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f23a0b29afc..f94544877ed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1964,7 +1964,7 @@ Backward propagate array placement properties." ;; the full compilation unit. ;; For this reason this is triggered only at comp-speed == 3. -(defun comp-call-optim-form-call (callee args self) +(defun comp-call-optim-form-call (callee args) "" (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL @@ -2017,11 +2017,11 @@ Backward propagate array placement properties." do (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) + (comp-mvar-constant f) rest))) (setcar insn-cell `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) + (comp-mvar-constant f) rest))) (setcar insn-cell new-form))))))) (defun comp-call-optim (_) @@ -2296,17 +2296,17 @@ processes from `comp-async-compilations'" do (remhash file-name comp-async-compilations)) (hash-table-count comp-async-compilations)) -(let (num-cpus) - (defun comp-effective-async-max-jobs () - "Compute the effective number of async jobs." - (if (zerop comp-async-jobs-number) - (or num-cpus - (setf num-cpus - ;; Half of the CPUs or at least one. - ;; FIXME portable? - (max 1 (/ (string-to-number (shell-command-to-string "nproc")) - 2)))) - comp-async-jobs-number))) +(defvar comp-num-cpus) +(defun comp-effective-async-max-jobs () + "Compute the effective number of async jobs." + (if (zerop comp-async-jobs-number) + (or comp-num-cpus + (setf comp-num-cpus + ;; Half of the CPUs or at least one. + ;; FIXME portable? + (max 1 (/ (string-to-number (shell-command-to-string "nproc")) + 2)))) + comp-async-jobs-number)) (defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. From f5ba60defbef2445243b513416c2c2f2b5766cd6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 May 2020 08:40:56 +0100 Subject: [PATCH 0877/1452] * lisp/emacs-lisp/comp.el (comp-num-cpus): Fix definition. Introduced by 2aec16ab75. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f94544877ed..9fe614f9e94 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2296,7 +2296,7 @@ processes from `comp-async-compilations'" do (remhash file-name comp-async-compilations)) (hash-table-count comp-async-compilations)) -(defvar comp-num-cpus) +(defvar comp-num-cpus nil) (defun comp-effective-async-max-jobs () "Compute the effective number of async jobs." (if (zerop comp-async-jobs-number) From 68fad7a8fc98d41284c4054dd7b53fbb0d990cba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 8 May 2020 16:02:58 -0300 Subject: [PATCH 0878/1452] Do not block SIGIO in platforms that don't have it. * src/comp.c (comp--compile-ctxt-to-file): Add a preprocessor check to avoid blocking SIGIO in platforms that don't have it. Signed-off-by: Andrea Corallo --- src/comp.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/comp.c b/src/comp.c index c9426d1990e..87b86ddba7f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3364,7 +3364,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigemptyset (&blocked); sigaddset (&blocked, SIGALRM); sigaddset (&blocked, SIGINT); +#ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +#endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); } emit_ctxt_code (); From 05b08f26444213ce93aff668a80a81a820c73feb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 8 May 2020 15:56:09 -0300 Subject: [PATCH 0879/1452] * Handle setjmp() taking two arguments in Windows. * src/comp.c: Add `define_setjmp_deps()` and `emit_setjmp()` which abstract over this difference in behavior between operating systems. WARNING: Not all cases are handled by this patch. The Mingw-64 setjmp.h header deals with many other combinations. I don't think it is a good idea to replicate the logic of that header inside emacs. (Maybe a few lines in the configure script could be added to handle this problem?) --- src/comp.c | 47 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 41 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 87b86ddba7f..3fa3361bbf2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see . */ #ifdef HAVE_NATIVE_COMP +#include #include #include #include @@ -74,10 +75,15 @@ along with GNU Emacs. If not, see . */ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR (name)) -#ifdef HAVE__SETJMP -#define SETJMP _setjmp +#ifndef WINDOWSNT +# ifdef HAVE__SETJMP +# define SETJMP _setjmp +# else +# define SETJMP setjmp +# endif #else -#define SETJMP setjmp +/* snippet from MINGW-64 setjmp.h */ +# define SETJMP _setjmp #endif #define SETJMP_NAME SETJMP @@ -1493,6 +1499,30 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) direct); } +static gcc_jit_rvalue * +emit_setjmp (gcc_jit_rvalue *buf) +{ +#ifndef WINDOWSNT + gcc_jit_rvalue *args[] = {buf}; + return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, + false); +#else + /* _setjmp (buf, __builtin_frame_address (0)) */ + gcc_jit_rvalue *args[2]; + + args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); + + args[1] = gcc_jit_context_new_call (comp.ctxt, + NULL, + gcc_jit_context_get_builtin_function (comp.ctxt, + "__builtin_frame_address"), + 1, args); + args[0] = buf; + return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, + false); +#endif +} + /* Register an handler for a non local exit. */ static void @@ -1519,8 +1549,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, NULL); gcc_jit_rvalue *res; - res = - emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, false); + res = emit_setjmp (args[0]); emit_cond_jump (res, handler_bb, guarded_bb); } @@ -2079,8 +2108,14 @@ declare_runtime_imported_funcs (void) args[1] = comp.int_type; ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); +#ifndef WINDOWSNT args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); +#else + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + args[1] = comp.void_ptr_type; + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); +#endif ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); @@ -2320,7 +2355,7 @@ define_jmp_buf (void) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.char_type, - sizeof (jmp_buf)), + sizeof (sys_jmp_buf)), "stuff"); comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, From 72a96ed992bbc3ec446a974322dc8ba9dd94ce39 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 May 2020 20:24:41 +0100 Subject: [PATCH 0880/1452] * src/comp.c (emit_setjmp): Aesthetic, respect 80 columns limit. --- src/comp.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3fa3361bbf2..86a9721108c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1510,13 +1510,16 @@ emit_setjmp (gcc_jit_rvalue *buf) /* _setjmp (buf, __builtin_frame_address (0)) */ gcc_jit_rvalue *args[2]; - args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); - args[1] = gcc_jit_context_new_call (comp.ctxt, - NULL, - gcc_jit_context_get_builtin_function (comp.ctxt, - "__builtin_frame_address"), - 1, args); + args[1] = + gcc_jit_context_new_call ( + comp.ctxt, + NULL, + gcc_jit_context_get_builtin_function (comp.ctxt, + "__builtin_frame_address"), + 1, args); args[0] = buf; return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, false); From 5ff2cbdb04fe190c12b43a6c0f95a311da767872 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 8 May 2020 16:23:10 -0300 Subject: [PATCH 0881/1452] * Remove a layer of indirection for access to pure storage. * src/comp.c: Taking the address of an array is the same as casting it to a pointer. Therefore, the C expression `(EMACS_INT **) &pure` is in fact adding a layer of indirection that is not necessary. The fix is to cast the `pure` array to a pointer and store that in a void pointer that is part of the compiled shared library. --- src/comp.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 86a9721108c..15dd0487c01 100644 --- a/src/comp.c +++ b/src/comp.c @@ -142,7 +142,7 @@ typedef struct { gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread_ref; /* Other globals. */ - gcc_jit_rvalue *pure_ref; + gcc_jit_rvalue *pure_ptr; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -1320,8 +1320,7 @@ emit_PURE_P (gcc_jit_rvalue *ptr) GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, ptr, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.pure_ref, NULL))), + comp.pure_ptr), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -2170,13 +2169,13 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); - comp.pure_ref = + comp.pure_ptr = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.void_ptr_type), + comp.void_ptr_type, PURE_RELOC_SYM)); gcc_jit_context_new_global ( @@ -3691,7 +3690,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); @@ -3708,7 +3707,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; - *pure_reloc = (EMACS_INT **)&pure; + *pure_reloc = pure; /* Imported functions. */ *freloc_link_table = freloc.link_table; From 7fa83f9ac96bd201a15f7b0ae4a2cd20a70fd7ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 8 May 2020 14:30:14 -0300 Subject: [PATCH 0882/1452] Handle LISP_WORDS_ARE_POINTERS and CHECK_LISP_OBJECT_TYPE. * src/comp.c: Introduce the Lisp_X, Lisp_Word, and Lisp_Word_tag types. These types are used instead of long or long long. Use emacs_int_type and emacs_uint_types where appropriate. (emit_coerce): Add special logic that handles the case when Lisp_Object is a struct. This is necessary for handling the --enable-check-lisp-object-type configure option. * src/lisp.h: Since libgccjit does not support opaque unions, change Lisp_X to be struct. This is done to ensure that the same types are used in the same binary. It is probably unnecessary since only a pointer to it is used. --- src/comp.c | 319 ++++++++++++++++++++++++++++++++++++----------------- src/lisp.h | 5 +- 2 files changed, 218 insertions(+), 106 deletions(-) diff --git a/src/comp.c b/src/comp.c index 15dd0487c01..acb018bab7b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -116,6 +116,16 @@ typedef struct { gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; +#if LISP_WORDS_ARE_POINTERS + gcc_jit_struct *lisp_X_s; + gcc_jit_type *lisp_X; +#endif + gcc_jit_type *lisp_word_type; + gcc_jit_type *lisp_word_tag_type; +#ifdef LISP_OBJECT_IS_STRUCT + gcc_jit_field *lisp_obj_i; + gcc_jit_struct *lisp_obj_s; +#endif gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; /* struct Lisp_Cons */ @@ -158,7 +168,8 @@ typedef struct { gcc_jit_field *cast_union_as_c_p; gcc_jit_field *cast_union_as_v_p; gcc_jit_field *cast_union_as_lisp_cons_ptr; - gcc_jit_field *cast_union_as_lisp_obj; + gcc_jit_field *cast_union_as_lisp_word; + gcc_jit_field *cast_union_as_lisp_word_tag; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ @@ -344,8 +355,10 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_c_p; else if (type == comp.lisp_cons_ptr_type) field = comp.cast_union_as_lisp_cons_ptr; - else if (type == comp.lisp_obj_type) - field = comp.cast_union_as_lisp_obj; + else if (type == comp.lisp_word_type) + field = comp.cast_union_as_lisp_word; + else if (type == comp.lisp_word_tag_type) + field = comp.cast_union_as_lisp_word_tag; else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else @@ -624,6 +637,31 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) if (new_type == old_type) return obj; +#ifdef LISP_OBJECT_IS_STRUCT + if (old_type == comp.lisp_obj_type) + { + gcc_jit_rvalue *lwordobj = + gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i); + return emit_coerce (new_type, lwordobj); + } + + if (new_type == comp.lisp_obj_type) + { + gcc_jit_rvalue *lwordobj = + emit_coerce (comp.lisp_word_type, obj); + + gcc_jit_lvalue *tmp_s + = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, + format_string ("lisp_obj_%td", i++)); + + gcc_jit_block_add_assignment (comp.block, NULL, + gcc_jit_lvalue_access_field (tmp_s, NULL, + comp.lisp_obj_i), + lwordobj); + return gcc_jit_lvalue_as_rvalue (tmp_s); + } +#endif + gcc_jit_field *orig_field = type_to_cast_field (old_type); gcc_jit_field *dest_field = type_to_cast_field (new_type); @@ -661,14 +699,8 @@ emit_binary_op (enum gcc_jit_binary_op op, /* Should come with libgccjit. */ static gcc_jit_rvalue * -emit_rvalue_from_long_long (long long n) +emit_rvalue_from_long_long (gcc_jit_type *type, long long n) { -#ifndef WIDE_EMACS_INT - xsignal1 (Qnative_ice, - build_string ("emit_rvalue_from_long_long called in non wide int" - " configuration")); -#endif - emit_comment (format_string ("emit long long: %lld", n)); gcc_jit_rvalue *high = @@ -694,7 +726,7 @@ emit_rvalue_from_long_long (long long n) 32)); return - emit_coerce (comp.long_long_type, + emit_coerce (type, emit_binary_op ( GCC_JIT_BINARY_OP_BITWISE_OR, comp.unsigned_long_long_type, @@ -709,26 +741,120 @@ emit_rvalue_from_long_long (long long n) } static gcc_jit_rvalue * -emit_most_positive_fixnum (void) +emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) { -#if EMACS_INT_MAX > LONG_MAX - return emit_rvalue_from_long_long (MOST_POSITIVE_FIXNUM); + emit_comment (format_string ("emit unsigned long long: %llu", n)); + + gcc_jit_rvalue *high = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.unsigned_long_long_type, + n >> 32); + gcc_jit_rvalue *low = + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_long_long_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + gcc_jit_context_new_rvalue_from_long ( + comp.ctxt, + comp.unsigned_long_long_type, + n), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)); + + return emit_coerce ( + type, + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_OR, + comp.unsigned_long_long_type, + emit_binary_op ( + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), + low)); +} + +static gcc_jit_rvalue * +emit_rvalue_from_emacs_uint (EMACS_UINT val) +{ + if (val != (long) val) + { + return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); + } +} + +static gcc_jit_rvalue * +emit_rvalue_from_emacs_int (EMACS_INT val) +{ + if (val != (long) val) + { + return emit_rvalue_from_long_long (comp.emacs_int_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, val); + } +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) +{ + if (val != (long) val) + { + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); + } +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_word (Lisp_Word val) +{ +#if LISP_WORDS_ARE_POINTERS + return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.lisp_word_type, + val); #else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_POSITIVE_FIXNUM); + if (val != (long) val) + { + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_type, + val); + } #endif } static gcc_jit_rvalue * -emit_most_negative_fixnum (void) +emit_rvalue_from_lisp_obj (Lisp_Object obj) { -#if EMACS_INT_MAX > LONG_MAX - return emit_rvalue_from_long_long (MOST_NEGATIVE_FIXNUM); +#ifdef LISP_OBJECT_IS_STRUCT + return emit_coerce (comp.lisp_obj_type, + emit_rvalue_from_lisp_word (obj.i)); #else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_NEGATIVE_FIXNUM); + return emit_rvalue_from_lisp_word (obj); #endif } @@ -766,7 +892,7 @@ static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { emit_comment ("XLI"); - return obj; + return emit_coerce (comp.emacs_int_type, obj); } static gcc_jit_lvalue * @@ -776,54 +902,40 @@ emit_lval_XLI (gcc_jit_lvalue *obj) return obj; } -/* + static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { emit_comment ("XLP"); - return gcc_jit_rvalue_access_field (obj, - NULL, - comp.lisp_obj_as_ptr); + return emit_coerce (comp.void_ptr_type, obj); } -static gcc_jit_lvalue * -emit_lval_XLP (gcc_jit_lvalue *obj) -{ - emit_comment ("lval_XLP"); +/* TODO */ +/* static gcc_jit_lvalue * */ +/* emit_lval_XLP (gcc_jit_lvalue *obj) */ +/* { */ +/* emit_comment ("lval_XLP"); */ + +/* return gcc_jit_lvalue_access_field (obj, */ +/* NULL, */ +/* comp.lisp_obj_as_ptr); */ +/* } */ - return gcc_jit_lvalue_access_field (obj, - NULL, - comp.lisp_obj_as_ptr); -} */ static gcc_jit_rvalue * -emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ emit_comment ("XUNTAG"); -#ifndef WIDE_EMACS_INT return emit_coerce ( gcc_jit_type_get_pointer (type), emit_binary_op ( GCC_JIT_BINARY_OP_MINUS, - comp.emacs_int_type, - emit_XLI (a), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.emacs_int_type, - lisp_word_tag))); -#else - return emit_coerce ( - gcc_jit_type_get_pointer (type), - emit_binary_op ( - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_long_long_type, - /* FIXME Should be XLP. */ - emit_XLI (a), - emit_rvalue_from_long_long (lisp_word_tag))); -#endif + comp.uintptr_type, + emit_XLP (a), + emit_rvalue_from_lisp_word_tag(lisp_word_tag))); } static gcc_jit_rvalue * @@ -850,7 +962,7 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) } static gcc_jit_rvalue * -emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) +emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag) { /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -1051,17 +1163,7 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) comp.emacs_int_type, tmp, comp.lisp_int0); - gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - "lisp_obj_fixnum"); - - gcc_jit_block_add_assignment (comp.block, - NULL, - emit_lval_XLI (res), - tmp); - - return gcc_jit_lvalue_as_rvalue (res); + return emit_coerce (comp.lisp_obj_type, tmp); } static gcc_jit_rvalue * @@ -1073,10 +1175,8 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) return XIL (n); */ - gcc_jit_rvalue *intmask = - emit_coerce (comp.emacs_uint_type, - emit_rvalue_from_long_long ((EMACS_INT_MAX - >> (INTTYPEBITS - 1)))); + gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK); + n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND, comp.emacs_uint_type, intmask, n); @@ -1087,12 +1187,10 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_uint_type, comp.lisp_int0, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.emacs_uint_type, - VALBITS)), + emit_rvalue_from_emacs_uint (VALBITS)), n); - return emit_XLI (emit_coerce (comp.emacs_int_type, n)); + + return emit_coerce (comp.lisp_obj_type, n); } @@ -1124,17 +1222,10 @@ emit_lisp_obj_rval (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); - if (NIL_IS_ZERO && EQ (obj, Qnil)) + if (EQ (obj, Qnil)) { gcc_jit_rvalue *n; -#ifdef WIDE_EMACS_INT - eassert (NIL_IS_ZERO); - n = emit_rvalue_from_long_long (0); -#else - n = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - NULL); -#endif + n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil); return emit_coerce (comp.lisp_obj_type, n); } @@ -1360,16 +1451,7 @@ emit_mvar_rval (Lisp_Object mvar) { /* We can still emit directly objects that are self-contained in a word (read fixnums). */ - gcc_jit_rvalue *word; -#ifdef WIDE_EMACS_INT - word = emit_rvalue_from_long_long (constant); -#else - word = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - XLP (constant)); -#endif - return emit_coerce (comp.lisp_obj_type, word); + return emit_rvalue_from_lisp_obj (constant); } /* Other const objects are fetched from the reloc array. */ return emit_lisp_obj_rval (constant); @@ -2537,11 +2619,16 @@ define_cast_union (void) NULL, comp.lisp_cons_ptr_type, "cons_ptr"); - comp.cast_union_as_lisp_obj = + comp.cast_union_as_lisp_word = gcc_jit_context_new_field (comp.ctxt, NULL, - comp.lisp_obj_type, - "lisp_obj"); + comp.lisp_word_type, + "lisp_word"); + comp.cast_union_as_lisp_word_tag = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_word_tag_type, + "lisp_word_tag"); comp.cast_union_as_lisp_obj_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -2562,7 +2649,8 @@ define_cast_union (void) comp.cast_union_as_c_p, comp.cast_union_as_v_p, comp.cast_union_as_lisp_cons_ptr, - comp.cast_union_as_lisp_obj, + comp.cast_union_as_lisp_word, + comp.cast_union_as_lisp_word_tag, comp.cast_union_as_lisp_obj_ptr }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, @@ -2829,8 +2917,8 @@ define_add1_sub1 (void) GCC_JIT_COMPARISON_NE, n_fixnum, i == 0 - ? emit_most_positive_fixnum () - : emit_most_negative_fixnum ())), + ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) + : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), inline_block, fcall_block); @@ -2900,7 +2988,8 @@ define_negate (void) NULL, GCC_JIT_COMPARISON_NE, n_fixnum, - emit_most_negative_fixnum ())), + emit_rvalue_from_emacs_int ( + MOST_NEGATIVE_FIXNUM))), inline_block, fcall_block); @@ -3318,9 +3407,31 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_UINT), false); - /* No XLP is emitted for now so lets define this always as integer - disregarding LISP_WORDS_ARE_POINTERS value. */ - comp.lisp_obj_type = comp.emacs_int_type; +#if LISP_WORDS_ARE_POINTERS + comp.lisp_X_s = gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X"); + comp.lisp_X = gcc_jit_struct_as_type (comp.lisp_X_s); + comp.lisp_word_type = gcc_jit_type_get_pointer (comp.lisp_X); +#else + comp.lisp_word_type = comp.emacs_int_type; +#endif + comp.lisp_word_tag_type + = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false); +#ifdef LISP_OBJECT_IS_STRUCT + comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_word_type, + "i"); + comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "Lisp_Object", + 1, + &comp.lisp_obj_i); + comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s); +#else + comp.lisp_obj_type = comp.lisp_word_type; +#endif comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, diff --git a/src/lisp.h b/src/lisp.h index 893e278afe0..9e4d53ccf17 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -299,12 +299,12 @@ error !; /* 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 @@ -573,6 +573,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 }; From 38a9ddbc1c656cfaab2c7660f7dab9b0587ecfef Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 May 2020 21:03:29 +0100 Subject: [PATCH 0883/1452] * src/comp.c: Some aesthetic code clean-up. * src/comp.c (comp_t): Remove 'lisp_X_s' field. (emit_coerce): Respect 80 columns limit. (emit_rvalue_from_emacs_uint): GNU style, unnecessary brackets. (emit_rvalue_from_emacs_int): Likewise. (emit_rvalue_from_lisp_word_tag): Likewise. (emit_rvalue_from_lisp_word): Likewise. (emit_lval_XLI): Remove unused function. (emit_lval_XLP): Remove commented out code. (define_add1_sub1): Respect 80 columns limit. (Fcomp__init_ctxt): Reflect 'lisp_X_s' field removal. --- src/comp.c | 104 ++++++++++++++++++----------------------------------- 1 file changed, 35 insertions(+), 69 deletions(-) diff --git a/src/comp.c b/src/comp.c index acb018bab7b..14862228ab2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -117,7 +117,6 @@ typedef struct { gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; #if LISP_WORDS_ARE_POINTERS - gcc_jit_struct *lisp_X_s; gcc_jit_type *lisp_X; #endif gcc_jit_type *lisp_word_type; @@ -650,14 +649,15 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_rvalue *lwordobj = emit_coerce (comp.lisp_word_type, obj); - gcc_jit_lvalue *tmp_s - = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - format_string ("lisp_obj_%td", i++)); + gcc_jit_lvalue *tmp_s = + gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, + format_string ("lisp_obj_%td", i++)); - gcc_jit_block_add_assignment (comp.block, NULL, - gcc_jit_lvalue_access_field (tmp_s, NULL, - comp.lisp_obj_i), - lwordobj); + gcc_jit_block_add_assignment ( + comp.block, NULL, + gcc_jit_lvalue_access_field (tmp_s, NULL, + comp.lisp_obj_i), + lwordobj); return gcc_jit_lvalue_as_rvalue (tmp_s); } #endif @@ -786,44 +786,32 @@ static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { if (val != (long) val) - { - return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); - } + return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_uint_type, - val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); } static gcc_jit_rvalue * emit_rvalue_from_emacs_int (EMACS_INT val) { if (val != (long) val) - { - return emit_rvalue_from_long_long (comp.emacs_int_type, val); - } + return emit_rvalue_from_long_long (comp.emacs_int_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, val); } static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { if (val != (long) val) - { - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); - } + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.lisp_word_tag_type, - val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); } static gcc_jit_rvalue * @@ -835,15 +823,11 @@ emit_rvalue_from_lisp_word (Lisp_Word val) val); #else if (val != (long) val) - { - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); - } + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.lisp_word_type, - val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_type, + val); #endif } @@ -895,14 +879,6 @@ emit_XLI (gcc_jit_rvalue *obj) return emit_coerce (comp.emacs_int_type, obj); } -static gcc_jit_lvalue * -emit_lval_XLI (gcc_jit_lvalue *obj) -{ - emit_comment ("lval_XLI"); - return obj; -} - - static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { @@ -911,17 +887,6 @@ emit_XLP (gcc_jit_rvalue *obj) return emit_coerce (comp.void_ptr_type, obj); } -/* TODO */ -/* static gcc_jit_lvalue * */ -/* emit_lval_XLP (gcc_jit_lvalue *obj) */ -/* { */ -/* emit_comment ("lval_XLP"); */ - -/* return gcc_jit_lvalue_access_field (obj, */ -/* NULL, */ -/* comp.lisp_obj_as_ptr); */ -/* } */ - static gcc_jit_rvalue * emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) { @@ -2912,13 +2877,14 @@ define_add1_sub1 (void) GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, sure_fixnum, - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - n_fixnum, - i == 0 - ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) - : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + i == 0 + ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) + : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), inline_block, fcall_block); @@ -3408,10 +3374,10 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (EMACS_UINT), false); #if LISP_WORDS_ARE_POINTERS - comp.lisp_X_s = gcc_jit_context_new_opaque_struct (comp.ctxt, - NULL, - "Lisp_X"); - comp.lisp_X = gcc_jit_struct_as_type (comp.lisp_X_s); + comp.lisp_X = + gcc_jit_struct_as_type (gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X")); comp.lisp_word_type = gcc_jit_type_get_pointer (comp.lisp_X); #else comp.lisp_word_type = comp.emacs_int_type; From f036ec97cecc8d7ec2cd36741bbe2619cda1207b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 21 May 2020 14:38:51 +0100 Subject: [PATCH 0884/1452] * src/comp.c: Fix i386 --enable-check-lisp-object-type * src/comp.c (load_comp_unit): Fix return type, on i386 influence parameter passing! --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 14862228ab2..6371757487c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3755,7 +3755,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, freloc_check_fill (); - void (*top_level_run)(Lisp_Object) + Lisp_Object (*top_level_run)(Lisp_Object) = dynlib_sym (handle, late_load ? "late_top_level_run" : "top_level_run"); From 0a2ac47909c497d299e5d5cc111cf77206dcda9b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 21 May 2020 17:51:31 +0100 Subject: [PATCH 0885/1452] * src/comp.c: Fix 32bit wide-int. * src/comp.c (emit_XFIXNUM): Make right shift for MSB_TAG arithmetic too to preserve sign bit. --- src/comp.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6371757487c..994bd7db934 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1066,6 +1066,8 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) emit_comment ("XFIXNUM"); gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); + /* FIXME: Implementation dependent (both RSHIFT are arithmetics). */ + if (!USE_LSB_TAG) { i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, @@ -1073,14 +1075,12 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) i, comp.inttypebits); - return emit_coerce (comp.emacs_int_type, - emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_uint_type, - i, - comp.inttypebits)); + return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } else - /* FIXME: Implementation dependent (wants arithmetic shift). */ return emit_coerce (comp.emacs_int_type, emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, From 483cdf7a7942c91f6691953c9fe4618194dd175b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Mon, 11 May 2020 20:43:06 -0300 Subject: [PATCH 0886/1452] Load libgccjit dynamically in Windows. * configure.ac: don't add linker flags if compiling on Windows. Compile dynlib.c if modules or native compilation are enabled. Always compile comp.c * lisp/term/w32-win.el: Map 'gccjit to "libgccjit.dll" in `dynamic-library-alist`. * src/Makefile.in: Update comments. Update to handle changes in configure.ac. * src/comp.c: Add declarations of used libgccjit functions using DEF_DLL_FN. Add calls to load_gccjit_if_necessary() where necessary. Add `native-comp-available-p` * src/comp.h: Remove Fnative_elisp_load. Add syms_of_comp(). * src/emacs.c (main): Always call syms_of_comp() * src/w32.c (globals_of_w32): Clear Vlibrary_cache when starting because the libraries loaded when dumping will not be loaded when starting. * src/w32fns.c: Add Qgccjit symbol. --- configure.ac | 19 ++- lisp/term/w32-win.el | 3 +- src/Makefile.in | 9 +- src/comp.c | 374 ++++++++++++++++++++++++++++++++++++++++++- src/comp.h | 6 +- src/emacs.c | 2 - src/w32.c | 4 + src/w32fns.c | 1 + 8 files changed, 398 insertions(+), 20 deletions(-) diff --git a/configure.ac b/configure.ac index 23b94cf6ca1..ea0144f4048 100644 --- a/configure.ac +++ b/configure.ac @@ -3666,6 +3666,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" ;; @@ -3701,7 +3702,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]) @@ -3785,7 +3787,6 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -COMP_OBJ= if test "${with_nativecomp}" != "no"; then emacs_save_LIBS=$LIBS LIBS="-lgccjit" @@ -3793,8 +3794,11 @@ if test "${with_nativecomp}" != "no"; then [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes - LIBGCCJIT_LIB="-lgccjit -ldl" - COMP_OBJ="comp.o" + # mingw32 loads the library dynamically. + if test "${opsys}" != "mingw32"; then + LIBGCCJIT_LIB="-lgccjit -ldl" + fi + NEED_DYNLIB=yes AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) fi if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then @@ -3804,7 +3808,12 @@ AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) AC_SUBST(LIBGCCJIT_LIB) -AC_SUBST(COMP_OBJ) + +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 diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 5901e0295e1..6b9716ca307 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -289,7 +289,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.dll"))) ;;; multi-tty support (defvar w32-initialized nil diff --git a/src/Makefile.in b/src/Makefile.in index 63f909ae147..85709184da1 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -241,7 +241,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@ @@ -327,8 +327,9 @@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ LIBGCCJIT = @LIBGCCJIT_LIB@ -## dynlib.o comp.o if native compiler is enabled, otherwise empty. -COMP_OBJ = @COMP_OBJ@ + +## dynlib.o if necessary, else empty +DYNLIB_OBJ = @DYNLIB_OBJ@ RUN_TEMACS = ./temacs @@ -418,7 +419,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 $(COMP_OBJ) \ + 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) \ diff --git a/src/comp.c b/src/comp.c index 994bd7db934..d72fa927460 100644 --- a/src/comp.c +++ b/src/comp.c @@ -20,6 +20,8 @@ along with GNU Emacs. If not, see . */ #include +#include "lisp.h" + #ifdef HAVE_NATIVE_COMP #include @@ -28,7 +30,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include "lisp.h" #include "puresize.h" #include "window.h" #include "dynlib.h" @@ -36,6 +37,347 @@ along with GNU Emacs. If not, see . */ #include "blockinput.h" #include "sha512.h" + +/********************************/ +/* Dynamic loading of libgccjit */ +/********************************/ + +#ifdef WINDOWSNT +# include "w32common.h" + +#undef gcc_jit_block_add_assignment +#undef gcc_jit_block_add_comment +#undef gcc_jit_block_add_eval +#undef gcc_jit_block_end_with_conditional +#undef gcc_jit_block_end_with_jump +#undef gcc_jit_block_end_with_return +#undef gcc_jit_block_end_with_void_return +#undef gcc_jit_context_acquire +#undef gcc_jit_context_compile_to_file +#undef gcc_jit_context_dump_reproducer_to_file +#undef gcc_jit_context_dump_to_file +#undef gcc_jit_context_get_builtin_function +#undef gcc_jit_context_get_first_error +#undef gcc_jit_context_get_int_type +#undef gcc_jit_context_get_type +#undef gcc_jit_context_new_array_access +#undef gcc_jit_context_new_array_type +#undef gcc_jit_context_new_binary_op +#undef gcc_jit_context_new_call +#undef gcc_jit_context_new_call_through_ptr +#undef gcc_jit_context_new_comparison +#undef gcc_jit_context_new_field +#undef gcc_jit_context_new_function +#undef gcc_jit_context_new_function_ptr_type +#undef gcc_jit_context_new_global +#undef gcc_jit_context_new_opaque_struct +#undef gcc_jit_context_new_param +#undef gcc_jit_context_new_rvalue_from_int +#undef gcc_jit_context_new_rvalue_from_long +#undef gcc_jit_context_new_rvalue_from_ptr +#undef gcc_jit_context_new_struct_type +#undef gcc_jit_context_new_unary_op +#undef gcc_jit_context_new_union_type +#undef gcc_jit_context_release +#undef gcc_jit_context_set_bool_option +#undef gcc_jit_context_set_int_option +#undef gcc_jit_context_set_logfile +#undef gcc_jit_function_get_param +#undef gcc_jit_function_new_block +#undef gcc_jit_function_new_local +#undef gcc_jit_lvalue_access_field +#undef gcc_jit_lvalue_as_rvalue +#undef gcc_jit_lvalue_get_address +#undef gcc_jit_param_as_lvalue +#undef gcc_jit_param_as_rvalue +#undef gcc_jit_rvalue_access_field +#undef gcc_jit_rvalue_dereference +#undef gcc_jit_rvalue_dereference_field +#undef gcc_jit_rvalue_get_type +#undef gcc_jit_struct_as_type +#undef gcc_jit_struct_set_fields +#undef gcc_jit_type_get_pointer + +/* In alphabetical order */ +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int, + (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, int value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_as_rvalue, + (gcc_jit_lvalue *lvalue)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_rvalue_access_field, + (gcc_jit_rvalue *struct_or_union, gcc_jit_location *loc, + gcc_jit_field *field)); +DEF_DLL_FN (void, gcc_jit_block_add_comment, + (gcc_jit_block *block, gcc_jit_location *loc, const char *text)); +DEF_DLL_FN (void, gcc_jit_context_release, (gcc_jit_context *ctxt)); +DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, + (gcc_jit_context *ctxt)); +DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, + (gcc_jit_function *func, const char *name)); +DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_get_builtin_function, + (gcc_jit_context *ctxt, const char *name)); +DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_new_function, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_function_kind kind, gcc_jit_type *return_type, + const char *name, int num_params, gcc_jit_param **params, + int is_variadic)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_array_access, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_rvalue *ptr, + gcc_jit_rvalue *index)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_global_kind kind, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local, + (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field, + (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc, + gcc_jit_field *field)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_param_as_lvalue, (gcc_jit_param *param)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference, + (gcc_jit_rvalue *rvalue, gcc_jit_location *loc)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference_field, + (gcc_jit_rvalue *ptr, gcc_jit_location *loc, gcc_jit_field *field)); +DEF_DLL_FN (gcc_jit_param *, gcc_jit_context_new_param, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_param *, gcc_jit_function_get_param, + (gcc_jit_function *func, int index)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_binary_op, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_binary_op op, gcc_jit_type *result_type, + gcc_jit_rvalue *a, gcc_jit_rvalue *b)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_function *func, int numargs , gcc_jit_rvalue **args)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call_through_ptr, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_rvalue *fn_ptr, int numargs, gcc_jit_rvalue **args)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, + (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, + (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_unary_op op, gcc_jit_type *result_type, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_get_address, + (gcc_jit_lvalue *lvalue, gcc_jit_location *loc)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_param_as_rvalue, (gcc_jit_param *param)); +DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_opaque_struct, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name)); +DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_struct_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name, + int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_int_type, + (gcc_jit_context *ctxt, int num_bytes, int is_signed)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_type, + (gcc_jit_context *ctxt, enum gcc_jit_types type_)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_array_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_type *element_type, int num_elements)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_function_ptr_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_type *return_type, int num_params, + gcc_jit_type **param_types, int is_variadic)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name, + int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type, + (gcc_jit_struct *struct_type)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); +DEF_DLL_FN (void, gcc_jit_block_add_assignment, + (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_add_eval, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_end_with_conditional, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *boolval, gcc_jit_block *on_true, + gcc_jit_block *on_false)); +DEF_DLL_FN (void, gcc_jit_block_end_with_jump, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_block *target)); +DEF_DLL_FN (void, gcc_jit_block_end_with_return, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_end_with_void_return, + (gcc_jit_block *block, gcc_jit_location *loc)); +DEF_DLL_FN (void, gcc_jit_context_compile_to_file, + (gcc_jit_context *ctxt, enum gcc_jit_output_kind output_kind, + const char *output_path)); +DEF_DLL_FN (void, gcc_jit_context_dump_reproducer_to_file, + (gcc_jit_context *ctxt, const char *path)); +DEF_DLL_FN (void, gcc_jit_context_dump_to_file, + (gcc_jit_context *ctxt, const char *path, int update_locations)); +DEF_DLL_FN (void, gcc_jit_context_set_bool_option, + (gcc_jit_context *ctxt, enum gcc_jit_bool_option opt, int value)); +DEF_DLL_FN (void, gcc_jit_context_set_int_option, + (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value)); +DEF_DLL_FN (void, gcc_jit_context_set_logfile, + (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity)); +DEF_DLL_FN (void, gcc_jit_struct_set_fields, + (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, + gcc_jit_field **fields)); + +static bool +init_gccjit_functions (void) +{ + HMODULE library; + + if (!(library = w32_delayed_load (Qgccjit))) + { + return false; + } + + /* In alphabetical order */ + LOAD_DLL_FN(library, gcc_jit_block_add_assignment); + LOAD_DLL_FN(library, gcc_jit_block_add_comment); + LOAD_DLL_FN(library, gcc_jit_block_add_eval); + LOAD_DLL_FN(library, gcc_jit_block_end_with_conditional); + LOAD_DLL_FN(library, gcc_jit_block_end_with_jump); + LOAD_DLL_FN(library, gcc_jit_block_end_with_return); + LOAD_DLL_FN(library, gcc_jit_block_end_with_void_return); + LOAD_DLL_FN(library, gcc_jit_context_acquire); + LOAD_DLL_FN(library, gcc_jit_context_compile_to_file); + LOAD_DLL_FN(library, gcc_jit_context_dump_reproducer_to_file); + LOAD_DLL_FN(library, gcc_jit_context_dump_to_file); + LOAD_DLL_FN(library, gcc_jit_context_get_builtin_function); + LOAD_DLL_FN(library, gcc_jit_context_get_first_error); + LOAD_DLL_FN(library, gcc_jit_context_get_int_type); + LOAD_DLL_FN(library, gcc_jit_context_get_type); + LOAD_DLL_FN(library, gcc_jit_context_new_array_access); + LOAD_DLL_FN(library, gcc_jit_context_new_array_type); + LOAD_DLL_FN(library, gcc_jit_context_new_binary_op); + LOAD_DLL_FN(library, gcc_jit_context_new_call); + LOAD_DLL_FN(library, gcc_jit_context_new_call_through_ptr); + LOAD_DLL_FN(library, gcc_jit_context_new_comparison); + LOAD_DLL_FN(library, gcc_jit_context_new_field); + LOAD_DLL_FN(library, gcc_jit_context_new_function); + LOAD_DLL_FN(library, gcc_jit_context_new_function_ptr_type); + LOAD_DLL_FN(library, gcc_jit_context_new_global); + LOAD_DLL_FN(library, gcc_jit_context_new_opaque_struct); + LOAD_DLL_FN(library, gcc_jit_context_new_param); + LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_int); + LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_long); + LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_ptr); + LOAD_DLL_FN(library, gcc_jit_context_new_struct_type); + LOAD_DLL_FN(library, gcc_jit_context_new_unary_op); + LOAD_DLL_FN(library, gcc_jit_context_new_union_type); + LOAD_DLL_FN(library, gcc_jit_context_release); + LOAD_DLL_FN(library, gcc_jit_context_set_bool_option); + LOAD_DLL_FN(library, gcc_jit_context_set_int_option); + LOAD_DLL_FN(library, gcc_jit_context_set_logfile); + LOAD_DLL_FN(library, gcc_jit_function_get_param); + LOAD_DLL_FN(library, gcc_jit_function_new_block); + LOAD_DLL_FN(library, gcc_jit_function_new_local); + LOAD_DLL_FN(library, gcc_jit_lvalue_access_field); + LOAD_DLL_FN(library, gcc_jit_lvalue_as_rvalue); + LOAD_DLL_FN(library, gcc_jit_lvalue_get_address); + LOAD_DLL_FN(library, gcc_jit_param_as_lvalue); + LOAD_DLL_FN(library, gcc_jit_param_as_rvalue); + LOAD_DLL_FN(library, gcc_jit_rvalue_access_field); + LOAD_DLL_FN(library, gcc_jit_rvalue_dereference); + LOAD_DLL_FN(library, gcc_jit_rvalue_dereference_field); + LOAD_DLL_FN(library, gcc_jit_rvalue_get_type); + LOAD_DLL_FN(library, gcc_jit_struct_as_type); + LOAD_DLL_FN(library, gcc_jit_struct_set_fields); + LOAD_DLL_FN(library, gcc_jit_type_get_pointer); + + return true; +} + +/* In alphabetical order */ +#define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment +#define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment +#define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval +#define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional +#define gcc_jit_block_end_with_jump fn_gcc_jit_block_end_with_jump +#define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return +#define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return +#define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file +#define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file +#define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file +#define gcc_jit_context_get_builtin_function fn_gcc_jit_context_get_builtin_function +#define gcc_jit_context_get_first_error fn_gcc_jit_context_get_first_error +#define gcc_jit_context_get_int_type fn_gcc_jit_context_get_int_type +#define gcc_jit_context_get_type fn_gcc_jit_context_get_type +#define gcc_jit_context_new_array_access fn_gcc_jit_context_new_array_access +#define gcc_jit_context_new_array_type fn_gcc_jit_context_new_array_type +#define gcc_jit_context_new_binary_op fn_gcc_jit_context_new_binary_op +#define gcc_jit_context_new_call fn_gcc_jit_context_new_call +#define gcc_jit_context_new_call_through_ptr fn_gcc_jit_context_new_call_through_ptr +#define gcc_jit_context_new_comparison fn_gcc_jit_context_new_comparison +#define gcc_jit_context_new_field fn_gcc_jit_context_new_field +#define gcc_jit_context_new_function fn_gcc_jit_context_new_function +#define gcc_jit_context_new_function_ptr_type fn_gcc_jit_context_new_function_ptr_type +#define gcc_jit_context_new_global fn_gcc_jit_context_new_global +#define gcc_jit_context_new_opaque_struct fn_gcc_jit_context_new_opaque_struct +#define gcc_jit_context_new_param fn_gcc_jit_context_new_param +#define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int +#define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long +#define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type +#define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op +#define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type +#define gcc_jit_context_release fn_gcc_jit_context_release +#define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option +#define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option +#define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile +#define gcc_jit_function_get_param fn_gcc_jit_function_get_param +#define gcc_jit_function_new_block fn_gcc_jit_function_new_block +#define gcc_jit_function_new_local fn_gcc_jit_function_new_local +#define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field +#define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue +#define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address +#define gcc_jit_param_as_lvalue fn_gcc_jit_param_as_lvalue +#define gcc_jit_param_as_rvalue fn_gcc_jit_param_as_rvalue +#define gcc_jit_rvalue_access_field fn_gcc_jit_rvalue_access_field +#define gcc_jit_rvalue_dereference fn_gcc_jit_rvalue_dereference +#define gcc_jit_rvalue_dereference_field fn_gcc_jit_rvalue_dereference_field +#define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type +#define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type +#define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields +#define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer + +#endif + +static bool +load_gccjit_if_necessary (bool mandatory) +{ +#ifdef WINDOWSNT + static bool tried_to_initialize_once; + static bool gccjit_initialized; + + if (!tried_to_initialize_once) + { + tried_to_initialize_once = true; + Lisp_Object status; + gccjit_initialized = init_gccjit_functions (); + status = gccjit_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qgccjit, status), Vlibrary_cache); + } + + if (mandatory && !gccjit_initialized) + xsignal1(Qnative_compiler_error, build_string("libgccjit not found")); + + return gccjit_initialized; +#else + return true; +#endif +} + + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -3295,6 +3637,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, doc: /* Initialize the native compiler context. Return t on success. */) (void) { + load_gccjit_if_necessary(true); + if (comp.ctxt) { xsignal1 (Qnative_ice, @@ -3441,6 +3785,8 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, doc: /* Release the native compiler context. */) (void) { + load_gccjit_if_necessary(true); + if (comp.ctxt) gcc_jit_context_release (comp.ctxt); @@ -3457,6 +3803,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, doc: /* Compile as native code the current context to file. */) (Lisp_Object base_name) { + load_gccjit_if_necessary(true); + CHECK_STRING (base_name); gcc_jit_context_set_int_option (comp.ctxt, @@ -3626,6 +3974,9 @@ maybe_defer_native_compilation (Lisp_Object function_name, fflush (f); } #endif + if (!load_gccjit_if_necessary(false)) + return; + if (!comp_deferred_compilation || noninteractive || !NILP (Vpurify_flag) @@ -3975,10 +4326,26 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, return Qt; } +#endif /* HAVE_NATIVE_COMP */ + +DEFUN ("native-comp-available-p", Fnative_comp_available_p, + Snative_comp_available_p, 0, 0, 0, + doc: /* Returns t if native compilation of Lisp files is available in +this instance of Emacs. */) + (void) +{ +#ifdef HAVE_NATIVE_COMP + return load_gccjit_if_necessary(false) ? Qt : Qnil; +#else + return Qnil; +#endif +} + void syms_of_comp (void) { +#ifdef HAVE_NATIVE_COMP /* Compiler control customizes. */ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, doc: /* If t compile asyncronously every .elc file loaded. */); @@ -4122,6 +4489,7 @@ syms_of_comp (void) doc: /* Hash table symbol-name -> function-value. For internal use during */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); -} +#endif -#endif /* HAVE_NATIVE_COMP */ + defsubr (&Snative_comp_available_p); +} diff --git a/src/comp.h b/src/comp.h index b03a8055142..36e7cdf4413 100644 --- a/src/comp.h +++ b/src/comp.h @@ -90,11 +90,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) {} -static inline Lisp_Object -Fnative_elisp_load (Lisp_Object file, Lisp_Object late_load) -{ - eassume (false); -} +extern void syms_of_comp (void); #endif diff --git a/src/emacs.c b/src/emacs.c index 2c908257422..e75cb588349 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1606,10 +1606,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif -#ifdef HAVE_NATIVE_COMP if (!initialized) syms_of_comp (); -#endif no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); diff --git a/src/w32.c b/src/w32.c index 0f69e652a57..d01a45029d8 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10586,6 +10586,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 */ diff --git a/src/w32fns.c b/src/w32fns.c index e595b0285a7..eeb73489dd5 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10462,6 +10462,7 @@ syms_of_w32fns (void) DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); DEFSYM (Qjson, "json"); + DEFSYM (Qgccjit, "gccjit"); Fput (Qundefined_color, Qerror_conditions, pure_list (Qundefined_color, Qerror)); From 21aef26a4c0234c3af6e3fdd269292a726aa0f48 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 23 May 2020 08:45:51 +0100 Subject: [PATCH 0887/1452] * src/comp.c: Aesthetic, GNU style fixes. --- src/comp.c | 130 ++++++++++++++++++++++++++--------------------------- 1 file changed, 64 insertions(+), 66 deletions(-) diff --git a/src/comp.c b/src/comp.c index d72fa927460..68ad6d3eb8d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -232,66 +232,64 @@ DEF_DLL_FN (void, gcc_jit_struct_set_fields, static bool init_gccjit_functions (void) { - HMODULE library; + HMODULE library = w32_delayed_load (Qgccjit); - if (!(library = w32_delayed_load (Qgccjit))) - { - return false; - } + if (!library) + return false; /* In alphabetical order */ - LOAD_DLL_FN(library, gcc_jit_block_add_assignment); - LOAD_DLL_FN(library, gcc_jit_block_add_comment); - LOAD_DLL_FN(library, gcc_jit_block_add_eval); - LOAD_DLL_FN(library, gcc_jit_block_end_with_conditional); - LOAD_DLL_FN(library, gcc_jit_block_end_with_jump); - LOAD_DLL_FN(library, gcc_jit_block_end_with_return); - LOAD_DLL_FN(library, gcc_jit_block_end_with_void_return); - LOAD_DLL_FN(library, gcc_jit_context_acquire); - LOAD_DLL_FN(library, gcc_jit_context_compile_to_file); - LOAD_DLL_FN(library, gcc_jit_context_dump_reproducer_to_file); - LOAD_DLL_FN(library, gcc_jit_context_dump_to_file); - LOAD_DLL_FN(library, gcc_jit_context_get_builtin_function); - LOAD_DLL_FN(library, gcc_jit_context_get_first_error); - LOAD_DLL_FN(library, gcc_jit_context_get_int_type); - LOAD_DLL_FN(library, gcc_jit_context_get_type); - LOAD_DLL_FN(library, gcc_jit_context_new_array_access); - LOAD_DLL_FN(library, gcc_jit_context_new_array_type); - LOAD_DLL_FN(library, gcc_jit_context_new_binary_op); - LOAD_DLL_FN(library, gcc_jit_context_new_call); - LOAD_DLL_FN(library, gcc_jit_context_new_call_through_ptr); - LOAD_DLL_FN(library, gcc_jit_context_new_comparison); - LOAD_DLL_FN(library, gcc_jit_context_new_field); - LOAD_DLL_FN(library, gcc_jit_context_new_function); - LOAD_DLL_FN(library, gcc_jit_context_new_function_ptr_type); - LOAD_DLL_FN(library, gcc_jit_context_new_global); - LOAD_DLL_FN(library, gcc_jit_context_new_opaque_struct); - LOAD_DLL_FN(library, gcc_jit_context_new_param); - LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_int); - LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_long); - LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_ptr); - LOAD_DLL_FN(library, gcc_jit_context_new_struct_type); - LOAD_DLL_FN(library, gcc_jit_context_new_unary_op); - LOAD_DLL_FN(library, gcc_jit_context_new_union_type); - LOAD_DLL_FN(library, gcc_jit_context_release); - LOAD_DLL_FN(library, gcc_jit_context_set_bool_option); - LOAD_DLL_FN(library, gcc_jit_context_set_int_option); - LOAD_DLL_FN(library, gcc_jit_context_set_logfile); - LOAD_DLL_FN(library, gcc_jit_function_get_param); - LOAD_DLL_FN(library, gcc_jit_function_new_block); - LOAD_DLL_FN(library, gcc_jit_function_new_local); - LOAD_DLL_FN(library, gcc_jit_lvalue_access_field); - LOAD_DLL_FN(library, gcc_jit_lvalue_as_rvalue); - LOAD_DLL_FN(library, gcc_jit_lvalue_get_address); - LOAD_DLL_FN(library, gcc_jit_param_as_lvalue); - LOAD_DLL_FN(library, gcc_jit_param_as_rvalue); - LOAD_DLL_FN(library, gcc_jit_rvalue_access_field); - LOAD_DLL_FN(library, gcc_jit_rvalue_dereference); - LOAD_DLL_FN(library, gcc_jit_rvalue_dereference_field); - LOAD_DLL_FN(library, gcc_jit_rvalue_get_type); - LOAD_DLL_FN(library, gcc_jit_struct_as_type); - LOAD_DLL_FN(library, gcc_jit_struct_set_fields); - LOAD_DLL_FN(library, gcc_jit_type_get_pointer); + LOAD_DLL_FN (library, gcc_jit_block_add_assignment); + LOAD_DLL_FN (library, gcc_jit_block_add_comment); + LOAD_DLL_FN (library, gcc_jit_block_add_eval); + LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); + LOAD_DLL_FN (library, gcc_jit_block_end_with_jump); + LOAD_DLL_FN (library, gcc_jit_block_end_with_return); + LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); + LOAD_DLL_FN (library, gcc_jit_context_acquire); + LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); + LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); + LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); + LOAD_DLL_FN (library, gcc_jit_context_get_builtin_function); + LOAD_DLL_FN (library, gcc_jit_context_get_first_error); + LOAD_DLL_FN (library, gcc_jit_context_get_int_type); + LOAD_DLL_FN (library, gcc_jit_context_get_type); + LOAD_DLL_FN (library, gcc_jit_context_new_array_access); + LOAD_DLL_FN (library, gcc_jit_context_new_array_type); + LOAD_DLL_FN (library, gcc_jit_context_new_binary_op); + LOAD_DLL_FN (library, gcc_jit_context_new_call); + LOAD_DLL_FN (library, gcc_jit_context_new_call_through_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_comparison); + LOAD_DLL_FN (library, gcc_jit_context_new_field); + LOAD_DLL_FN (library, gcc_jit_context_new_function); + LOAD_DLL_FN (library, gcc_jit_context_new_function_ptr_type); + LOAD_DLL_FN (library, gcc_jit_context_new_global); + LOAD_DLL_FN (library, gcc_jit_context_new_opaque_struct); + LOAD_DLL_FN (library, gcc_jit_context_new_param); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); + LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); + LOAD_DLL_FN (library, gcc_jit_context_new_union_type); + LOAD_DLL_FN (library, gcc_jit_context_release); + LOAD_DLL_FN (library, gcc_jit_context_set_bool_option); + LOAD_DLL_FN (library, gcc_jit_context_set_int_option); + LOAD_DLL_FN (library, gcc_jit_context_set_logfile); + LOAD_DLL_FN (library, gcc_jit_function_get_param); + LOAD_DLL_FN (library, gcc_jit_function_new_block); + LOAD_DLL_FN (library, gcc_jit_function_new_local); + LOAD_DLL_FN (library, gcc_jit_lvalue_access_field); + LOAD_DLL_FN (library, gcc_jit_lvalue_as_rvalue); + LOAD_DLL_FN (library, gcc_jit_lvalue_get_address); + LOAD_DLL_FN (library, gcc_jit_param_as_lvalue); + LOAD_DLL_FN (library, gcc_jit_param_as_rvalue); + LOAD_DLL_FN (library, gcc_jit_rvalue_access_field); + LOAD_DLL_FN (library, gcc_jit_rvalue_dereference); + LOAD_DLL_FN (library, gcc_jit_rvalue_dereference_field); + LOAD_DLL_FN (library, gcc_jit_rvalue_get_type); + LOAD_DLL_FN (library, gcc_jit_struct_as_type); + LOAD_DLL_FN (library, gcc_jit_struct_set_fields); + LOAD_DLL_FN (library, gcc_jit_type_get_pointer); return true; } @@ -369,7 +367,7 @@ load_gccjit_if_necessary (bool mandatory) } if (mandatory && !gccjit_initialized) - xsignal1(Qnative_compiler_error, build_string("libgccjit not found")); + xsignal1 (Qnative_compiler_error, build_string ("libgccjit not found")); return gccjit_initialized; #else @@ -1242,7 +1240,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, emit_XLP (a), - emit_rvalue_from_lisp_word_tag(lisp_word_tag))); + emit_rvalue_from_lisp_word_tag (lisp_word_tag))); } static gcc_jit_rvalue * @@ -3637,7 +3635,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, doc: /* Initialize the native compiler context. Return t on success. */) (void) { - load_gccjit_if_necessary(true); + load_gccjit_if_necessary (true); if (comp.ctxt) { @@ -3785,7 +3783,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, doc: /* Release the native compiler context. */) (void) { - load_gccjit_if_necessary(true); + load_gccjit_if_necessary (true); if (comp.ctxt) gcc_jit_context_release (comp.ctxt); @@ -3803,7 +3801,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, doc: /* Compile as native code the current context to file. */) (Lisp_Object base_name) { - load_gccjit_if_necessary(true); + load_gccjit_if_necessary (true); CHECK_STRING (base_name); @@ -3963,7 +3961,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, if (!f) { char str[128]; - sprintf (str, "log_%d", getpid()); + sprintf (str, "log_%d", getpid ()); f = fopen (str, "w"); } if (!f) @@ -3974,7 +3972,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, fflush (f); } #endif - if (!load_gccjit_if_necessary(false)) + if (!load_gccjit_if_necessary (false)) return; if (!comp_deferred_compilation @@ -4313,7 +4311,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (NILP (Ffile_exists_p (file))) xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), file); - struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); + struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); comp_u->handle = dynlib_open (SSDATA (file)); if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); @@ -4335,7 +4333,7 @@ this instance of Emacs. */) (void) { #ifdef HAVE_NATIVE_COMP - return load_gccjit_if_necessary(false) ? Qt : Qnil; + return load_gccjit_if_necessary (false) ? Qt : Qnil; #else return Qnil; #endif From 60b326ef112b6196cccf8bf9508df9e6622285cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 8 May 2020 14:04:06 -0300 Subject: [PATCH 0888/1452] * Workaround the 32768 chars command line limit in Windows. * lisp/emacs-lisp/comp.el (comp-run-async-workers): Pass the compilation commands through a temporary file that is loaded by the child process. This is also done all other operating systems, even those that support long command lines. It should not be a problem since libgccjit uses temporary files too. --- lisp/emacs-lisp/comp.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9fe614f9e94..e5d3be6eed0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2337,6 +2337,10 @@ display a message." (_ (progn (comp-log "\n") (comp-log (prin1-to-string expr)))) + (temp-file (make-temp-file + (concat "emacs-async-comp-" + (file-name-base source-file) "-") + nil ".el" (prin1-to-string expr))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) @@ -2344,13 +2348,14 @@ display a message." :command (list (expand-file-name invocation-name invocation-directory) - "--batch" "--eval" (prin1-to-string expr)) + "--batch" "-l" temp-file) :sentinel (lambda (process _event) (run-hook-with-args 'comp-async-cu-done-hook source-file) (accept-process-output process) + (ignore-errors (delete-file temp-file)) (when (and load1 (zerop (process-exit-status process))) (native-elisp-load From d59607b68592fa709bd8466a3ac7300d280df83a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Wed, 13 May 2020 16:22:17 -0300 Subject: [PATCH 0889/1452] * Windows: Use NUMBER_OF_PROCESSORS environment variable. * lisp/emacs-lisp/comp.el (comp-effective-async-max-jobs): Use NUMBER_OF_PROCESSORS environment variable if system is Windows NT, "nproc" if it is in PATH or a default of 1. --- lisp/emacs-lisp/comp.el | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e5d3be6eed0..6c152136fb5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2302,9 +2302,14 @@ processes from `comp-async-compilations'" (if (zerop comp-async-jobs-number) (or comp-num-cpus (setf comp-num-cpus - ;; Half of the CPUs or at least one. - ;; FIXME portable? - (max 1 (/ (string-to-number (shell-command-to-string "nproc")) + ;; FIXME: we already have a function to determine + ;; the number of processors, see get_native_system_info in w32.c. + ;; The result needs to be exported to Lisp. + (max 1 (/ (cond ((eq 'windows-nt system-type) + (string-to-number (getenv "NUMBER_OF_PROCESSORS"))) + ((executable-find "nproc") + (string-to-number (shell-command-to-string "nproc"))) + (t 1)) 2)))) comp-async-jobs-number)) From f5dceed09a8234548d5b3acb76d443569533cab9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 23 May 2020 14:25:44 +0100 Subject: [PATCH 0890/1452] * lisp/loadup.el: Use new 'native-comp-available-p'. --- lisp/loadup.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/loadup.el b/lisp/loadup.el index 7cf2cb01c33..31843fc24d1 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,7 +449,7 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (boundp 'comp-ctxt) ; FIXME better native-comp feature discriminant? +(when (native-comp-available-p) ;; Fix the compilation unit filename to have it working when ;; when installed or if the source directory got moved. This is set to be ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). From 1b809f378f6263bc099da45c5e4a42c89fef8d71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Tue, 19 May 2020 15:57:31 -0300 Subject: [PATCH 0891/1452] Improve handling of native compilation units still in use in Windows When closing emacs will inspect all directories from which it loaded native compilation units. If it finds a ".eln.old" file it will try to delete it, if it fails that means that another Emacs instance is using it. When compiling a file we rename the file that was in the output path in case it has been loaded into another Emacs instance. When deleting a package we move any ".eln" or ".eln.old" files in the package folder that we can't delete to `package-user-dir`. Emacs will check that directory when closing and delete them. * lisp/emacs-lisp/comp.el (comp--replace-output-file): Function called from C code to finish the compilation process. It performs renaming of the old file if necessary. * lisp/emacs-lisp/package.el (package--delete-directory): Function to delete a package directory. It moves native compilation units that it can't delete to `package-user-dir'. * src/alloc.c (cleanup_vector): Call dispose_comp_unit(). (garbage_collect): Call finish_delayed_disposal_of_comp_units(). * src/comp.c: Restore the signal mask using unwind-protect. Store loaded native compilation units in a hash table for disposal on close. Store filenames of native compilation units GC'd in a linked list to finish their disposal when the GC is over. (clean_comp_unit_directory): Delete all *.eln.old files in a directory. (clean_package_user_dir_of_old_comp_units): Delete all *.eln.old files in `package-user-dir'. (dispose_all_remaining_comp_units): Dispose of native compilation units that are still loaded. (dispose_comp_unit): Close handle and cleanup directory or arrange for later cleanup if DELAY is true. (finish_delayed_disposal_of_comp_units): Dispose of native compilation units that were GC'd. (register_native_comp_unit): Register native compilation unit for disposal when Emacs closes. * src/comp.h: Introduce cfile member in Lisp_Native_Comp_Unit. Add declarations of functions that: clean directories of unused native compilation units, handle disposal of native compilation units. * src/emacs.c (kill-emacs): Dispose all remaining compilation units right right before calling exit(). * src/eval.c (internal_condition_case_3, internal_condition_case_4): Add functions. * src/lisp.h (internal_condition_case_3, internal_condition_case_4): Add functions. * src/pdumper.c (dump_do_dump_relocation): Set cfile to a copy of the Lisp string specifying the file path. --- lisp/emacs-lisp/comp.el | 25 ++++ lisp/emacs-lisp/package.el | 31 ++++- src/alloc.c | 3 +- src/comp.c | 260 +++++++++++++++++++++++++++++++++++-- src/comp.h | 34 +++++ src/emacs.c | 4 + src/eval.c | 55 ++++++++ src/lisp.h | 2 + src/pdumper.c | 3 + 9 files changed, 404 insertions(+), 13 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6c152136fb5..3845827f661 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2277,6 +2277,31 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. +(defun comp--replace-output-file (outfile tmpfile) + "Replace OUTFILE with TMPFILE taking the necessary steps when +dealing with shared libraries that may be loaded into Emacs" + (cond ((eq 'windows-nt system-type) + (ignore-errors (delete-file outfile)) + (let ((retry t)) + (while retry + (setf retry nil) + (condition-case _ + (progn + ;; outfile maybe recreated by another Emacs in + ;; between the following two rename-file calls + (if (file-exists-p outfile) + (rename-file outfile (make-temp-file-internal + (file-name-sans-extension outfile) + nil ".eln.old" nil) + t)) + (rename-file tmpfile outfile nil)) + (file-already-exists (setf retry t)))))) + ;; Remove the old eln instead of copying the new one into it + ;; to get a new inode and prevent crashes in case the old one + ;; is currently loaded. + (t (delete-file outfile) + (rename-file tmpfile outfile)))) + (defvar comp-files-queue () "List of Elisp files to be compiled.") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 808e4f34fc5..4288d906ef5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2204,6 +2204,35 @@ If some packages are not installed propose to install them." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) +(defun package--delete-directory (dir) + "Delete DIR recursively. +In Windows move .eln and .eln.old files that can not be deleted +to `package-user-dir'." + (cond ((eq 'windows-nt system-type) + (let ((retry t)) + (while retry + (setf retry nil) + (condition-case err + (delete-directory dir t) + (file-error + (cl-destructuring-bind (reason1 reason2 filename) err + (if (and (string= "Removing old name" reason1) + (string= "Permission denied" reason2) + (string-prefix-p (expand-file-name package-user-dir) + filename) + (or (string-suffix-p ".eln" filename) + (string-suffix-p ".eln.old" filename))) + (progn + (rename-file filename + (make-temp-file-internal + (concat package-user-dir + (file-name-base filename)) + nil ".eln.old" nil) + t) + (setf retry t)) + (signal (car err) (cdr err))))))))) + (t (delete-directory dir t)))) + (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -2256,7 +2285,7 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-name pkg-used-elsewhere-by))) (t (add-hook 'post-command-hook #'package-menu--post-refresh) - (delete-directory dir t) + (package--delete-directory dir) ;; Remove NAME-VERSION.signed and NAME-readme.txt files. ;; ;; NAME-readme.txt files are no longer created, but they diff --git a/src/alloc.c b/src/alloc.c index 76d49d2efd6..b892022125e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3119,8 +3119,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - eassert (cu->handle); - dynlib_close (cu->handle); + dispose_comp_unit (cu, true); } } diff --git a/src/comp.c b/src/comp.c index 68ad6d3eb8d..16ad77c74bc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,6 +411,10 @@ load_gccjit_if_necessary (bool mandatory) #define CALL1I(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR (fun)), arg) +/* Like call2 but stringify and intern. */ +#define CALL2I(fun, arg1, arg2) \ + CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2) + #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR (name)) @@ -435,6 +439,8 @@ typedef struct { ptrdiff_t size; } f_reloc_t; +sigset_t saved_sigset; + static f_reloc_t freloc; /* C side of the compiler context. */ @@ -3795,6 +3801,13 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +static void +restore_sigmask (void) +{ + pthread_sigmask (SIG_SETMASK, &saved_sigset, 0); + unblock_input (); +} + DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -3816,6 +3829,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); sigset_t oldset; + ptrdiff_t count = 0; + if (!noninteractive) { sigset_t blocked; @@ -3828,6 +3843,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigaddset (&blocked, SIGIO); #endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + count = SPECPDL_INDEX (); + record_unwind_protect_void (restore_sigmask); } emit_ctxt_code (); @@ -3866,18 +3883,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* Remove the old eln instead of copying the new one into it to get - a new inode and prevent crashes in case the old one is currently - loaded. */ - if (!NILP (Ffile_exists_p (out_file))) - Fdelete_file (out_file, Qnil); - Frename_file (tmp_file, out_file, Qnil); + CALL2I(comp--replace-output-file, out_file, tmp_file); if (!noninteractive) - { - pthread_sigmask (SIG_SETMASK, &oldset, 0); - unblock_input (); - } + unbind_to (count, Qnil); return out_file; } @@ -3938,6 +3947,223 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } + +/*********************************/ +/* Disposal of compilation units */ +/*********************************/ + +/* +The problem: Windows does not let us delete an .eln file that has been +loaded by a process. This has two implications in Emacs: + +1) It is not possible to recompile a lisp file if the corresponding +.eln file has been loaded. This is because we'd like to use the same +filename, but we can't delete the old .eln file. + +2) It is not possible to delete a package using `package-delete' +if an .eln file has been loaded. + +* General idea + +The solution to these two problems is to move the foo.eln file +somewhere else and have the last Emacs instance using it delete it. +To make it easy to find what files need to be removed we use two approaches. + +In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same +folder. When Emacs is unloading "foo" (either GC'd the native +compilation unit or Emacs is closing (see below)) we delete all the +.eln.old files in the folder where the original foo.eln was stored. + +Ideally we'd figure out the new name of foo.eln and delete it if +it ends in .eln.old. There is no simple API to do this in +Windows. GetModuleFileName() returns the original filename, not the +current one. This forces us to put .eln.old files in an agreed upon +path. We cannot use %TEMP% because it may be in another drive and then +the rename operation would fail. + +In the 2) case we can't use the same folder where the .eln file +resided, as we are trying to completely remove the package. Since we +are removing packages we can safely move the .eln.old file to +`package-user-dir' as we are sure that that would not mean changing +drives. + +* Implementation details + +The concept of disposal of a native compilation unit refers to +unloading the shared library and deleting all the .eln.old files in +the directory. These are two separate steps. We'll call them +early-disposal and late-disposal. + +There are two data structures used: + +- The `all_loaded_comp_units_h` hashtable. + +This hashtable is used like an array of weak references to native +compilation units. This hash table is filled by load_comp_unit() and +dispose_all_remaining_comp_units() iterates over all values that were +not disposed by the GC and performs all disposal steps when Emacs is +closing. + +- The `delayed_comp_unit_disposal_list` list. + +This is were the dispose_comp_unit() function, when called by the GC +sweep stage, stores the original filenames of the disposed native +compilation units. This is an ad-hoc C structure instead of a Lisp +cons because we need to allocate instances of this structure during +the GC. + +The finish_delayed_disposal_of_comp_units() function will iterate over +this list and perform the late-disposal step when Emacs is closing. + +*/ + +#ifdef WINDOWSNT +#define OLD_ELN_SUFFIX_REGEXP build_string ("\\.eln\\.old\\'") + +static Lisp_Object all_loaded_comp_units_h; + +/* We need to allocate instances of this struct during a GC + * sweep. This is why it can't be transformed into a simple cons. + */ +struct delayed_comp_unit_disposal +{ + struct delayed_comp_unit_disposal *next; + char *filename; +}; + +struct delayed_comp_unit_disposal *delayed_comp_unit_disposal_list; + +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} + +/* Tries to remove all *.eln.old files in DIRNAME. + + * Any error is ignored because it may be due to the file being loaded + * in another Emacs instance. + */ +static void +clean_comp_unit_directory (Lisp_Object dirpath) +{ + if (NILP (dirpath)) + return; + Lisp_Object files_in_dir; + files_in_dir = internal_condition_case_4 (Fdirectory_files, dirpath, Qt, + OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, + return_nil); + FOR_EACH_TAIL (files_in_dir) { DeleteFile (SSDATA (XCAR (files_in_dir))); } +} + +/* Tries to remove all *.eln.old files in `package-user-dir'. + + * This is called when Emacs is closing to clean any *.eln left from a + * deleted package. + */ +void +clean_package_user_dir_of_old_comp_units (void) +{ + Lisp_Object package_user_dir + = find_symbol_value (intern ("package-user-dir")); + if (EQ (package_user_dir, Qunbound) || !STRINGP (package_user_dir)) + return; + + clean_comp_unit_directory (package_user_dir); +} + +/* This function disposes all compilation units that are still loaded. + * It is important that this function is called only right before + * Emacs is closed, otherwise we risk running a subr that is + * implemented in an unloaded dynamic library. + */ +void +dispose_all_remaining_comp_units (void) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units_h); + + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + Lisp_Object k = HASH_KEY (h, i); + if (!EQ (k, Qunbound)) + { + Lisp_Object val = HASH_VALUE (h, i); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (val); + dispose_comp_unit (cu, false); + } + } +} + +/* This function finishes the disposal of compilation units that were + * passed to `dispose_comp_unit` with DELAY == true. + * + * This function is called when Emacs is idle and when it is about to + * close. + */ +void +finish_delayed_disposal_of_comp_units (void) +{ + for (struct delayed_comp_unit_disposal *item + = delayed_comp_unit_disposal_list; + delayed_comp_unit_disposal_list; item = delayed_comp_unit_disposal_list) + { + delayed_comp_unit_disposal_list = item->next; + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (item->filename), Qt, return_nil); + clean_comp_unit_directory (dirname); + xfree (item->filename); + xfree (item); + } +} +#endif + +/* This function puts the compilation unit in the + * `all_loaded_comp_units_h` hashmap. + */ +static void +register_native_comp_unit (Lisp_Object comp_u) +{ +#ifdef WINDOWSNT + Fputhash (CALL1I (gensym, Qnil), comp_u, all_loaded_comp_units_h); +#endif +} + +/* This function disposes compilation units. It is called during the GC sweep + * stage and when Emacs is closing. + + * On Windows the the DELAY parameter specifies whether the native + * compilation file will be deleted right away (if necessary) or put + * on a list. That list will be dealt with by + * `finish_delayed_disposal_of_comp_units`. + */ +void +dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) +{ + eassert (comp_handle->handle); + dynlib_close (comp_handle->handle); +#ifdef WINDOWSNT + if (!delay) + { + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (comp_handle->cfile), Qt, + return_nil); + if (!NILP (dirname)) + clean_comp_unit_directory (dirname); + xfree (comp_handle->cfile); + comp_handle->cfile = NULL; + } + else + { + struct delayed_comp_unit_disposal *head; + head = xmalloc (sizeof (struct delayed_comp_unit_disposal)); + head->next = delayed_comp_unit_disposal_list; + head->filename = comp_handle->cfile; + comp_handle->cfile = NULL; + delayed_comp_unit_disposal_list = head; + } +#endif +} + /***********************************/ /* Deferred compilation mechanism. */ @@ -4159,6 +4385,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + + /* If we register them while dumping we will get some entries in + the hash table that will be duplicated when pdumper calls + load_comp_unit. */ + if (!will_dump_p ()) + register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4316,6 +4548,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup (file); +#endif comp_u->data_vec = Qnil; comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); @@ -4464,6 +4699,11 @@ syms_of_comp (void) staticpro (&delayed_sources); delayed_sources = Qnil; +#ifdef WINDOWSNT + staticpro (&all_loaded_comp_units_h); + all_loaded_comp_units_h = CALLN(Fmake_hash_table, QCweakness, Qvalue); +#endif + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); Vcomp_ctxt = Qnil; diff --git a/src/comp.h b/src/comp.h index 36e7cdf4413..b8e40ceb900 100644 --- a/src/comp.h +++ b/src/comp.h @@ -52,7 +52,15 @@ struct Lisp_Native_Comp_Unit /* STUFFS WE DO NOT DUMP!! */ Lisp_Object *data_imp_relocs; bool loaded_once; + dynlib_handle_ptr handle; +#ifdef WINDOWSNT + /* We need to store a copy of the original file name in memory that + is not subject to GC because the function to dispose native + compilation units is called by the GC. By that time the `file' + string may have been sweeped. */ + char * cfile; +#endif }; #ifdef HAVE_NATIVE_COMP @@ -83,6 +91,14 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); + +extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, bool delay); + +extern void finish_delayed_disposal_of_comp_units (void); + +extern void dispose_all_remaining_comp_units (void); + +extern void clean_package_user_dir_of_old_comp_units (void); #else static inline void @@ -92,6 +108,24 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); +static inline void +dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle) +{ + eassert (false); +} + +static inline void +dispose_all_remaining_comp_units (void) +{} + +static inline void +clean_package_user_dir_of_old_comp_units (void) +{} + +static inline void +finish_delayed_disposal_of_comp_units (void) +{} + #endif #endif diff --git a/src/emacs.c b/src/emacs.c index 93a837a44ef..2a7a5257f15 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2398,6 +2398,10 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } + finish_delayed_disposal_of_comp_units (); + dispose_all_remaining_comp_units (); + clean_package_user_dir_of_old_comp_units (); + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/eval.c b/src/eval.c index 37d466f69ed..9e86a185908 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1419,6 +1419,61 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), } } +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as + its arguments. */ + +Lisp_Object +internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as + its arguments. */ + +Lisp_Object +internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, + Lisp_Object arg3, Lisp_Object arg4, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3, arg4); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ diff --git a/src/lisp.h b/src/lisp.h index 4c0057b2552..52242791aa5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4165,6 +4165,8 @@ 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_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); diff --git a/src/pdumper.c b/src/pdumper.c index a6d12b6ea0c..26480388d59 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5312,6 +5312,9 @@ dump_do_dump_relocation (const uintptr_t dump_base, concat2 (Vinvocation_directory, installation_state == LOCAL_BUILD ? XCDR (comp_u->file) : XCAR (comp_u->file)); +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup(comp_u->file); +#endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); From 1bc558b77e648efa905076f793d28fc0f025ae50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 May 2020 21:50:19 +0100 Subject: [PATCH 0892/1452] Fix non Windows builds * src/emacs.c (Fkill_emacs): Given 'finish_delayed_disposal_of_comp_units', 'dispose_all_remaining_comp_units' and 'clean_package_user_dir_of_old_comp_units' are defined only with windows native-comp builds ifdef them. * src/comp.h (dispose_comp_unit): Fix missing parameter in declaration. --- src/comp.h | 2 +- src/emacs.c | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/comp.h b/src/comp.h index b8e40ceb900..18c5ba12298 100644 --- a/src/comp.h +++ b/src/comp.h @@ -109,7 +109,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); static inline void -dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle) +dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle, bool delay) { eassert (false); } diff --git a/src/emacs.c b/src/emacs.c index 2a7a5257f15..cd4f7a0b286 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2398,9 +2398,11 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } +#if defined (HAVE_NATIVE_COMP) && defined (WINDOWSNT) finish_delayed_disposal_of_comp_units (); dispose_all_remaining_comp_units (); clean_package_user_dir_of_old_comp_units (); +#endif if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 From 0bba0e367b4b5378501de7c91838ea2de8b4af4a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 May 2020 21:59:25 +0100 Subject: [PATCH 0893/1452] Fix GNU style * src/comp.h: Fix GNU style. * src/comp.c (Fcomp__compile_ctxt_to_file): Likewise. * lisp/emacs-lisp/comp.el (comp--replace-output-file): Likewise. * src/pdumper.c (dump_do_dump_relocation): Likewise. --- lisp/emacs-lisp/comp.el | 5 +- src/comp.c | 151 +++++++++++++++++++--------------------- src/comp.h | 7 +- src/pdumper.c | 2 +- 4 files changed, 81 insertions(+), 84 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3845827f661..02917cb9a0a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2278,8 +2278,9 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. (defun comp--replace-output-file (outfile tmpfile) - "Replace OUTFILE with TMPFILE taking the necessary steps when -dealing with shared libraries that may be loaded into Emacs" + "Replace OUTFILE with TMPFILE. +Takes the necessary steps when dealing with shared libraries that +may be loaded into Emacs" (cond ((eq 'windows-nt system-type) (ignore-errors (delete-file outfile)) (let ((retry t)) diff --git a/src/comp.c b/src/comp.c index 16ad77c74bc..b4e3e2e887f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3883,7 +3883,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL2I(comp--replace-output-file, out_file, tmp_file); + CALL2I (comp--replace-output-file, out_file, tmp_file); if (!noninteractive) unbind_to (count, Qnil); @@ -3953,67 +3953,68 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /*********************************/ /* -The problem: Windows does not let us delete an .eln file that has been -loaded by a process. This has two implications in Emacs: + The problem: Windows does not let us delete an .eln file that has + been loaded by a process. This has two implications in Emacs: -1) It is not possible to recompile a lisp file if the corresponding -.eln file has been loaded. This is because we'd like to use the same -filename, but we can't delete the old .eln file. + 1) It is not possible to recompile a lisp file if the corresponding + .eln file has been loaded. This is because we'd like to use the same + filename, but we can't delete the old .eln file. -2) It is not possible to delete a package using `package-delete' -if an .eln file has been loaded. + 2) It is not possible to delete a package using `package-delete' + if an .eln file has been loaded. -* General idea + * General idea -The solution to these two problems is to move the foo.eln file -somewhere else and have the last Emacs instance using it delete it. -To make it easy to find what files need to be removed we use two approaches. + The solution to these two problems is to move the foo.eln file + somewhere else and have the last Emacs instance using it delete it. + To make it easy to find what files need to be removed we use two approaches. -In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same -folder. When Emacs is unloading "foo" (either GC'd the native -compilation unit or Emacs is closing (see below)) we delete all the -.eln.old files in the folder where the original foo.eln was stored. + In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same + folder. When Emacs is unloading "foo" (either GC'd the native + compilation unit or Emacs is closing (see below)) we delete all the + .eln.old files in the folder where the original foo.eln was stored. -Ideally we'd figure out the new name of foo.eln and delete it if -it ends in .eln.old. There is no simple API to do this in -Windows. GetModuleFileName() returns the original filename, not the -current one. This forces us to put .eln.old files in an agreed upon -path. We cannot use %TEMP% because it may be in another drive and then -the rename operation would fail. + Ideally we'd figure out the new name of foo.eln and delete it if it + ends in .eln.old. There is no simple API to do this in Windows. + GetModuleFileName () returns the original filename, not the current + one. This forces us to put .eln.old files in an agreed upon path. + We cannot use %TEMP% because it may be in another drive and then the + rename operation would fail. -In the 2) case we can't use the same folder where the .eln file -resided, as we are trying to completely remove the package. Since we -are removing packages we can safely move the .eln.old file to -`package-user-dir' as we are sure that that would not mean changing -drives. + In the 2) case we can't use the same folder where the .eln file + resided, as we are trying to completely remove the package. Since we + are removing packages we can safely move the .eln.old file to + `package-user-dir' as we are sure that that would not mean changing + drives. -* Implementation details + * Implementation details -The concept of disposal of a native compilation unit refers to -unloading the shared library and deleting all the .eln.old files in -the directory. These are two separate steps. We'll call them -early-disposal and late-disposal. + The concept of disposal of a native compilation unit refers to + unloading the shared library and deleting all the .eln.old files in + the directory. These are two separate steps. We'll call them + early-disposal and late-disposal. -There are two data structures used: + There are two data structures used: -- The `all_loaded_comp_units_h` hashtable. + - The `all_loaded_comp_units_h` hashtable. -This hashtable is used like an array of weak references to native -compilation units. This hash table is filled by load_comp_unit() and -dispose_all_remaining_comp_units() iterates over all values that were -not disposed by the GC and performs all disposal steps when Emacs is -closing. + This hashtable is used like an array of weak references to native + compilation units. This hash table is filled by load_comp_unit () + and dispose_all_remaining_comp_units () iterates over all values + that were not disposed by the GC and performs all disposal steps + when Emacs is closing. -- The `delayed_comp_unit_disposal_list` list. + - The `delayed_comp_unit_disposal_list` list. -This is were the dispose_comp_unit() function, when called by the GC -sweep stage, stores the original filenames of the disposed native -compilation units. This is an ad-hoc C structure instead of a Lisp -cons because we need to allocate instances of this structure during -the GC. + This is were the dispose_comp_unit () function, when called by the + GC sweep stage, stores the original filenames of the disposed native + compilation units. This is an ad-hoc C structure instead of a Lisp + cons because we need to allocate instances of this structure during + the GC. -The finish_delayed_disposal_of_comp_units() function will iterate over -this list and perform the late-disposal step when Emacs is closing. + The finish_delayed_disposal_of_comp_units () function will iterate + over this list and perform the late-disposal step when Emacs is + closing. */ @@ -4022,9 +4023,8 @@ this list and perform the late-disposal step when Emacs is closing. static Lisp_Object all_loaded_comp_units_h; -/* We need to allocate instances of this struct during a GC - * sweep. This is why it can't be transformed into a simple cons. - */ +/* We need to allocate instances of this struct during a GC sweep. + This is why it can't be transformed into a simple cons. */ struct delayed_comp_unit_disposal { struct delayed_comp_unit_disposal *next; @@ -4041,9 +4041,8 @@ return_nil (Lisp_Object arg) /* Tries to remove all *.eln.old files in DIRNAME. - * Any error is ignored because it may be due to the file being loaded - * in another Emacs instance. - */ + Any error is ignored because it may be due to the file being loaded + in another Emacs instance. */ static void clean_comp_unit_directory (Lisp_Object dirpath) { @@ -4058,9 +4057,8 @@ clean_comp_unit_directory (Lisp_Object dirpath) /* Tries to remove all *.eln.old files in `package-user-dir'. - * This is called when Emacs is closing to clean any *.eln left from a - * deleted package. - */ + This is called when Emacs is closing to clean any *.eln left from a + deleted package. */ void clean_package_user_dir_of_old_comp_units (void) { @@ -4073,10 +4071,10 @@ clean_package_user_dir_of_old_comp_units (void) } /* This function disposes all compilation units that are still loaded. - * It is important that this function is called only right before - * Emacs is closed, otherwise we risk running a subr that is - * implemented in an unloaded dynamic library. - */ + + It is important that this function is called only right before + Emacs is closed, otherwise we risk running a subr that is + implemented in an unloaded dynamic library. */ void dispose_all_remaining_comp_units (void) { @@ -4095,11 +4093,10 @@ dispose_all_remaining_comp_units (void) } /* This function finishes the disposal of compilation units that were - * passed to `dispose_comp_unit` with DELAY == true. - * - * This function is called when Emacs is idle and when it is about to - * close. - */ + passed to `dispose_comp_unit` with DELAY == true. + + This function is called when Emacs is idle and when it is about to + close. */ void finish_delayed_disposal_of_comp_units (void) { @@ -4118,8 +4115,7 @@ finish_delayed_disposal_of_comp_units (void) #endif /* This function puts the compilation unit in the - * `all_loaded_comp_units_h` hashmap. - */ + `all_loaded_comp_units_h` hashmap. */ static void register_native_comp_unit (Lisp_Object comp_u) { @@ -4128,14 +4124,13 @@ register_native_comp_unit (Lisp_Object comp_u) #endif } -/* This function disposes compilation units. It is called during the GC sweep - * stage and when Emacs is closing. +/* This function disposes compilation units. It is called during the GC sweep + stage and when Emacs is closing. - * On Windows the the DELAY parameter specifies whether the native - * compilation file will be deleted right away (if necessary) or put - * on a list. That list will be dealt with by - * `finish_delayed_disposal_of_comp_units`. - */ + On Windows the the DELAY parameter specifies whether the native + compilation file will be deleted right away (if necessary) or put + on a list. That list will be dealt with by + `finish_delayed_disposal_of_comp_units`. */ void dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) { @@ -4387,10 +4382,10 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); /* If we register them while dumping we will get some entries in - the hash table that will be duplicated when pdumper calls - load_comp_unit. */ + the hash table that will be duplicated when pdumper calls + load_comp_unit. */ if (!will_dump_p ()) - register_native_comp_unit (comp_u_lisp_obj); + register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4701,7 +4696,7 @@ syms_of_comp (void) #ifdef WINDOWSNT staticpro (&all_loaded_comp_units_h); - all_loaded_comp_units_h = CALLN(Fmake_hash_table, QCweakness, Qvalue); + all_loaded_comp_units_h = CALLN (Fmake_hash_table, QCweakness, Qvalue); #endif DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, diff --git a/src/comp.h b/src/comp.h index 18c5ba12298..c6f23dc1468 100644 --- a/src/comp.h +++ b/src/comp.h @@ -57,9 +57,9 @@ struct Lisp_Native_Comp_Unit #ifdef WINDOWSNT /* We need to store a copy of the original file name in memory that is not subject to GC because the function to dispose native - compilation units is called by the GC. By that time the `file' + compilation units is called by the GC. By that time the `file' string may have been sweeped. */ - char * cfile; + char *cfile; #endif }; @@ -92,7 +92,8 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); -extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, bool delay); +extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, + bool delay); extern void finish_delayed_disposal_of_comp_units (void); diff --git a/src/pdumper.c b/src/pdumper.c index 26480388d59..b40a29c02ac 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5313,7 +5313,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, installation_state == LOCAL_BUILD ? XCDR (comp_u->file) : XCAR (comp_u->file)); #ifdef WINDOWSNT - comp_u->cfile = xlispstrdup(comp_u->file); + comp_u->cfile = xlispstrdup (comp_u->file); #endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) From 2bc41e0963275e77ca3627fbfd754fcc041405cb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 May 2020 22:49:38 +0100 Subject: [PATCH 0894/1452] ; Ease ifdef navigation in native-comp files * src/comp.c (syms_of_comp): Add a comment to ease #endif understading. * src/comp.h: Likewise. --- src/comp.c | 3 ++- src/comp.h | 7 ++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index b4e3e2e887f..32a98173d53 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4722,7 +4722,8 @@ syms_of_comp (void) doc: /* Hash table symbol-name -> function-value. For internal use during */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); -#endif + +#endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); } diff --git a/src/comp.h b/src/comp.h index c6f23dc1468..1f64a6df550 100644 --- a/src/comp.h +++ b/src/comp.h @@ -100,7 +100,8 @@ extern void finish_delayed_disposal_of_comp_units (void); extern void dispose_all_remaining_comp_units (void); extern void clean_package_user_dir_of_old_comp_units (void); -#else + +#else /* #ifdef HAVE_NATIVE_COMP */ static inline void maybe_defer_native_compilation (Lisp_Object function_name, @@ -127,6 +128,6 @@ static inline void finish_delayed_disposal_of_comp_units (void) {} -#endif +#endif /* #ifdef HAVE_NATIVE_COMP */ -#endif +#endif /* #ifndef COMP_H */ From f28b1780c6d5ed974e414a423cef8d11ed8145e6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 25 May 2020 20:27:46 +0100 Subject: [PATCH 0895/1452] * Split type hint pass from dead code removal pass into dedicated one. Given SSA prop overwrite mvar type slot we clean-up the compiler type hints as last. * lisp/emacs-lisp/comp.el (comp-passes): Add comp-remove-type-hints. (comp-remove-type-hints-func): Code move. (comp-dead-code): Do not call `comp-remove-type-hints-func'. (comp-remove-type-hints): Add as new pass. --- lisp/emacs-lisp/comp.el | 44 +++++++++++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 02917cb9a0a..11539761d1e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -167,6 +167,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-dead-code comp-tco comp-propagate-alloc + comp-remove-type-hints comp-final) "Passes to be executed in order.") @@ -2089,18 +2090,6 @@ Return the list of m-var ids nuked." insn)))))) nuke-list))) -(defun comp-remove-type-hints-func () - "Remove type hints from the current function. -These are substituted with a normal 'set' op." - (cl-loop - for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) - (setcar insn-cell `(set ,l-val ,r-val))))))) - (defun comp-dead-code (_) "Dead code elimination." (when (>= comp-speed 2) @@ -2112,9 +2101,7 @@ These are substituted with a normal 'set' op." for i from 1 while (comp-dead-assignments-func) finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3)) - (comp-remove-type-hints-func) - (comp-log-func comp-func 3)))) + (comp-log-func comp-func 3))))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -2156,6 +2143,33 @@ These are substituted with a normal 'set' op." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) + +;;; Type hint removal pass specific code. + +;; This must run after all SSA prop not to have the type hint +;; information overwritten. + +(defun comp-remove-type-hints-func () + "Remove type hints from the current function. +These are substituted with a normal 'set' op." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setcar insn-cell `(set ,l-val ,r-val))))))) + +(defun comp-remove-type-hints (_) + "Dead code elimination." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-remove-type-hints-func) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt)))) + ;;; Final pass specific code. From 3fa73fa0fb1caedd10553d9f3185635c039319fd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 25 May 2020 20:14:24 +0100 Subject: [PATCH 0896/1452] Add a compiler hint test Test that compiler hints are executed transparently. * test/src/comp-tests.el (comp-tests-type-hints): New test. * test/src/comp-test-funcs.el (comp-tests-hint-fixnum-f) (comp-tests-hint-cons-f): New functions. --- test/src/comp-test-funcs.el | 6 ++++++ test/src/comp-tests.el | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 9fcc132b518..5e04be4459f 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -50,6 +50,12 @@ (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 () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c07c92a1065..3e40dba10b4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -194,6 +194,12 @@ Check that the resulting binaries do not differ." (should-error (comp-tests-fixnum-minus-f 'a) :type 'wrong-type-argument)) +(ert-deftest comp-tests-type-hints () + "Just test compiler hints are transparent in this case." + ;; FIXME we should really check they are also effective. + (should (= (comp-tests-hint-fixnum-f 3) 4)) + (should (= (comp-tests-hint-cons-f (cons 1 2)) 1))) + (ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." (should (eq (comp-tests-eqlsign-f 4 3) nil)) From 15c121ee0b5cbe005548eeba09dd54b145b2e258 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 30 May 2020 11:13:38 +0100 Subject: [PATCH 0897/1452] * Avoid calling Ffile_exists_p too early Being quite early in startup initialization is better not to rely on Ffile_exists_p, this call Ffile_expand and not all the necessary initialization already happened. * src/pdumper.c (dump_do_dump_relocation): Use fopen instead of Ffile_exists_p. --- src/pdumper.c | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index b40a29c02ac..19dbacca896 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5301,17 +5301,25 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); + /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) - /* Check just once if is a local build or Emacs got installed. */ - installation_state = - NILP (Ffile_exists_p (concat2 (Vinvocation_directory, - XCAR (comp_u->file)))) - ? LOCAL_BUILD : INSTALLED; + { + char *fname = SSDATA (concat2 (Vinvocation_directory, + XCAR (comp_u->file))); + FILE *file; + if ((file = fopen (fname, "r"))) + { + fclose (file); + installation_state = INSTALLED; + } + else + installation_state = LOCAL_BUILD; + } comp_u->file = concat2 (Vinvocation_directory, - installation_state == LOCAL_BUILD - ? XCDR (comp_u->file) : XCAR (comp_u->file)); + installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file)); #ifdef WINDOWSNT comp_u->cfile = xlispstrdup (comp_u->file); #endif From bb9c0188ea3881a555415de7e6fe7973911719e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 29 May 2020 21:03:00 -0300 Subject: [PATCH 0898/1452] Do not call `gensym' too early when loading a dump file. This happened when subr.eln was not the first native compilation unit to be loaded. register_native_comp_unit() is called when loading a native compilation unit and that in turn used to call `gensym', which was not loaded yet. This led to a SIGSEGV. * src/comp.c (register_native_comp_unit): Replace the call to `gensym' with an ad-hoc counter. --- src/comp.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 32a98173d53..d3bff1e4cfe 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4120,7 +4120,12 @@ static void register_native_comp_unit (Lisp_Object comp_u) { #ifdef WINDOWSNT - Fputhash (CALL1I (gensym, Qnil), comp_u, all_loaded_comp_units_h); + /* We have to do this since we can't use `gensym'. This function is + called early when loading a dump file and subr.el may not have + been loaded yet. */ + static intmax_t count; + + Fputhash (make_int (count++), comp_u, all_loaded_comp_units_h); #endif } From b818a49f667a77b7627c678fb4a2ca014f43695e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Fri, 29 May 2020 21:08:37 -0300 Subject: [PATCH 0899/1452] Fix loading of libgccjit.dll while dumping in Windows. loadup.el calls `native-comp-available-p', that calls load_gccjit_if_necessary() in Windows. That function tries to load libgccjit using the mappings defined in `dynamic-library-alist'. That mapping is filled by term/w32-win.el, but that file may be loaded too late. * src/emacs.c (syms_of_emacs): Add libgccjit to the `dynamic-library-alist' used when starting to dump so `native-comp-available-p' always works in Windows. --- src/emacs.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/emacs.c b/src/emacs.c index cd4f7a0b286..8ecf9b4aeba 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3052,7 +3052,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 + /* 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.dll to it. */ + if (will_dump_p ()) + Vdynamic_library_alist = list1 (list2 (Qgccjit, + build_string ("libgccjit.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 From 5cf148cfef23b827629950048dab678f3b9af2d3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 31 May 2020 12:22:46 +0100 Subject: [PATCH 0900/1452] * Emit better debug comments in emit_static_object * src/comp.c (emit_static_object): Do not truncate debug comments at the first NULL character. --- src/comp.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index d3bff1e4cfe..f288fc2551a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2392,8 +2392,15 @@ emit_static_object (const char *name, Lisp_Object obj) 0, NULL, 0); DECL_BLOCK (block, f); - /* NOTE this truncates if the data has some zero byte before termination. */ - gcc_jit_block_add_comment (block, NULL, p); + if (COMP_DEBUG > 1) + { + char *comment = memcpy (xmalloc (len), p, len); + for (ptrdiff_t i = 0; i < len - 1; i++) + if (!comment[i]) + comment[i] = '\n'; + gcc_jit_block_add_comment (block, NULL, comment); + xfree (comment); + } gcc_jit_lvalue *arr = gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); From 3efb2808d415f723ade4a0f9f61738e1a707156c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Wed, 20 May 2020 00:34:32 -0300 Subject: [PATCH 0901/1452] * Cut down compile-time emitting static data as string literals MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This change drastically reduce compile time. Apparently GCC optimizer does not scale up well at all for long sequences of assignments into a single array. Nicolás Bértolo Andrea Corallo * src/comp.c (gcc_jit_context_new_string_literal) (gcc_jit_block_add_assignment_op): New imports. (comp_t): New 'size_t_type' 'memcpy' fields. (emit_static_object): Define static objects using string literals and memcpy. (define_memcpy): New function. (Fcomp__init_ctxt): Define 'size_t_type' and 'memcpy'. --- src/comp.c | 120 ++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 105 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index f288fc2551a..81c4d2fe32a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -46,6 +46,7 @@ along with GNU Emacs. If not, see . */ # include "w32common.h" #undef gcc_jit_block_add_assignment +#undef gcc_jit_block_add_assignment_op #undef gcc_jit_block_add_comment #undef gcc_jit_block_add_eval #undef gcc_jit_block_end_with_conditional @@ -75,6 +76,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_context_new_rvalue_from_int #undef gcc_jit_context_new_rvalue_from_long #undef gcc_jit_context_new_rvalue_from_ptr +#undef gcc_jit_context_new_string_literal #undef gcc_jit_context_new_struct_type #undef gcc_jit_context_new_unary_op #undef gcc_jit_context_new_union_type @@ -164,6 +166,8 @@ DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal, + (gcc_jit_context *ctxt, const char *value)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, (gcc_jit_context *ctxt, gcc_jit_location *loc, enum gcc_jit_unary_op op, gcc_jit_type *result_type, @@ -197,6 +201,10 @@ DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); DEF_DLL_FN (void, gcc_jit_block_add_assignment, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_add_assignment_op, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_lvalue *lvalue, enum gcc_jit_binary_op op, + gcc_jit_rvalue *rvalue)); DEF_DLL_FN (void, gcc_jit_block_add_eval, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_rvalue *rvalue)); @@ -239,6 +247,7 @@ init_gccjit_functions (void) /* In alphabetical order */ LOAD_DLL_FN (library, gcc_jit_block_add_assignment); + LOAD_DLL_FN (library, gcc_jit_block_add_assignment_op); LOAD_DLL_FN (library, gcc_jit_block_add_comment); LOAD_DLL_FN (library, gcc_jit_block_add_eval); LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); @@ -268,6 +277,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_string_literal); LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); LOAD_DLL_FN (library, gcc_jit_context_new_union_type); @@ -296,6 +306,7 @@ init_gccjit_functions (void) /* In alphabetical order */ #define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment +#define gcc_jit_block_add_assignment_op fn_gcc_jit_block_add_assignment_op #define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment #define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval #define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional @@ -325,6 +336,7 @@ init_gccjit_functions (void) #define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int #define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long #define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal #define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type #define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op #define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type @@ -462,6 +474,7 @@ typedef struct { gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; + gcc_jit_type *size_t_type; #if LISP_WORDS_ARE_POINTERS gcc_jit_type *lisp_X; #endif @@ -548,6 +561,7 @@ typedef struct { gcc_jit_rvalue *data_relocs_ephemeral; /* Synthesized struct holding func relocs. */ gcc_jit_lvalue *func_relocs; + gcc_jit_function *memcpy; Lisp_Object d_default_idx; Lisp_Object d_impure_idx; Lisp_Object d_ephemeral_idx; @@ -2347,7 +2361,7 @@ emit_static_object (const char *name, Lisp_Object obj) /* libgccjit has no support for initialized static data. The mechanism below is certainly not aesthetic but I assume the bottle neck in terms of performance at load time will still be the reader. - NOTE: we can not relay on libgccjit even for valid NULL terminated C + NOTE: we can not rely on libgccjit even for valid NULL terminated C strings cause of this funny bug that will affect all pre gcc10 era gccs: https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ @@ -2405,22 +2419,78 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_lvalue *arr = gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); - for (ptrdiff_t i = 0; i < len; i++, p++) + gcc_jit_lvalue *ptrvar = gcc_jit_function_new_local (f, NULL, + comp.char_ptr_type, + "ptr"); + + gcc_jit_block_add_assignment ( + block, + NULL, + ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)), + NULL)); + + for (ptrdiff_t i = 0; i < len;) { - gcc_jit_block_add_assignment ( - block, - NULL, - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (arr), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - i)), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.char_type, - *p)); + /* We can't use string literals longer that 200 bytes because + they cause a crash in older versions of gccjit. + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html. */ + char str[200]; + strncpy (str, p, 200); + str[199] = 0; + uintptr_t l = strlen (str); + + if (l != 0) + { + p += l; + i += l; + + gcc_jit_rvalue *args[3] + = {gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_string_literal (comp.ctxt, str), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.size_t_type, + l)}; + + gcc_jit_block_add_eval (block, NULL, + gcc_jit_context_new_call (comp.ctxt, NULL, + comp.memcpy, + ARRAYELTS (args), + args)); + gcc_jit_block_add_assignment (block, NULL, ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access (comp.ctxt, NULL, + gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + l)), + NULL)); + } + else + { + /* If strlen returned 0 that means that the static object + contains a NULL byte. In that case just move over to the + next block. We can rely on the byte being zero because + of the previous call to bzero and because the dynamic + linker cleared it. */ + p++; + i++; + gcc_jit_block_add_assignment ( + block, NULL, ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access ( + comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, 1)), + NULL)); + } } + gcc_jit_block_add_assignment ( block, NULL, @@ -2766,6 +2836,21 @@ define_jmp_buf (void) 1, &field); } +static void +define_memcpy (void) +{ + + gcc_jit_param *params[] = + { gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "dest"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "src"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.size_t_type, "n") }; + + comp.memcpy = + gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED, + comp.void_ptr_type, "memcpy", + ARRAYELTS (params), params, false); +} + /* struct handler definition */ static void @@ -3772,6 +3857,9 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (void *), false); + comp.size_t_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (size_t), + false); comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal); /* @@ -3780,6 +3868,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, */ comp.imported_funcs_h = CALLN (Fmake_hash_table); + define_memcpy (); + /* Define data structures. */ define_lisp_cons (); From c936e028c643dc2629e6d2041f2069d89d8c5877 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 31 May 2020 20:47:50 +0100 Subject: [PATCH 0902/1452] * Add `comp-libgccjit-version' subr * src/comp.c (gcc_jit_version_major, gcc_jit_version_minor) (gcc_jit_version_patchlevel): Import. (Fcomp_libgccjit_version): New Lisp function. (syms_of_comp): Update for 'comp-libgccjit-version'. --- src/comp.c | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/comp.c b/src/comp.c index 81c4d2fe32a..c9d3fd04070 100644 --- a/src/comp.c +++ b/src/comp.c @@ -236,6 +236,9 @@ DEF_DLL_FN (void, gcc_jit_context_set_logfile, DEF_DLL_FN (void, gcc_jit_struct_set_fields, (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (int, gcc_jit_version_major); +DEF_DLL_FN (int, gcc_jit_version_minor); +DEF_DLL_FN (int, gcc_jit_version_patchlevel); static bool init_gccjit_functions (void) @@ -300,6 +303,9 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN (library, gcc_jit_version_major); + LOAD_DLL_FN (library, gcc_jit_version_minor); + LOAD_DLL_FN (library, gcc_jit_version_patchlevel); return true; } @@ -3988,6 +3994,29 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return out_file; } +DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, + Scomp_libgccjit_version, 0, 0, 0, + doc: /* Return the libgccjit version in use in the form +(MAJOR MINOR PATCHLEVEL) or nil if unknown (pre GCC10). */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) + load_gccjit_if_necessary (true); + + /* FIXME this kludge is quite bad. Can we dynamically load on all + operating systems? */ +#pragma GCC diagnostic ignored "-Waddress" + return gcc_jit_version_major + ? list3 (make_fixnum (gcc_jit_version_major ()), + make_fixnum (gcc_jit_version_minor ()), + make_fixnum (gcc_jit_version_patchlevel ())) + : Qnil; +#pragma GCC diagnostic pop +#else + return Qnil; +#endif +} + /******************************************************************************/ /* Helper functions called from the run-time. */ @@ -4781,6 +4810,7 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp_libgccjit_version); defsubr (&Scomp__register_lambda); defsubr (&Scomp__register_subr); defsubr (&Scomp__late_register_subr); From ce3c1ea83e18e6b8a02013bbdae4b4c183e39997 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 31 May 2020 20:28:31 +0100 Subject: [PATCH 0903/1452] * Optimize 'emit_static_object' for load-time * src/comp.c (emit_static_object): Use a chunck size of 200 bytes on bugged GCCs and a longer one (1024) in sane ones. Rename str in buff to disambiguate and prefer xmalloc to a VLA given the buffer is not that small. --- src/comp.c | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/src/comp.c b/src/comp.c index c9d3fd04070..2d904c91548 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2441,27 +2441,30 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)), NULL)); + /* We can't use always string literals longer that 200 bytes because + they cause a crash in pre GCC 10 libgccjit. + . + + Adjust if possible to reduce the number of function calls. */ + size_t chunck_size = NILP (Fcomp_libgccjit_version ()) ? 200 : 1024; + char *buff = xmalloc (chunck_size); for (ptrdiff_t i = 0; i < len;) { - /* We can't use string literals longer that 200 bytes because - they cause a crash in older versions of gccjit. - https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html. */ - char str[200]; - strncpy (str, p, 200); - str[199] = 0; - uintptr_t l = strlen (str); + strncpy (buff, p, chunck_size); + buff[chunck_size - 1] = 0; + uintptr_t l = strlen (buff); if (l != 0) { p += l; i += l; - gcc_jit_rvalue *args[3] - = {gcc_jit_lvalue_as_rvalue (ptrvar), - gcc_jit_context_new_string_literal (comp.ctxt, str), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.size_t_type, - l)}; + gcc_jit_rvalue *args[] = + { gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_string_literal (comp.ctxt, buff), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.size_t_type, + l) }; gcc_jit_block_add_eval (block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2496,6 +2499,7 @@ emit_static_object (const char *name, Lisp_Object obj) NULL)); } } + xfree (buff); gcc_jit_block_add_assignment ( block, From 2e25eebfbd25b131b6d0fcff4e60f7a8773d912b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 31 May 2020 22:26:08 +0100 Subject: [PATCH 0904/1452] Store libgccjit version into generated code * src/comp.c (emit_ctxt_code): Add libgccjit version into stored optimize qualities. (syms_of_comp): Define Qgccjit here. * src/w32fns.c (syms_of_w32fns): Move out Qgccjit definition. --- src/comp.c | 7 +++++-- src/w32fns.c | 1 - 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2d904c91548..d8e78bc2175 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2634,8 +2634,10 @@ emit_ctxt_code (void) { Fcons (Qcomp_speed, Fsymbol_value (Qcomp_speed)), Fcons (Qcomp_debug, - Fsymbol_value (Qcomp_debug)) }; - emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, opt_qly)); + Fsymbol_value (Qcomp_debug)), + Fcons (Qgccjit, + Fcomp_libgccjit_version ()) }; + emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly)); emit_static_object (TEXT_FDOC_SYM, CALL1I (comp-ctxt-function-docs, Vcomp_ctxt)); @@ -4770,6 +4772,7 @@ syms_of_comp (void) DEFSYM (Qscratch, "scratch"); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); + DEFSYM (Qgccjit, "gccjit"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); diff --git a/src/w32fns.c b/src/w32fns.c index eeb73489dd5..e595b0285a7 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10462,7 +10462,6 @@ syms_of_w32fns (void) DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); DEFSYM (Qjson, "json"); - DEFSYM (Qgccjit, "gccjit"); Fput (Qundefined_color, Qerror_conditions, pure_list (Qundefined_color, Qerror)); From 516575369b7168f09030d297b5a2f89a26f1894d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Sun, 31 May 2020 15:55:18 -0300 Subject: [PATCH 0905/1452] * Remove unnecessary DLL load of gcc_jit_block_add_assignment_op. * src/comp.c (gcc_jit_block_add_assignment_op): Remove unnecessary func import. --- src/comp.c | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index d8e78bc2175..b6726822b75 100644 --- a/src/comp.c +++ b/src/comp.c @@ -46,7 +46,6 @@ along with GNU Emacs. If not, see . */ # include "w32common.h" #undef gcc_jit_block_add_assignment -#undef gcc_jit_block_add_assignment_op #undef gcc_jit_block_add_comment #undef gcc_jit_block_add_eval #undef gcc_jit_block_end_with_conditional @@ -201,10 +200,6 @@ DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); DEF_DLL_FN (void, gcc_jit_block_add_assignment, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, gcc_jit_rvalue *rvalue)); -DEF_DLL_FN (void, gcc_jit_block_add_assignment_op, - (gcc_jit_block *block, gcc_jit_location *loc, - gcc_jit_lvalue *lvalue, enum gcc_jit_binary_op op, - gcc_jit_rvalue *rvalue)); DEF_DLL_FN (void, gcc_jit_block_add_eval, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_rvalue *rvalue)); @@ -250,7 +245,6 @@ init_gccjit_functions (void) /* In alphabetical order */ LOAD_DLL_FN (library, gcc_jit_block_add_assignment); - LOAD_DLL_FN (library, gcc_jit_block_add_assignment_op); LOAD_DLL_FN (library, gcc_jit_block_add_comment); LOAD_DLL_FN (library, gcc_jit_block_add_eval); LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); @@ -312,7 +306,6 @@ init_gccjit_functions (void) /* In alphabetical order */ #define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment -#define gcc_jit_block_add_assignment_op fn_gcc_jit_block_add_assignment_op #define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment #define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval #define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional From 035a91dd963290a40766b430e4e9a108cbbc4eac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Sat, 30 May 2020 18:33:58 -0300 Subject: [PATCH 0906/1452] * Define casts using functions. This is to dump prettier C files. This does not affect compilation times in my tests. * src/comp.c: Define a 15x15 cast matrix. Use it in emit_coerce(). --- src/comp.c | 305 +++++++++++++++++++++++------------------------------ 1 file changed, 134 insertions(+), 171 deletions(-) diff --git a/src/comp.c b/src/comp.c index b6726822b75..8ccae7cf846 100644 --- a/src/comp.c +++ b/src/comp.c @@ -454,6 +454,8 @@ sigset_t saved_sigset; static f_reloc_t freloc; +#define NUM_CAST_TYPES 15 + /* C side of the compiler context. */ typedef struct { @@ -513,21 +515,14 @@ typedef struct { /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; - gcc_jit_field *cast_union_as_ll; - gcc_jit_field *cast_union_as_ull; - gcc_jit_field *cast_union_as_l; - gcc_jit_field *cast_union_as_ul; - gcc_jit_field *cast_union_as_u; - gcc_jit_field *cast_union_as_i; - gcc_jit_field *cast_union_as_b; - gcc_jit_field *cast_union_as_uintptr; - gcc_jit_field *cast_union_as_ptrdiff; - gcc_jit_field *cast_union_as_c_p; - gcc_jit_field *cast_union_as_v_p; - gcc_jit_field *cast_union_as_lisp_cons_ptr; - gcc_jit_field *cast_union_as_lisp_word; - gcc_jit_field *cast_union_as_lisp_word_tag; - gcc_jit_field *cast_union_as_lisp_obj_ptr; + gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES]; + /* We add one to make space for the last member which is the "biggest_type" + member. */ + gcc_jit_type *cast_types[NUM_CAST_TYPES+1]; + size_t cast_type_sizes[NUM_CAST_TYPES+1]; + const char *cast_type_names[NUM_CAST_TYPES+1]; + gcc_jit_field *cast_union_fields[NUM_CAST_TYPES+1]; + size_t cast_union_field_biggest_type; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ @@ -684,47 +679,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -static gcc_jit_field * -type_to_cast_field (gcc_jit_type *type) -{ - gcc_jit_field *field; - - if (type == comp.long_long_type) - field = comp.cast_union_as_ll; - else if (type == comp.unsigned_long_long_type) - field = comp.cast_union_as_ull; - else if (type == comp.long_type) - field = comp.cast_union_as_l; - else if (type == comp.unsigned_long_type) - field = comp.cast_union_as_ul; - else if (type == comp.unsigned_type) - field = comp.cast_union_as_u; - else if (type == comp.int_type) - field = comp.cast_union_as_i; - else if (type == comp.bool_type) - field = comp.cast_union_as_b; - else if (type == comp.void_ptr_type) - field = comp.cast_union_as_v_p; - else if (type == comp.uintptr_type) - field = comp.cast_union_as_uintptr; - else if (type == comp.ptrdiff_type) - field = comp.cast_union_as_ptrdiff; - else if (type == comp.char_ptr_type) - field = comp.cast_union_as_c_p; - else if (type == comp.lisp_cons_ptr_type) - field = comp.cast_union_as_lisp_cons_ptr; - else if (type == comp.lisp_word_type) - field = comp.cast_union_as_lisp_word; - else if (type == comp.lisp_word_tag_type) - field = comp.cast_union_as_lisp_word_tag; - else if (type == comp.lisp_obj_ptr_type) - field = comp.cast_union_as_lisp_obj_ptr; - else - xsignal1 (Qnative_ice, build_string ("unsupported cast")); - - return field; -} - static gcc_jit_block * retrive_block (Lisp_Object block_name) { @@ -985,11 +939,19 @@ emit_cond_jump (gcc_jit_rvalue *test, } +static int +type_to_cast_index (gcc_jit_type * type) +{ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + if (type == comp.cast_types[i]) + return i; + + xsignal1 (Qnative_ice, build_string ("unsupported cast")); +} + static gcc_jit_rvalue * emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { - static ptrdiff_t i; - gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj); if (new_type == old_type) @@ -1021,25 +983,14 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } #endif - gcc_jit_field *orig_field = - type_to_cast_field (old_type); - gcc_jit_field *dest_field = type_to_cast_field (new_type); + int old_index = type_to_cast_index (old_type); + int new_index = type_to_cast_index (new_type); - gcc_jit_lvalue *tmp_u = - gcc_jit_function_new_local (comp.func, - NULL, - comp.cast_union_type, - format_string ("union_cast_%td", i++)); - gcc_jit_block_add_assignment (comp.block, - NULL, - gcc_jit_lvalue_access_field (tmp_u, - NULL, - orig_field), - obj); - - return gcc_jit_rvalue_access_field ( gcc_jit_lvalue_as_rvalue (tmp_u), - NULL, - dest_field); + /* Lookup the appropriate cast function in the cast matrix. */ + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cast_functions_from_to[old_index][new_index], + 1, &obj); } static gcc_jit_rvalue * @@ -2963,109 +2914,121 @@ define_thread_state_struct (void) gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); } -static void -define_cast_union (void) +struct cast_type { + gcc_jit_type *type; + const char *name; + size_t bytes_size; +}; - comp.cast_union_as_ll = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "ll"); - comp.cast_union_as_ull = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_long_long_type, - "ull"); - comp.cast_union_as_l = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_type, - "l"); - comp.cast_union_as_ul = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_long_type, - "ul"); - comp.cast_union_as_u = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_type, - "u"); - comp.cast_union_as_i = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "i"); - comp.cast_union_as_b = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "b"); - comp.cast_union_as_uintptr = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.uintptr_type, - "uintptr"); - comp.cast_union_as_ptrdiff = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.ptrdiff_type, - "ptrdiff"); - comp.cast_union_as_c_p = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.char_ptr_type, - "c_p"); - comp.cast_union_as_v_p = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "v_p"); - comp.cast_union_as_lisp_cons_ptr = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_cons_ptr_type, - "cons_ptr"); - comp.cast_union_as_lisp_word = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_word_type, - "lisp_word"); - comp.cast_union_as_lisp_word_tag = - gcc_jit_context_new_field (comp.ctxt, +static gcc_jit_function * +define_cast_from_to (struct cast_type from, int from_index, struct cast_type to, + int to_index) +{ + char *name = format_string ("cast_from_%s_to_%s", from.name, to.name); + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, + from.type, "arg"); + gcc_jit_function *result = gcc_jit_context_new_function (comp.ctxt, NULL, - comp.lisp_word_tag_type, - "lisp_word_tag"); - comp.cast_union_as_lisp_obj_ptr = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "lisp_obj_ptr"); + GCC_JIT_FUNCTION_INTERNAL, + to.type, + name, + 1, + ¶m, + 0); + DECL_BLOCK (entry_block, result); + + gcc_jit_lvalue *tmp_union + = gcc_jit_function_new_local (result, + NULL, + comp.cast_union_type, + "union_cast"); + + /* Zero the union first. */ + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + comp.cast_union_fields[NUM_CAST_TYPES]), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.cast_types[NUM_CAST_TYPES], + 0)); + + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + comp.cast_union_fields[from_index]), + gcc_jit_param_as_rvalue (param)); + + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + gcc_jit_lvalue_as_rvalue (tmp_union), + NULL, + comp.cast_union_fields[to_index])); + + return result; +} + +static void +define_cast_functions (void) +{ + struct cast_type cast_types[NUM_CAST_TYPES] + = { { comp.bool_type, "bool", sizeof (bool) }, + { comp.char_ptr_type, "char_ptr", sizeof (char *) }, + { comp.int_type, "int", sizeof (int) }, + { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *) }, + { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *) }, + { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag) }, + { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word) }, + { comp.long_long_type, "long_long", sizeof (long long) }, + { comp.long_type, "long", sizeof (long) }, + { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t) }, + { comp.uintptr_type, "uintptr", sizeof (uintptr_t) }, + { comp.unsigned_long_long_type, "unsigned_long_long", + sizeof (unsigned long long) }, + { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long) }, + { comp.unsigned_type, "unsigned", sizeof (unsigned) }, + { comp.void_ptr_type, "void_ptr", sizeof (void*) } }; + + /* Find the biggest size. It should be unsigned long long, but to be + sure we find it programmatically. */ + size_t biggest_size = 0; + for (int i = 0; i < NUM_CAST_TYPES; ++i) + biggest_size = max (biggest_size, cast_types[i].bytes_size); + + /* Define the union used for casting. */ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + { + comp.cast_types[i] = cast_types[i].type; + comp.cast_union_fields[i] = gcc_jit_context_new_field (comp.ctxt, + NULL, + cast_types[i].type, + cast_types[i].name); + comp.cast_type_names[i] = cast_types[i].name; + comp.cast_type_sizes[i] = cast_types[i].bytes_size; + } + + gcc_jit_type *biggest_type = gcc_jit_context_get_int_type (comp.ctxt, + biggest_size, + false); + comp.cast_types[NUM_CAST_TYPES] = biggest_type; + comp.cast_union_fields[NUM_CAST_TYPES] + = gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); + comp.cast_type_names[NUM_CAST_TYPES] = "biggest_type"; + comp.cast_type_sizes[NUM_CAST_TYPES] = biggest_size; - gcc_jit_field *cast_union_fields[] = - { comp.cast_union_as_ll, - comp.cast_union_as_ull, - comp.cast_union_as_l, - comp.cast_union_as_ul, - comp.cast_union_as_u, - comp.cast_union_as_i, - comp.cast_union_as_b, - comp.cast_union_as_uintptr, - comp.cast_union_as_ptrdiff, - comp.cast_union_as_c_p, - comp.cast_union_as_v_p, - comp.cast_union_as_lisp_cons_ptr, - comp.cast_union_as_lisp_word, - comp.cast_union_as_lisp_word_tag, - comp.cast_union_as_lisp_obj_ptr }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, "cast_union", - ARRAYELTS (cast_union_fields), - cast_union_fields); + NUM_CAST_TYPES + 1, + comp.cast_union_fields); + + /* Define the cast functions using a matrix. */ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + for (int j = 0; j < NUM_CAST_TYPES; ++j) + comp.cast_functions_from_to[i][j] = + define_cast_from_to (cast_types[i], i, cast_types[j], j); } static void @@ -3881,7 +3844,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); - define_cast_union (); + define_cast_functions (); return Qt; } From 9f6c12be5574060014f91ad6190d79124ea19802 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Sun, 31 May 2020 18:09:12 -0300 Subject: [PATCH 0907/1452] * Throw an ICE when asked to emit a cast with sign extension. * src/comp.c (cast_kind_of_type): Enum that specifies the kind of type in the cast enum (unsigned, signed, pointer). (emit_coerce): Throw an ICE when asked to emit a cast with sign extension. (define_cast_from_to): Return NULL for casts involving sign extension. (define_cast_functions): Specify the kind of each type in the cast union. --- src/comp.c | 70 ++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 49 insertions(+), 21 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8ccae7cf846..d0574ac5ef3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -456,6 +456,13 @@ static f_reloc_t freloc; #define NUM_CAST_TYPES 15 +enum cast_kind_of_type + { + kind_unsigned, + kind_signed, + kind_pointer + }; + /* C side of the compiler context. */ typedef struct { @@ -518,10 +525,11 @@ typedef struct { gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES]; /* We add one to make space for the last member which is the "biggest_type" member. */ - gcc_jit_type *cast_types[NUM_CAST_TYPES+1]; - size_t cast_type_sizes[NUM_CAST_TYPES+1]; - const char *cast_type_names[NUM_CAST_TYPES+1]; - gcc_jit_field *cast_union_fields[NUM_CAST_TYPES+1]; + gcc_jit_type *cast_types[NUM_CAST_TYPES + 1]; + size_t cast_type_sizes[NUM_CAST_TYPES + 1]; + enum cast_kind_of_type cast_type_kind[NUM_CAST_TYPES + 1]; + const char *cast_type_names[NUM_CAST_TYPES + 1]; + gcc_jit_field *cast_union_fields[NUM_CAST_TYPES + 1]; size_t cast_union_field_biggest_type; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ @@ -986,6 +994,13 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) int old_index = type_to_cast_index (old_type); int new_index = type_to_cast_index (new_type); + if (comp.cast_type_sizes[old_index] < comp.cast_type_sizes[new_index] + && comp.cast_type_kind[new_index] == kind_signed) + xsignal3 (Qnative_ice, + build_string ("FIXME: sign extension not implemented"), + build_string (comp.cast_type_names[old_index]), + build_string (comp.cast_type_names[new_index])); + /* Lookup the appropriate cast function in the cast matrix. */ return gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2919,12 +2934,18 @@ struct cast_type gcc_jit_type *type; const char *name; size_t bytes_size; + enum cast_kind_of_type kind; }; static gcc_jit_function * define_cast_from_to (struct cast_type from, int from_index, struct cast_type to, int to_index) { + /* FIXME: sign extension not implemented. */ + if (comp.cast_type_sizes[from_index] < comp.cast_type_sizes[to_index] + && comp.cast_type_kind[to_index] == kind_signed) + return NULL; + char *name = format_string ("cast_from_%s_to_%s", from.name, to.name); gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, from.type, "arg"); @@ -2973,22 +2994,27 @@ static void define_cast_functions (void) { struct cast_type cast_types[NUM_CAST_TYPES] - = { { comp.bool_type, "bool", sizeof (bool) }, - { comp.char_ptr_type, "char_ptr", sizeof (char *) }, - { comp.int_type, "int", sizeof (int) }, - { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *) }, - { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *) }, - { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag) }, - { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word) }, - { comp.long_long_type, "long_long", sizeof (long long) }, - { comp.long_type, "long", sizeof (long) }, - { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t) }, - { comp.uintptr_type, "uintptr", sizeof (uintptr_t) }, + = { { comp.bool_type, "bool", sizeof (bool), kind_unsigned }, + { comp.char_ptr_type, "char_ptr", sizeof (char *), kind_pointer }, + { comp.int_type, "int", sizeof (int), kind_signed }, + { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *), + kind_pointer }, + { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *), + kind_pointer }, + { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag), + kind_unsigned }, + { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word), + LISP_WORDS_ARE_POINTERS ? kind_pointer : kind_signed }, + { comp.long_long_type, "long_long", sizeof (long long), kind_signed }, + { comp.long_type, "long", sizeof (long), kind_signed }, + { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t), kind_signed }, + { comp.uintptr_type, "uintptr", sizeof (uintptr_t), kind_unsigned }, { comp.unsigned_long_long_type, "unsigned_long_long", - sizeof (unsigned long long) }, - { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long) }, - { comp.unsigned_type, "unsigned", sizeof (unsigned) }, - { comp.void_ptr_type, "void_ptr", sizeof (void*) } }; + sizeof (unsigned long long), kind_unsigned }, + { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long), + kind_unsigned }, + { comp.unsigned_type, "unsigned", sizeof (unsigned), kind_unsigned }, + { comp.void_ptr_type, "void_ptr", sizeof (void*), kind_pointer } }; /* Find the biggest size. It should be unsigned long long, but to be sure we find it programmatically. */ @@ -3006,16 +3032,18 @@ define_cast_functions (void) cast_types[i].name); comp.cast_type_names[i] = cast_types[i].name; comp.cast_type_sizes[i] = cast_types[i].bytes_size; + comp.cast_type_kind[i] = cast_types[i].kind; } gcc_jit_type *biggest_type = gcc_jit_context_get_int_type (comp.ctxt, biggest_size, false); comp.cast_types[NUM_CAST_TYPES] = biggest_type; - comp.cast_union_fields[NUM_CAST_TYPES] - = gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); + comp.cast_union_fields[NUM_CAST_TYPES] = + gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); comp.cast_type_names[NUM_CAST_TYPES] = "biggest_type"; comp.cast_type_sizes[NUM_CAST_TYPES] = biggest_size; + comp.cast_type_kind[NUM_CAST_TYPES] = kind_unsigned; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, From b619339b7a6c7952508bff72f07fc98c04e85f2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Mon, 1 Jun 2020 19:53:00 -0300 Subject: [PATCH 0908/1452] Fix DLL imports of gccjit version functions. * src/comp.c (init_gccjit_functions): Use LOAD_DLL_FN_OPT macro to load gcc_jit_version_major, gcc_jit_version_major and gcc_jit_version_patchlevel. * src/w32common.h (LOAD_DLL_FN_OPT): Add macro optionally load a function from a DLL. --- src/comp.c | 18 ++++++++++++------ src/w32common.h | 8 ++++++++ 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index d0574ac5ef3..8e7582b3e65 100644 --- a/src/comp.c +++ b/src/comp.c @@ -98,6 +98,9 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_struct_as_type #undef gcc_jit_struct_set_fields #undef gcc_jit_type_get_pointer +#undef gcc_jit_version_major +#undef gcc_jit_version_minor +#undef gcc_jit_version_patchlevel /* In alphabetical order */ DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int, @@ -231,9 +234,9 @@ DEF_DLL_FN (void, gcc_jit_context_set_logfile, DEF_DLL_FN (void, gcc_jit_struct_set_fields, (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, gcc_jit_field **fields)); -DEF_DLL_FN (int, gcc_jit_version_major); -DEF_DLL_FN (int, gcc_jit_version_minor); -DEF_DLL_FN (int, gcc_jit_version_patchlevel); +DEF_DLL_FN (int, gcc_jit_version_major, (void)); +DEF_DLL_FN (int, gcc_jit_version_minor, (void)); +DEF_DLL_FN (int, gcc_jit_version_patchlevel, (void)); static bool init_gccjit_functions (void) @@ -297,9 +300,9 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); - LOAD_DLL_FN (library, gcc_jit_version_major); - LOAD_DLL_FN (library, gcc_jit_version_minor); - LOAD_DLL_FN (library, gcc_jit_version_patchlevel); + LOAD_DLL_FN_OPT (library, gcc_jit_version_major); + LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); + LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); return true; } @@ -358,6 +361,9 @@ init_gccjit_functions (void) #define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type #define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields #define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer +#define gcc_jit_version_major fn_gcc_jit_version_major +#define gcc_jit_version_minor fn_gcc_jit_version_minor +#define gcc_jit_version_patchlevel fn_gcc_jit_version_patchlevel #endif diff --git a/src/w32common.h b/src/w32common.h index eb7faa1939a..bd01fd40401 100644 --- a/src/w32common.h +++ b/src/w32common.h @@ -81,6 +81,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 From e4e6bb7fddaa3a4e82748c106366fe9113dc16d9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 3 Jun 2020 22:06:26 +0100 Subject: [PATCH 0909/1452] * Introduce `comp-loop-insn-in-block' * lisp/emacs-lisp/comp.el (comp-loop-insn-in-block): New macro. (comp-call-optim-func, comp-dead-assignments-func) (comp-remove-type-hints-func): Use `comp-loop-insn-in-block'. --- lisp/emacs-lisp/comp.el | 62 ++++++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 11539761d1e..5116f887220 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -494,6 +494,16 @@ VERBOSITY is a number between 0 and 3." "Output filename for SRC file being native compiled." (concat (comp-output-base-filename src) ".eln")) +(defmacro comp-loop-insn-in-block (basic-block &rest body) + "Loop over all insns in BASIC-BLOCK executning BODY. +Inside BODY `insn' can be used to read or set the current +instruction." + (declare (debug (form body)) + (indent defun)) + (let ((sym-cell (gensym "cell-"))) + `(cl-symbol-macrolet ((insn (car ,sym-cell))) + (cl-loop for ,sym-cell on (comp-block-insns ,basic-block) + do ,@body)))) ;;; spill-lap pass specific code. @@ -2012,18 +2022,16 @@ Backward propagate array placement properties." with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) when self ;; FIXME add proper anonymous lambda support. - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) - (setcar insn-cell `(set ,lval ,new-form)))) - (`(callref funcall ,f . ,rest) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) - (setcar insn-cell new-form))))))) + do (comp-loop-insn-in-block b + (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest))) + (setf insn `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest))) + (setf insn new-form))))))) (defun comp-call-optim (_) "Try to optimize out funcall trampoline usage when possible." @@ -2077,17 +2085,15 @@ Return the list of m-var ids nuked." 3) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - for (op arg0 rest) = insn - when (and (comp-set-op-p op) - (memq (comp-mvar-id arg0) nuke-list)) - do (setcar insn-cell - (if (comp-limple-insn-call-p rest) - rest - `(comment ,(format "optimized out: %s" - insn)))))) + do (comp-loop-insn-in-block b + (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn + (when (and (comp-set-op-p op) + (memq (comp-mvar-id arg0) nuke-list)) + (setf insn + (if (comp-limple-insn-call-p arg1) + arg1 + `(comment ,(format "optimized out: %s" + insn)))))))) nuke-list))) (defun comp-dead-code (_) @@ -2154,12 +2160,10 @@ Return the list of m-var ids nuked." These are substituted with a normal 'set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) - (setcar insn-cell `(set ,l-val ,r-val))))))) + do (comp-loop-insn-in-block b + (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setf insn `(set ,l-val ,r-val))))))) (defun comp-remove-type-hints (_) "Dead code elimination." From 5684b3420d73715836c5111ef1f6ec9e4e257e8f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 4 Jun 2020 11:02:51 +0100 Subject: [PATCH 0910/1452] * Fix build for --enable-check-lisp-object-type=yes (bug#41703) * src/comp.c (emit_coerce): Add missing declaration. --- src/comp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/comp.c b/src/comp.c index 8e7582b3e65..45904a3bb1d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -984,6 +984,7 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_rvalue *lwordobj = emit_coerce (comp.lisp_word_type, obj); + static ptrdiff_t i; gcc_jit_lvalue *tmp_s = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, format_string ("lisp_obj_%td", i++)); From 385d9e69740e4f6293fe4c7b4206e3a4aca6ca21 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jun 2020 13:00:45 +0100 Subject: [PATCH 0911/1452] Some fixes for --without-nativecomp config * src/pdumper.c (dump_subr): Do not add RELOC_NATIVE_SUBR for VERY_LATE_RELOCS in --without-nativecomp. (dump_do_dump_relocation): Add a sanity check that no RELOC_NATIVE_SUBR exists in --without-nativecomp. * src/lread.c (Fload): As Fnative_elisp_load is not defined in --without-nativecomp so ifdef this block. --- src/lread.c | 6 ++++++ src/pdumper.c | 8 +++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index 026f3b6d98f..192c7ba773a 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1507,6 +1507,7 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { +#ifdef HAVE_NATIVE_COMP specbind (Qcurrent_load_list, Qnil); if (!NILP (Vpurify_flag)) { @@ -1517,6 +1518,11 @@ Return t if the file exists and loads successfully. */) 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 { diff --git a/src/pdumper.c b/src/pdumper.c index ffe59fbb306..92ac96a8faa 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2967,7 +2967,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && !NILP (subr->native_comp_u[0])) + 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], @@ -5331,6 +5333,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } 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 From e38678b268c2a3f77d1fa32a55706fb9e077405c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Mon, 25 May 2020 18:05:23 -0300 Subject: [PATCH 0912/1452] Reduce the number of files probed when finding a lisp file. * src/lread.c (get-load-suffixes): Do not add any suffix to files that need to be loaded by the dynamic linker. (effective_load_path): Remove function. (load): Don't add any suffix if file ends in a suffix already. (effective_load_path): Remove function. (openp_add_middle_dir_to_suffixes): Add helper function to create pairs of middle directories and suffixes. (openp_max_middledir_and_suffix_len): Add helper function to count the number of bytes needed to store the middle directory and suffix. (openp_fill_filename_buffer): Add helper function to copy middle directory, basename and suffix to the filename buffer. --- src/lread.c | 207 +++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 156 insertions(+), 51 deletions(-) diff --git a/src/lread.c b/src/lread.c index 192c7ba773a..a3e8d07c563 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1056,33 +1056,29 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) { Lisp_Object exts = Vload_file_rep_suffixes; Lisp_Object suffix = XCAR (suffixes); - FOR_EACH_TAIL (exts) - lst = Fcons (concat2 (suffix, XCAR (exts)), lst); + bool native_code_suffix = + NATIVE_COMP_FLAG + && strcmp (NATIVE_ELISP_SUFFIX, SSDATA (suffix)) == 0; + +#ifdef HAVE_MODULES + native_code_suffix = + native_code_suffix || strcmp (MODULES_SUFFIX, SSDATA (suffix)) == 0; +#ifdef MODULES_SECONDARY_SUFFIX + native_code_suffix = + native_code_suffix + || strcmp (MODULES_SECONDARY_SUFFIX, SSDATA (suffix)) == 0; +#endif +#endif + + if (native_code_suffix) + lst = Fcons (suffix, lst); + else + FOR_EACH_TAIL (exts) + lst = Fcons (concat2 (suffix, XCAR (exts)), lst); } return Fnreverse (lst); } -static Lisp_Object -effective_load_path (void) -{ -#ifndef HAVE_NATIVE_COMP - return Vload_path; -#else - Lisp_Object lp = Vload_path; - Lisp_Object new_lp = Qnil; - FOR_EACH_TAIL (lp) - { - Lisp_Object el = XCAR (lp); - new_lp = - Fcons (concat2 (Ffile_name_as_directory (el), - Vcomp_native_path_postfix), - new_lp); - new_lp = Fcons (el, new_lp); - } - return Fnreverse (new_lp); -#endif -} - /* Return true if STRING ends with SUFFIX. */ bool suffix_p (Lisp_Object string, const char *suffix) @@ -1218,7 +1214,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. */ @@ -1236,8 +1232,7 @@ Return t if the file exists and loads successfully. */) } fd = - openp (effective_load_path (), file, suffixes, &found, Qnil, - load_prefer_newer); + openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); } if (fd == -1) @@ -1612,6 +1607,114 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) return file; } +/* This function turns a list of suffixes into a list of middle dirs + and suffixes. If the suffix is not NATIVE_ELISP_SUFFIX then its + suffix is nil and it is added to the list as is. Instead, if it + suffix is NATIVE_ELISP_SUFFIX then two elements are added to the + list. The first one has middledir equal to nil and the second uses + comp-native-path-postfix as middledir. This is because we'd like + to search for dir/foo.eln before dir/middledir/foo.eln. + +For example, it turns this: + +(".eln" ".elc" ".elc.gz" ".el" ".el.gz") + + into this: + +((nil . ".eln") + (comp-native-path-postfix . ".eln") + (nil . ".elc") + (nil . ".elc.gz") + (nil . ".el") + (nil . ".el.gz")) +*/ +static Lisp_Object +openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) +{ + Lisp_Object tail = suffixes; + Lisp_Object extended_suf = Qnil; + FOR_EACH_TAIL_SAFE (tail) + { +#ifdef HAVE_NATIVE_COMP + CHECK_STRING_CAR (tail); + char * suf = SSDATA (XCAR (tail)); + if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) + { + CHECK_STRING (Vcomp_native_path_postfix); + /* Here we add them in the opposite order so that nreverse + corrects it. */ + extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); + extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, XCAR (tail)), + extended_suf); + } + else +#endif + extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); + } + + suffixes = Fnreverse (extended_suf); + return suffixes; +} + +/* This function takes a list of middledirs and suffixes and returns + the maximum buffer space that this part of the filename will + need. */ +static ptrdiff_t +openp_max_middledir_and_suffix_len (Lisp_Object middledir_and_suffixes) +{ + ptrdiff_t max_extra_len = 0; + Lisp_Object tail = middledir_and_suffixes; + FOR_EACH_TAIL_SAFE (tail) + { + Lisp_Object middledir_and_suffix = XCAR (tail); + Lisp_Object middledir = XCAR (middledir_and_suffix); + Lisp_Object suffix = XCDR (middledir_and_suffix); + ptrdiff_t len = SBYTES (suffix); + if (!NILP (middledir)) + len += 2 + SBYTES (middledir); /* Add two slashes. */ + max_extra_len = max (max_extra_len, len); + } + return max_extra_len; +} + +/* This function completes the FN buffer with the middledir, + basenameme, and suffix. It takes the directory length in DIRNAME, + but it requires that it has been copied already to the start of + the buffer. + + After this function the FN buffer will be (depending on middledir) + dirname/middledir/basename.suffix + or + dirname/basename.suffix +*/ +static ptrdiff_t +openp_fill_filename_buffer (char *fn, ptrdiff_t dirnamelen, + Lisp_Object basenamewext, + Lisp_Object middledir_and_suffix) +{ + Lisp_Object middledir = XCAR (middledir_and_suffix); + Lisp_Object suffix = XCDR (middledir_and_suffix); + ptrdiff_t basenamewext_len = SBYTES (basenamewext); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + ptrdiff_t lmiddledir = 0; + if (!NILP (middledir)) + { + /* Add 1 for the slash. */ + lmiddledir = SBYTES (middledir) + 1; + memcpy (fn + dirnamelen, SDATA (middledir), + lmiddledir - 1); + fn[dirnamelen + (lmiddledir - 1)] = '/'; + } + + memcpy (fn + dirnamelen + lmiddledir, SDATA (basenamewext), + basenamewext_len); + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + dirnamelen + lmiddledir + basenamewext_len, + SDATA (suffix), lsuffix + 1); + fnlen = dirnamelen + lmiddledir + basenamewext_len + lsuffix; + return fnlen; +} + /* 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). @@ -1649,7 +1752,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, ptrdiff_t want_length; Lisp_Object filename; Lisp_Object string, tail, encoded_fn, save_string; - ptrdiff_t max_suffix_len = 0; + Lisp_Object middledir_and_suffixes; + ptrdiff_t max_extra_len = 0; int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; @@ -1660,13 +1764,9 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, CHECK_STRING (str); - tail = suffixes; - FOR_EACH_TAIL_SAFE (tail) - { - CHECK_STRING_CAR (tail); - max_suffix_len = max (max_suffix_len, - SBYTES (XCAR (tail))); - } + middledir_and_suffixes = openp_add_middle_dir_to_suffixes (suffixes); + + max_extra_len = openp_max_middledir_and_suffix_len (middledir_and_suffixes); string = filename = encoded_fn = save_string = Qnil; @@ -1683,7 +1783,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, executable. */ FOR_EACH_TAIL_SAFE (path) { - ptrdiff_t baselen, prefixlen; + ptrdiff_t dirnamelen, prefixlen; if (EQ (path, just_use_str)) filename = str; @@ -1700,35 +1800,40 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, continue; } + /* Calculate maximum length of any filename made from this path element/specified file name and any possible suffix. */ - want_length = max_suffix_len + SBYTES (filename); + want_length = max_extra_len + SBYTES (filename); if (fn_size <= want_length) { fn_size = 100 + want_length; fn = SAFE_ALLOCA (fn_size); } - /* Copy FILENAME's data to FN but remove starting /: if any. */ - prefixlen = ((SCHARS (filename) > 2 - && SREF (filename, 0) == '/' - && SREF (filename, 1) == ':') - ? 2 : 0); - baselen = SBYTES (filename) - prefixlen; - memcpy (fn, SDATA (filename) + prefixlen, baselen); + Lisp_Object dirnamewslash = Ffile_name_directory (filename); + Lisp_Object basenamewext = Ffile_name_nondirectory (filename); - /* Loop over suffixes. */ - AUTO_LIST1 (empty_string_only, empty_unibyte_string); - tail = NILP (suffixes) ? empty_string_only : suffixes; + /* Copy FILENAME's data to FN but remove starting /: if any. */ + prefixlen = ((SCHARS (dirnamewslash) > 2 + && SREF (dirnamewslash, 0) == '/' + && SREF (dirnamewslash, 1) == ':') + ? 2 : 0); + dirnamelen = SBYTES (dirnamewslash) - prefixlen; + memcpy (fn, SDATA (dirnamewslash) + prefixlen, dirnamelen); + + /* Loop over middledir_and_suffixes. */ + AUTO_LIST1 (empty_string_only, Fcons (Qnil, empty_unibyte_string)); + tail = NILP (middledir_and_suffixes) ? empty_string_only + : middledir_and_suffixes; FOR_EACH_TAIL_SAFE (tail) { - Lisp_Object suffix = XCAR (tail); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + Lisp_Object middledir_and_suffix = XCAR (tail); + Lisp_Object suffix = XCDR (middledir_and_suffix); Lisp_Object handler; - /* Make complete filename by appending SUFFIX. */ - memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); - fnlen = baselen + lsuffix; + ptrdiff_t fnlen = openp_fill_filename_buffer (fn, dirnamelen, + basenamewext, + middledir_and_suffix); /* Check that the file exists and is not a directory. */ /* We used to only check for handlers on non-absolute file names: From e8ab017b6d45aea2514a49f974e649ad1f7297ad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jun 2020 13:30:59 +0200 Subject: [PATCH 0913/1452] Change 'direct-call' 'direct-callref' LIMPLE ops sematinc Is cleaner to have the function c-name as first argument of 'direct-call' 'direct-callref'. This is preparatory to anonymous lambdas optimization. * lisp/emacs-lisp/comp.el (comp-propagate-insn): Use c-name when gathering the comp-func definition for direct calls. (comp-call-optim-form-call): Add put c-name as first argument of direct-call direct-callref when optimizing. * src/comp.c (emit_call): Update logic for having c-name as first arg of direct calls. (emit_call_ref): Rename 'subr_sym' into 'func'. --- lisp/emacs-lisp/comp.el | 25 +++++++++++++------------ src/comp.c | 38 ++++++++++++++++---------------------- 2 files changed, 29 insertions(+), 34 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5116f887220..e776b664812 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1888,14 +1888,15 @@ Here goes everything that can be done not iteratively (read once). (pcase insn (`(set ,lval ,rval) (pcase rval - (`(,(or 'call 'direct-call) ,f . ,args) - (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types)) - (comp-function-call-maybe-remove insn f args)) - (`(,(or 'callref 'direct-callref) ,f . ,args) + (`(,(or 'call 'callref) ,f . ,args) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) (comp-function-call-maybe-remove insn f args)) + (`(,(or 'direct-call 'direct-callref) ,f . ,args) + (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) + (setf (comp-mvar-type lval) + (alist-get f comp-known-ret-types)) + (comp-function-call-maybe-remove insn f args))) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) @@ -1985,9 +1986,9 @@ Backward propagate array placement properties." (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) - (callee-in-unit (gethash (gethash callee - (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-callee (gethash (gethash callee + (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)))) (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. @@ -1995,7 +1996,7 @@ Backward propagate array placement properties." (maxarg (cdr (subr-arity f))) (call-type (if (if subrp (not (numberp maxarg)) - (comp-nargs-p callee-in-unit)) + (comp-nargs-p comp-func-callee)) 'callref 'call)) (args (if (eq call-type 'callref) @@ -2005,14 +2006,14 @@ Backward propagate array placement properties." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and (>= comp-speed 3) - callee-in-unit) - (let* ((func-args (comp-func-args callee-in-unit)) + comp-func-callee) + (let* ((func-args (comp-func-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@args))) + `(,call-type ,(comp-func-c-name comp-func-callee) ,@args))) ((comp-type-hint-p callee) `(call ,callee ,@args))))))) diff --git a/src/comp.c b/src/comp.c index 45904a3bb1d..9171a6a524b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -860,34 +860,28 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, } /* Emit calls fetching from existing declarations. */ + static gcc_jit_rvalue * -emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, +emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue **args, bool direct) { - Lisp_Object func; - if (direct) - { - Lisp_Object c_name = - Fgethash (subr_sym, - CALL1I (comp-ctxt-sym-to-c-name-h, Vcomp_ctxt), - Qnil); - func = Fgethash (c_name, comp.exported_funcs_h, Qnil); - } - else - func = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); + Lisp_Object gcc_func = + Fgethash (func, + direct ? comp.exported_funcs_h : comp.imported_funcs_h, + Qnil); - if (NILP (func)) + if (NILP (gcc_func)) xsignal2 (Qnative_ice, build_string ("missing function declaration"), - subr_sym); + func); if (direct) { - emit_comment (format_string ("direct call to subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); + emit_comment (format_string ("direct call to: %s", + SSDATA (func))); return gcc_jit_context_new_call (comp.ctxt, NULL, - xmint_pointer (func), + xmint_pointer (gcc_func), nargs, args); } @@ -897,14 +891,14 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.func_relocs), NULL, - (gcc_jit_field *) xmint_pointer (func)); + (gcc_jit_field *) xmint_pointer (gcc_func)); if (!f_ptr) xsignal2 (Qnative_ice, build_string ("missing function relocation"), - subr_sym); + func); emit_comment (format_string ("calling subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); + SSDATA (SYMBOL_NAME (func)))); return gcc_jit_context_new_call_through_ptr (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (f_ptr), @@ -914,7 +908,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, } static gcc_jit_rvalue * -emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, +emit_call_ref (Lisp_Object func, ptrdiff_t nargs, gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = @@ -922,7 +916,7 @@ emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); + return emit_call (func, comp.lisp_obj_type, 2, args, direct); } /* Close current basic block emitting a conditional. */ From 6449a058b150edd2a5997d761a284ad6b9b5aa97 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jun 2020 14:20:47 +0200 Subject: [PATCH 0914/1452] * Clean-up unnecessary lisp_X context definition * src/comp.c (Fcomp__init_ctxt, comp_t): Remove lisp_X definition as is used only locally. --- src/comp.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 9171a6a524b..b2dbfe88b3b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -489,9 +489,6 @@ typedef struct { gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; gcc_jit_type *size_t_type; -#if LISP_WORDS_ARE_POINTERS - gcc_jit_type *lisp_X; -#endif gcc_jit_type *lisp_word_type; gcc_jit_type *lisp_word_tag_type; #ifdef LISP_OBJECT_IS_STRUCT @@ -3811,11 +3808,12 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (EMACS_UINT), false); #if LISP_WORDS_ARE_POINTERS - comp.lisp_X = - gcc_jit_struct_as_type (gcc_jit_context_new_opaque_struct (comp.ctxt, - NULL, - "Lisp_X")); - comp.lisp_word_type = gcc_jit_type_get_pointer (comp.lisp_X); + comp.lisp_word_type = + gcc_jit_type_get_pointer ( + gcc_jit_struct_as_type ( + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X"))); #else comp.lisp_word_type = comp.emacs_int_type; #endif From dcfcbb14f5037d2661280c4bb93e7db618819106 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jun 2020 14:49:01 +0200 Subject: [PATCH 0915/1452] * Allow for optimizing anonymous lambdas in call-optim * lisp/emacs-lisp/comp.el (comp-func-in-unit): New function. (comp-call-optim-form-call): Update logic for optimizing anonymous lambdas. --- lisp/emacs-lisp/comp.el | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e776b664812..f30409ae5cd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1976,19 +1976,31 @@ Backward propagate array placement properties." ;; the full compilation unit. ;; For this reason this is triggered only at comp-speed == 3. +(defun comp-func-in-unit (func) + "Given FUNC return the `comp-fun' definition in the current context. +FUNCTION can be a function-name or byte compiled function." + (if (symbolp func) + (gethash (gethash func + (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)) + (cl-assert (byte-code-function-p func)) + (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) + (defun comp-call-optim-form-call (callee args) "" (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) collect (make-comp-mvar :constant nil))))) - (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. + (when (and (or (symbolp callee) + (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) (not (memq callee comp-never-optimize-functions))) - (let* ((f (symbol-function callee)) + (let* ((f (if (symbolp callee) + (symbol-function callee) + (cl-assert (byte-code-function-p callee)) + callee)) (subrp (subrp f)) - (comp-func-callee (gethash (gethash callee - (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-callee (comp-func-in-unit callee))) (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. @@ -2005,8 +2017,12 @@ Backward propagate array placement properties." `(,call-type ,callee ,@args))) ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! - ((and (>= comp-speed 3) - comp-func-callee) + ((and comp-func-callee + (or (>= comp-speed 3) + (and (>= comp-speed 2) + ;; Anonymous lambdas can't be redefined so are + ;; always safe to optimize. + (byte-code-function-p callee)))) (let* ((func-args (comp-func-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) From 489a79de96c7f90271e57b86b8162ef7ba500fed Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Jun 2020 16:53:34 +0200 Subject: [PATCH 0916/1452] * Mitigate possible speed 3 miss-optimization Do not perform trampoline optimization at speed 3 on function if their name is not unique inside the compilation unit. Note that the function can still be redefined in any other way therefore this is a mitigation. * lisp/emacs-lisp/comp.el (comp-func-unique-in-cu-p): New predicate. (comp-call-optim-form-call): Perform trampoline optimization for named functions only if they are unique within the current compilation unit. --- lisp/emacs-lisp/comp.el | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f30409ae5cd..b8ab48a9965 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -399,6 +399,18 @@ structure.") "Type hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) +(defun comp-func-unique-in-cu-p (func) + "Return t if FUNC is know to be unique in the current compilation unit." + (if (symbolp func) + (cl-loop with h = (make-hash-table :test #'eq) + for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + for name = (comp-func-name f) + when (gethash name h) + return nil + do (puthash name t h) + finally return t) + t)) + (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. Assume allocaiton class 'd-default as default." @@ -2018,7 +2030,8 @@ FUNCTION can be a function-name or byte compiled function." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and comp-func-callee - (or (>= comp-speed 3) + (or (and (>= comp-speed 3) + (comp-func-unique-in-cu-p callee)) (and (>= comp-speed 2) ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. From a58fef9f63fd4383c4eae9dfe8ae663b4ed710d1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jun 2020 00:34:21 +0200 Subject: [PATCH 0917/1452] * Optimize optimizable variables * lisp/emacs-lisp/comp.el (comp-symbol-values-optimizable): New defconst. (comp-function-call-maybe-remove): New logic to to remove unnecessary `symbol-value' calls. --- lisp/emacs-lisp/comp.el | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b8ab48a9965..4926c5d683f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -184,6 +184,10 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (comp-hint-cons . cons)) "Alist used for type propagation.") +(defconst comp-symbol-values-optimizable '(most-positive-fixnum + most-negative-fixnum) + "Symbol values we can resolve in the compile-time.") + (defconst comp-type-hints '(comp-hint-fixnum comp-hint-cons) "List of fake functions used to give compiler hints.") @@ -1883,17 +1887,28 @@ Here goes everything that can be done not iteratively (read once). (defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." - (when (comp-function-optimizable f args) - (ignore-errors - ;; No point to complain here because we should do basic block - ;; pruning in order to be sure that this is not dead-code. This - ;; is now left to gcc, to be implemented only if we want a - ;; reliable diagnostic here. - (let ((value (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-setimm'. - (comp-add-const-to-relocs value) - (setf (car insn) 'setimm - (cddr insn) `(,value)))))) + (cl-flet ((rewrite-insn-as-setimm (insn value) + ;; See `comp-emit-setimm'. + (comp-add-const-to-relocs value) + (setf (car insn) 'setimm + (cddr insn) `(,value)))) + (cond + ((eq f 'symbol-value) + (when-let* ((arg0 (car args)) + (const (comp-mvar-const-vld arg0)) + (ok-to-optim (member (comp-mvar-constant arg0) + comp-symbol-values-optimizable))) + (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant + (car args)))))) + ((comp-function-optimizable f args) + (ignore-errors + ;; No point to complain here because we should do basic block + ;; pruning in order to be sure that this is not dead-code. This + ;; is now left to gcc, to be implemented only if we want a + ;; reliable diagnostic here. + (rewrite-insn-as-setimm insn + (apply f + (mapcar #'comp-mvar-constant args)))))))) (defun comp-propagate-insn (insn) "Propagate within INSN." From 47a6fbd38278b40737d498a41a35259458633136 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jun 2020 11:46:08 +0200 Subject: [PATCH 0918/1452] * Improve propagate pass As function folding can generate 'setimm' insns handle them in the `comp-propagate-insn'. * lisp/emacs-lisp/comp.el (comp-propagate-insn): Handle 'setimm' insn. --- lisp/emacs-lisp/comp.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4926c5d683f..ecd411591a3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1926,6 +1926,10 @@ Here goes everything that can be done not iteratively (read once). (comp-function-call-maybe-remove insn f args))) (_ (comp-mvar-propagate lval rval)))) + (`(setimm ,lval ,v) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) v + (comp-mvar-type lval) (comp-strict-type-of v))) (`(phi ,lval . ,rest) ;; Forward const prop here. (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) From 88ccee4083f9059603c8bf9b989848c41902d8b0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jun 2020 13:58:27 +0200 Subject: [PATCH 0919/1452] * Fix comp-call-optim-form-call for null `callee' * lisp/emacs-lisp/comp.el (comp-call-optim-form-call): Guard agains null `calle'. --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ecd411591a3..520ec8cd44d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2023,7 +2023,8 @@ FUNCTION can be a function-name or byte compiled function." ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) collect (make-comp-mvar :constant nil))))) - (when (and (or (symbolp callee) + (when (and callee + (or (symbolp callee) (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) (not (memq callee comp-never-optimize-functions))) (let* ((f (if (symbolp callee) From fbf4882a8babd6cab83e78048d5173fef6501393 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Jun 2020 14:42:12 +0200 Subject: [PATCH 0920/1452] * Rename comp-function-optimizable -> comp-function-optimizable-p * lisp/emacs-lisp/comp.el (comp-function-optimizable): Rename into 'comp-function-optimizable-p'. (comp-function-call-maybe-remove): Use the new name. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 520ec8cd44d..a6bf723f54c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1870,7 +1870,7 @@ Here goes everything that can be done not iteratively (read once). (comp-mvar-type lval) (comp-mvar-type rval))) ;; Here should fall most of (defun byte-optimize-* equivalents. -(defsubst comp-function-optimizable (f args) +(defsubst comp-function-optimizable-p (f args) "Given function F called with ARGS return non nil when optimizable." (when (cl-every #'comp-mvar-const-vld args) (or (get f 'pure) @@ -1900,7 +1900,7 @@ Here goes everything that can be done not iteratively (read once). comp-symbol-values-optimizable))) (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant (car args)))))) - ((comp-function-optimizable f args) + ((comp-function-optimizable-p f args) (ignore-errors ;; No point to complain here because we should do basic block ;; pruning in order to be sure that this is not dead-code. This From dfa52572bdc1024342fa1a227ff627386e097a12 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jun 2020 00:06:33 +0200 Subject: [PATCH 0921/1452] * src/pdumper.c (dump_do_dump_relocation): Fix 'lambda_gc_guard' fill value. Given 'lambda_gc_guard' is in use for sanity checking fill it with t as value. --- src/pdumper.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/pdumper.c b/src/pdumper.c index 92ac96a8faa..8cb9284c014 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5367,7 +5367,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); eassert (EQ (*fixup, Qlambda_fixup)); *fixup = tem; - Fputhash (tem, Qnil, comp_u->lambda_gc_guard); + Fputhash (tem, Qt, comp_u->lambda_gc_guard); } break; } From 3d3737b90ab4dcded11ec716f92b9fa8a5c3fbeb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jun 2020 18:34:46 +0200 Subject: [PATCH 0922/1452] * Move final log after containers has been finalized * lisp/emacs-lisp/comp.el (comp-final): Remove function log. (comp-compile-ctxt-to-file): Add function log. --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a6bf723f54c..2cde99e7280 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2305,6 +2305,9 @@ Update all insn accordingly." Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) (comp-finalize-relocs) + (maphash (lambda (_ f) + (comp-log-func f 1)) + (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. (ignore-error 'file-already-exists @@ -2315,9 +2318,6 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." (let (compile-result) - (maphash (lambda (_ f) - (comp-log-func f 1)) - (comp-ctxt-funcs-h comp-ctxt)) (comp--init-ctxt) (unwind-protect (setf compile-result From 4784bcc96b32f2fc796c7067d2a6c8ddf00f4242 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jun 2020 17:21:03 +0200 Subject: [PATCH 0923/1452] * Fix load logic for the reloading CU case (bug#41754) * src/comp.c (load_comp_unit): When swapping the compilation unit abandoning the new one for the original do not forget to set its loaded_once field to true because is in use by `comp--register-lambda'. (Fcomp__register_lambda): Add sanity a check to spot early if we are trying to load the same lambda twice. --- src/comp.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/comp.c b/src/comp.c index b2dbfe88b3b..960badb6467 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4439,6 +4439,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, { comp_u_lisp_obj = *saved_cu; comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj); + comp_u->loaded_once = true; } else *saved_cu = comp_u_lisp_obj; @@ -4603,6 +4604,7 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, Fputhash (tem, Qt, cu->lambda_gc_guard); /* This is for fixing up the value in d_reloc while resurrecting from dump. See 'dump_do_dump_relocation'. */ + eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); /* The key is not really important as long is the same as symbol_name so use c_name. */ From f2864e3354fd60174b1d8df05a301673a81cd3ea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jun 2020 22:13:29 +0100 Subject: [PATCH 0924/1452] Rename lambda_gc_guard -> lambda_gc_guard_h * src/comp.h (struct Lisp_Native_Comp_Unit): Rename lambda_gc_guard -> lambda_gc_guard_h * src/pdumper.c (dump_do_dump_relocation): Likewise. * src/comp.c (check_comp_unit_relocs, Fcomp__register_lambda) (Fnative_elisp_load): Likewise. --- src/comp.c | 6 +++--- src/comp.h | 6 +++--- src/pdumper.c | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 960badb6467..521cadcb10c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4400,7 +4400,7 @@ check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) return false; else if (SUBR_NATIVE_COMPILEDP (x)) { - if (NILP (Fgethash (x, comp_u->lambda_gc_guard, Qnil))) + if (NILP (Fgethash (x, comp_u->lambda_gc_guard_h, Qnil))) return false; } else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i))) @@ -4601,7 +4601,7 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, /* We must protect it against GC because the function is not reachable through symbols. */ - Fputhash (tem, Qt, cu->lambda_gc_guard); + Fputhash (tem, Qt, cu->lambda_gc_guard_h); /* This is for fixing up the value in d_reloc while resurrecting from dump. See 'dump_do_dump_relocation'. */ eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); @@ -4669,7 +4669,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, comp_u->cfile = xlispstrdup (file); #endif comp_u->data_vec = Qnil; - comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); load_comp_unit (comp_u, false, !NILP (late_load)); diff --git a/src/comp.h b/src/comp.h index 1f64a6df550..d46cdc735ff 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,9 +37,9 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; - /* Guard anonymous lambdas against Garbage Collection and make them - dumpable. */ - Lisp_Object lambda_gc_guard; + /* 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 documentaiton. */ diff --git a/src/pdumper.c b/src/pdumper.c index 8cb9284c014..3089adb35d8 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5299,7 +5299,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, 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 = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); @@ -5367,7 +5367,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); eassert (EQ (*fixup, Qlambda_fixup)); *fixup = tem; - Fputhash (tem, Qt, comp_u->lambda_gc_guard); + Fputhash (tem, Qt, comp_u->lambda_gc_guard_h); } break; } From 5e8cdca71a661a6d95355ac5fdaa1e2fa32ed0df Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 8 Jun 2020 22:31:19 +0100 Subject: [PATCH 0925/1452] * src/comp.h (struct Lisp_Native_Comp_Unit): Fix missing GCALIGNED_STRUCT. --- src/comp.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.h b/src/comp.h index d46cdc735ff..507379bf5e6 100644 --- a/src/comp.h +++ b/src/comp.h @@ -61,7 +61,7 @@ struct Lisp_Native_Comp_Unit string may have been sweeped. */ char *cfile; #endif -}; +} GCALIGNED_STRUCT; #ifdef HAVE_NATIVE_COMP From 4d1cfd0997c05de4abc5d2f96c17b1c5a02982d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Mon, 8 Jun 2020 20:47:06 -0300 Subject: [PATCH 0926/1452] * Fix usage of cl-destructuring-bind in package--delete-directory. * lisp/emacs-lisp/package.el (package--delete-directory): Fix usage of cl-destructuring-bind. --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 904fc9e1094..0171fd56ffd 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2215,7 +2215,7 @@ to `package-user-dir'." (condition-case err (delete-directory dir t) (file-error - (cl-destructuring-bind (reason1 reason2 filename) err + (cl-destructuring-bind (_ reason1 reason2 filename) err (if (and (string= "Removing old name" reason1) (string= "Permission denied" reason2) (string-prefix-p (expand-file-name package-user-dir) From 10933f235fa2f1d7a3936da173cdd6e807bff57f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= Date: Mon, 8 Jun 2020 22:01:25 -0300 Subject: [PATCH 0927/1452] Copy suffixes passed to 'openp' to avoid GC crashes. Fixes bug#41755 In openp_add_middle_dir_to_suffixes we build a heap-based list from the passed suffixes. It is crucial that we don't create a heap-based cons that points to a stack-based list. * src/lread.c (openp_add_middle_dir_to_suffixes): Copy suffixes when building a list of middle-dirs and suffixes. --- src/lread.c | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/lread.c b/src/lread.c index a3e8d07c563..0530848c2b7 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1635,21 +1635,27 @@ openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) Lisp_Object extended_suf = Qnil; FOR_EACH_TAIL_SAFE (tail) { -#ifdef HAVE_NATIVE_COMP + /* suffixes may be a stack-based cons pointing to stack-based + strings. We must copy the suffix if we are putting it into + a heap-based cons to avoid a dangling reference. This would + lead to crashes during the GC. */ CHECK_STRING_CAR (tail); char * suf = SSDATA (XCAR (tail)); + Lisp_Object copied_suffix = build_string (suf); +#ifdef HAVE_NATIVE_COMP if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) { CHECK_STRING (Vcomp_native_path_postfix); /* Here we add them in the opposite order so that nreverse corrects it. */ - extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); - extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, XCAR (tail)), + extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); + extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, + copied_suffix), extended_suf); } else #endif - extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); + extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); } suffixes = Fnreverse (extended_suf); From dd939d7484adad7735e66b1759283d00df708e70 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Jun 2020 22:41:19 +0200 Subject: [PATCH 0928/1452] * Remove unused 'helper_save_window_excursion' * src/comp.c (helper_unwind_protect): Remove definition and declaration. --- src/comp.c | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 521cadcb10c..af61d76d46d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -591,7 +591,7 @@ typedef struct { /* Helper functions called by the run-time. */ -Lisp_Object helper_save_window_excursion (Lisp_Object v1); + void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); @@ -4014,17 +4014,6 @@ DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, /* for laziness. Change this if a performance impact is measured. */ /******************************************************************************/ -Lisp_Object -helper_save_window_excursion (Lisp_Object v1) -{ - ptrdiff_t count1 = SPECPDL_INDEX (); - record_unwind_protect (restore_window_configuration, - Fcurrent_window_configuration (Qnil)); - v1 = Fprogn (v1); - unbind_to (count1, v1); - return v1; -} - void helper_unwind_protect (Lisp_Object handler) { From 506febd5e72b0cd48acdf8887fb95701004b6e43 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Jun 2020 22:22:00 +0200 Subject: [PATCH 0929/1452] Remove `Vcomp_sym_subr_c_name_h' Given there's no more unique relation symbol-name -> c-name remove `Vcomp_sym_subr_c_name_h' and store the c_name directly in struct Lisp_Subr. The old approach would have failed dumping two functions with the same symbol-name. * src/lisp.h (struct Lisp_Subr): Add 'native_c_name' field. * src/pdumper.c (dump_subr): Update hash + dump 'native_c_name'. (dump_cold_native_subr): dump 'native_c_name'. (dump_do_dump_relocation): Update logic for reviving using 'native_c_name'. * src/comp.c (make_subr): Update for 'native_c_name' field. (Fcomp__register_lambda, Fcomp__register_subr): Clean-up code for 'Vcomp_sym_subr_c_name_h' removal. (syms_of_comp): Remove 'Vcomp_sym_subr_c_name_h'. --- src/comp.c | 9 +-------- src/lisp.h | 1 + src/pdumper.c | 27 +++++++++++++++++++-------- 3 files changed, 21 insertions(+), 16 deletions(-) diff --git a/src/comp.c b/src/comp.c index af61d76d46d..0f7c04129b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4567,6 +4567,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.native_intspec = intspec; x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; + x->s.native_c_name[0] = xstrdup (SSDATA (c_name)); Lisp_Object tem; XSETSUBR (tem, &x->s); @@ -4595,9 +4596,6 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, from dump. See 'dump_do_dump_relocation'. */ eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); - /* The key is not really important as long is the same as - symbol_name so use c_name. */ - Fputhash (Fintern (c_name, Qnil), c_name, Vcomp_sym_subr_c_name_h); /* Do the real relocation fixup. */ cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem; @@ -4618,7 +4616,6 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); - Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); return tem; } @@ -4820,10 +4817,6 @@ syms_of_comp (void) to be necessarily exposed to lisp but can easy debug for now. */ DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); - DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, - doc: /* Hash table symbol-function -> function-c-name. For - internal use during dump reload */); - Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table, QCtest, Qeq); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, doc: /* String signing the ABI exposed to .eln files. */); Vcomp_abi_hash = Qnil; diff --git a/src/lisp.h b/src/lisp.h index d39300e5598..55055fe284a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2095,6 +2095,7 @@ struct Lisp_Subr }; EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; + const char *native_c_name[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { diff --git a/src/pdumper.c b/src/pdumper.c index 3089adb35d8..e6c877cbbe2 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,7 @@ 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_99B6674034) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_92BED44D81) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2964,7 +2964,11 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) } DUMP_FIELD_COPY (&out, subr, doc); if (NATIVE_COMP_FLAG) - dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); + { + 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_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG @@ -3493,6 +3497,15 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) ALLOW_IMPLICIT_CONVERSION; dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); DISALLOW_IMPLICIT_CONVERSION; + + 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]; + ALLOW_IMPLICIT_CONVERSION; + dump_write (ctx, c_name, 1 + strlen (c_name)); + DISALLOW_IMPLICIT_CONVERSION; } static void @@ -5342,20 +5355,18 @@ dump_do_dump_relocation (const uintptr_t dump_base, a 'top_level_run' mechanism, we revive them one-by-one here. */ struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); - Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); - Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); - if (NILP (c_name)) - error ("missing label name"); - void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); + 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 in compilation unit"); subr->function.a0 = func; Lisp_Object lambda_data_idx = - Fgethash (c_name, comp_u->lambda_c_name_idx_h, Qnil); + Fgethash (build_string (c_name), comp_u->lambda_c_name_idx_h, Qnil); if (!NILP (lambda_data_idx)) { /* This is an anonymous lambda. From 904550d8c8e1583d0444bcb28b5d1130af6bafc3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Jun 2020 20:23:00 +0200 Subject: [PATCH 0930/1452] Fix recursive load for non cons hashed 'data_ephemeral_vec' content Removing `Vcomp_sym_subr_c_name_h' all c_name functions are GC markable only through 'data_ephemeral_vec'. A recursive load must not overide its content otherwise a previously activated load will have the original content collected before it's used. * src/comp.h (struct Lisp_Native_Comp_Unit): Add 'load_ongoing' field. * src/comp.c (unset_cu_load_ongoing): New function. (load_comp_unit): Update logic to detect and handle recursive loads. --- src/comp.c | 39 ++++++++++++++++++++++++++++++++------- src/comp.h | 2 +- 2 files changed, 33 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0f7c04129b3..18a2a1ff912 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4398,6 +4398,12 @@ check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) return true; } +static void +unset_cu_load_ongoing (Lisp_Object comp_u) +{ + XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false; +} + void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load) @@ -4433,6 +4439,14 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, else *saved_cu = comp_u_lisp_obj; + /* Once we are sure to have the right compilation unit we want to + identify is we have at least another load active on it. */ + bool recursive_load = comp_u->load_ongoing; + comp_u->load_ongoing = true; + ptrdiff_t count = SPECPDL_INDEX (); + if (!recursive_load) + record_unwind_protect (unset_cu_load_ongoing, comp_u_lisp_obj); + freloc_check_fill (); Lisp_Object (*top_level_run)(Lisp_Object) @@ -4508,14 +4522,21 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, are necessary exclusively during the first load. Once these are collected we don't have to maintain them in the heap forever. */ + Lisp_Object volatile data_ephemeral_vec; + /* In case another load of the same CU is active on the stack + all ephemeral data is hold by that frame. Re-writing + 'data_ephemeral_vec' would be not only a waste of cycles but + more importanly would lead to crashed if the contained data + is not cons hashed. */ + if (!recursive_load) + { + Lisp_Object volatile data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); - Lisp_Object volatile data_ephemeral_vec = - load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); - - EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_eph_relocs[i] = AREF (data_ephemeral_vec, i); - + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); + } /* Executing this will perform all the expected environment modifications. */ top_level_run (comp_u_lisp_obj); @@ -4525,6 +4546,10 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, eassert (check_comp_unit_relocs (comp_u)); } + if (!recursive_load) + /* Clean-up the load ongoing flag in case. */ + unbind_to (count, Qnil); + return; } diff --git a/src/comp.h b/src/comp.h index 507379bf5e6..687e426b1ef 100644 --- a/src/comp.h +++ b/src/comp.h @@ -52,7 +52,7 @@ struct Lisp_Native_Comp_Unit /* STUFFS WE DO NOT DUMP!! */ Lisp_Object *data_imp_relocs; bool loaded_once; - + bool load_ongoing; dynlib_handle_ptr handle; #ifdef WINDOWSNT /* We need to store a copy of the original file name in memory that From ab78ed83b977084885265a1842e4e474e0938d9f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Jun 2020 23:24:00 +0200 Subject: [PATCH 0931/1452] * Fix memory leak when native compiled function is collected * src/alloc.c (cleanup_vector): Handle native compiled functions. --- src/alloc.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/alloc.c b/src/alloc.c index 9a9dbb52e7b..750ffbd2dd8 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3156,6 +3156,17 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); dispose_comp_unit (cu, true); } + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) + { + struct Lisp_Subr *subr = + PSEUDOVEC_STRUCT (vector, Lisp_Subr); + if (subr->native_comp_u[0]) + { + xfree (subr->symbol_name); + xfree (subr->native_c_name[0]); + } + } } /* Reclaim space used by unmarked vectors. */ From 88a116d3778982265bdccdd7196a8d76a45736f1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jun 2020 08:04:09 +0200 Subject: [PATCH 0932/1452] * src/alloc.c (cleanup_vector): Fix --enable-check-lisp-object-type build. --- src/alloc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/alloc.c b/src/alloc.c index 750ffbd2dd8..514810b83fa 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3161,7 +3161,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Subr *subr = PSEUDOVEC_STRUCT (vector, Lisp_Subr); - if (subr->native_comp_u[0]) + if (!NILP (subr->native_comp_u[0])) { xfree (subr->symbol_name); xfree (subr->native_c_name[0]); From 7f8dbf70a5b0a61345b458537b1a7b4febf468fc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jun 2020 14:39:49 +0200 Subject: [PATCH 0933/1452] Fix const qualifier warnings * src/lisp.h (struct Lisp_Subr): Remove const qualifier from 'native_c_name'. * src/alloc.c (cleanup_vector): Cast to discard const qualifier. --- src/alloc.c | 4 +++- src/lisp.h | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 514810b83fa..42a53276bc8 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3163,7 +3163,9 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Subr); if (!NILP (subr->native_comp_u[0])) { - xfree (subr->symbol_name); + /* FIXME Alternative and non invasive solution to this + cast? */ + xfree ((char *)subr->symbol_name); xfree (subr->native_c_name[0]); } } diff --git a/src/lisp.h b/src/lisp.h index 55055fe284a..bef2e8079e1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2095,7 +2095,7 @@ struct Lisp_Subr }; EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; - const char *native_c_name[NATIVE_COMP_FLAG]; + char *native_c_name[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { From 34ed9d24984360dcc26fc36561f2de6a0917c58e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Jun 2020 22:53:31 +0200 Subject: [PATCH 0934/1452] * Introduce latches Define a new kind of basic block 'latch' to close over loops. Its purpose is for now to emit calls to `comp-maybe-gc-or-quit' but in future will be usefull for the loop optimizer to exploit unboxes. * lisp/emacs-lisp/comp.el (comp-block): New base class. (comp-block-lap): New class for LAP derived basic blocks. (comp-latch): New class. (comp-bb-maybe-add, comp-make-curr-block, comp-emit-handler) (comp-emit-switch, comp-emit-switch, comp-limplify-top-level) (comp-addr-to-bb-name, comp-limplify-block) (comp-limplify-function): Update logic for new bb objects arrangment. (comp-latch-make-fill): New function. (comp-emit-uncond-jump, comp-emit-cond-jump): Update to emit latches. (comp-new-block-sym): Add a postfix paramenter. --- lisp/emacs-lisp/comp.el | 112 +++++++++++++++++++++++++++------------- 1 file changed, 76 insertions(+), 36 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cde99e7280..5027d1da088 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -279,16 +279,9 @@ To be used when ncall-conv is nil.")) :documentation "t if rest argument is present.")) (cl-defstruct (comp-block (:copier nil) - (:constructor make--comp-block - (addr sp name))) ; Positional - "A basic block." + (:constructor nil)) + "A base class for basic blocks." (name nil :type symbol) - ;; These two slots are used during limplification. - (sp nil :type number - :documentation "When non nil indicates the sp value while entering -into it.") - (addr nil :type number - :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") (closed nil :type boolean @@ -309,6 +302,22 @@ into it.") :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) +(cl-defstruct (comp-block-lap (:copier nil) + (:include comp-block) + (:constructor make--comp-block-lap + (addr sp name))) ; Positional + "A basic block created from lap." + ;; These two slots are used during limplification. + (sp nil :type number + :documentation "When non nil indicates the sp value while entering +into it.") + (addr nil :type number + :documentation "Start block LAP address.")) + +(cl-defstruct (comp-latch (:copier nil) + (:include comp-block)) + "A basic block for a latch loop.") + (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." (src nil :type comp-block) @@ -751,20 +760,22 @@ Restore the original value afterwards." (defun comp-bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." - (let ((bb (or (cl-loop ; See if the block was already liplified. + (let ((bb (or (cl-loop ; See if the block was already limplified. for bb being the hash-value in (comp-func-blocks comp-func) - when (equal (comp-block-addr bb) lap-addr) + when (and (comp-block-lap-p bb) + (equal (comp-block-lap-addr bb) lap-addr)) return bb) (cl-find-if (lambda (bb) ; Look within the pendings blocks. - (= (comp-block-addr bb) lap-addr)) + (and (comp-block-lap-p bb) + (= (comp-block-lap-addr bb) lap-addr))) (comp-limplify-pending-blocks comp-pass))))) (if bb (progn - (unless (or (null sp) (= sp (comp-block-sp bb))) + (unless (or (null sp) (= sp (comp-block-lap-sp bb))) (signal 'native-ice (list "incoherent stack pointers" - sp (comp-block-sp bb)))) + sp (comp-block-lap-sp bb)))) bb) - (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) + (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) (defsubst comp-call (func &rest args) @@ -832,21 +843,44 @@ If DST-N is specified use it otherwise assume it to be the current slot." ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block addr entry-sp block-name))) + (let ((bb (make--comp-block-lap addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-pc comp-pass) addr - (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (comp-limplify-sp comp-pass) (when (comp-block-lap-p bb) + (comp-block-lap-sp bb))) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) +(defun comp-latch-make-fill (target) + "Create a latch pointing to TARGET and fill it. +Return the created latch" + (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) + (curr-bb (comp-limplify-curr-block comp-pass))) + ;; See `comp-make-curr-block'. + (setf (comp-limplify-curr-block comp-pass) latch) + (when (< comp-speed 3) + ;; At speed 3 the programmer is responsible to manually + ;; place `comp-maybe-gc-or-quit'. + (comp-emit '(call comp-maybe-gc-or-quit))) + ;; See `comp-emit-uncond-jump'. + (comp-emit `(jump ,(comp-block-name target))) + (comp-mark-curr-bb-closed) + (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) curr-bb) + latch)) + (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth (cl-assert (= (1- stack-depth) (comp-sp)))) - (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) - (comp-sp)))) - (comp-emit `(jump ,(comp-block-name target))) + (let* ((target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr + (comp-sp))) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) + (comp-emit `(jump ,eff-target-name)) (comp-mark-curr-bb-closed)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -859,13 +893,16 @@ Return value is the fall through block name." (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)))) ; Fall through block. (target-sp (+ target-offset (comp-sp))) - (target (comp-block-name (comp-bb-maybe-add (comp-label-to-addr label-num) - target-sp)))) + (target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr target-sp)) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))) + (list 'cond-jump a b eff-target-name bb) + (list 'cond-jump a b bb eff-target-name))) (comp-mark-curr-bb-closed) bb))) @@ -878,7 +915,7 @@ Return value is the fall through block name." (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) (1+ (comp-sp)))) - (pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym)))) + (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) (comp-emit (list 'push-handler handler-type (comp-slot+1) @@ -904,9 +941,11 @@ Return value is the fall through block name." (comp-slot) (comp-slot+1)))))) -(defun comp-new-block-sym () - "Return a unique symbol naming the next new basic block." - (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) +(defun comp-new-block-sym (&optional postfix) + "Return a unique symbol postfixing POSTFIX naming the next new basic block." + (intern (format (if postfix "bb_%s_%s" "bb_%s") + (funcall (comp-func-block-cnt-gen comp-func)) + postfix))) (defun comp-fill-label-h () "Fill label-to-addr hash table for the current function." @@ -948,9 +987,9 @@ Return value is the fall through block name." for ff-bb = (if last (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)) - (make--comp-block nil - (comp-sp) - (comp-new-block-sym))) + (make--comp-block-lap nil + (comp-sp) + (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) @@ -1375,7 +1414,7 @@ into the C code forwarding the compilation unit." :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify - :curr-block (make--comp-block -1 0 'top-level) + :curr-block (make--comp-block-lap -1 0 'top-level) :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (if for-late-load @@ -1396,7 +1435,7 @@ into the C code forwarding the compilation unit." "Search for a block starting at ADDR into pending or limplified blocks." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) - (equal (comp-block-addr bb) addr))) + (equal (comp-block-lap-addr bb) addr))) (if-let ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) @@ -1407,8 +1446,8 @@ into the C code forwarding the compilation unit." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb - (comp-limplify-sp comp-pass) (comp-block-sp bb) - (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) + (comp-limplify-pc comp-pass) (comp-block-lap-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop for inst-cell on (nthcdr (comp-limplify-pc comp-pass) @@ -1459,7 +1498,8 @@ into the C code forwarding the compilation unit." ;; Sanity check against block duplication. (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) - for addr = (comp-block-addr bb) + for addr = (when (comp-block-lap-p bb) + (comp-block-lap-addr bb)) when addr do (cl-assert (null (gethash addr addr-h))) (puthash addr t addr-h)) From 5a55a845a7c426e82e8a6a6d02bc4a39992871e3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 13 Jun 2020 11:12:15 +0200 Subject: [PATCH 0935/1452] * Implement 'maybe_gc_or_quit' to allow correct GC in compiled Lisp. Implement the backend side of 'maybe_gc_or_quit' so that every time a call to it is emitted we render it accordingly. This allow GC to kicks in during long loops in Lisp code. * src/comp.c (comp_t): Add 'maybe_gc_or_quit' field. (helper_link_table): Add 'maybe_gc', 'maybe_quit'. (emit_maybe_gc_or_quit): New function. (declare_runtime_imported_funcs): Import 'maybe_gc', 'maybe_quit' functions. (define_maybe_gc_or_quit): New function. (Fcomp__init_ctxt): Register emitter. (Fcomp__compile_ctxt_to_file): Call 'define_maybe_gc_or_quit'. (syms_of_comp): Define Qcomp_maybe_gc_or_quit. --- src/comp.c | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 108 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 18a2a1ff912..24d69b2b1ef 100644 --- a/src/comp.c +++ b/src/comp.c @@ -554,6 +554,7 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; + gcc_jit_function *maybe_gc_or_quit; Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ @@ -610,7 +611,9 @@ void *helper_link_table[] = record_unwind_current_buffer, set_internal, helper_unwind_protect, - specbind }; + specbind, + maybe_gc, + maybe_quit }; static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) @@ -2316,6 +2319,13 @@ emit_integerp (Lisp_Object insn) &res); } +static gcc_jit_rvalue * +emit_maybe_gc_or_quit (Lisp_Object insn) +{ + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.maybe_gc_or_quit, 0, + NULL); +} + /* This is in charge of serializing an object and export a function to retrieve it at load time. */ static void @@ -2575,6 +2585,10 @@ declare_runtime_imported_funcs (void) args[0] = args[1] = comp.lisp_obj_type; ADD_IMPORTED (specbind, comp.void_type, 2, args); + ADD_IMPORTED (maybe_gc, comp.void_type, 0, NULL); + + ADD_IMPORTED (maybe_quit, comp.void_type, 0, NULL); + #undef ADD_IMPORTED return Freverse (field_list); @@ -3512,6 +3526,96 @@ define_CHECK_IMPURE (void) gcc_jit_block_end_with_void_return (err_block, NULL); } +static void +define_maybe_gc_or_quit (void) +{ + + /* + void + maybe_gc_or_quit (void) + { + static unsigned quitcounter; + inc: + quitcounter++; + if (quitcounter >> 14) goto maybe_do_it else goto pass; + maybe_do_it: + quitcounter = 0; + maybe_gc (); + maybe_quit (); + return; + pass: + return; + } + */ + + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_lvalue *quitcounter = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + comp.unsigned_type, + "quitcounter"); + + comp.func = comp.maybe_gc_or_quit = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.void_type, + "maybe_gc_quit", + 0, NULL, 0); + DECL_BLOCK (increment_block, comp.maybe_gc_or_quit); + DECL_BLOCK (maybe_do_it_block, comp.maybe_gc_or_quit); + DECL_BLOCK (pass_block, comp.maybe_gc_or_quit); + + comp.block = increment_block; + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + quitcounter, + emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.unsigned_type, + gcc_jit_lvalue_as_rvalue (quitcounter), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 1))); + emit_cond_jump ( + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_type, + gcc_jit_lvalue_as_rvalue (quitcounter), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 9)), + /* 9 translates into checking for GC or quit every 512 calls to + 'maybe_gc_quit'. This is the smallest value I could find with + no performance impact running elisp-banechmarks. Byte + intepreter uses 256 (see 'exec_byte_code'). */ + maybe_do_it_block, + pass_block); + + comp.block = maybe_do_it_block; + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + quitcounter, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 0)); + gcc_jit_block_add_eval (comp.block, NULL, + emit_call (intern_c_string ("maybe_gc"), + comp.void_type, 0, NULL, false)); + gcc_jit_block_add_eval (comp.block, NULL, + emit_call (intern_c_string ("maybe_quit"), + comp.void_type, 0, NULL, false)); + gcc_jit_block_end_with_void_return (comp.block, NULL); + + gcc_jit_block_end_with_void_return (pass_block, NULL); + + comp.block = bb_orig; +} + /* Define a function to convert boolean into t or nil */ static void @@ -3761,6 +3865,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, register_emitter (Qnegate, emit_negate); register_emitter (Qnumberp, emit_numperp); register_emitter (Qintegerp, emit_integerp); + register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); } comp.ctxt = gcc_jit_context_acquire (); @@ -3949,6 +4054,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_setcar_setcdr (); define_add1_sub1 (); define_negate (); + define_maybe_gc_or_quit (); struct Lisp_Hash_Table *func_h = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); @@ -4756,6 +4862,7 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); + DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); /* Allocation classes. */ DEFSYM (Qd_default, "d-default"); From c37b5446d1f8e567f97f5708008b14a80b6c6d65 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 1 Jun 2020 12:47:29 +0100 Subject: [PATCH 0936/1452] Add native compiler dynamic scope support Add an initial implementation to support dynamic scope. Arg parsing/binding it's done using the existing code in use for bytecode (no ad-hoc code is synthetized for that). * src/lisp.h (struct Lisp_Subr): Add lambda_list field. (SUBR_NATIVE_COMPILED_DYNP): New inliner. * src/alloc.c (mark_object): Update for Add lambda_list field. * src/eval.c (eval_sub, Ffuncall, funcall_lambda): Handle native compiled dynamic scope * src/comp.c (declare_lex_function): Rename from declare_function and rework. (declare_function): New function. (make_subr): Handle daynamic scope * src/pdumper.c (dump_subr): Update for lambda_list field. * lisp/emacs-lisp/comp.el (comp-func): Remove args slot. (comp-func-l, comp-func-d): New classes deriving from `comp-func'. (comp-spill-lap-function): Rework. (comp-prepare-args-for-top-level): New function. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Make use of `comp-prepare-args-for-top-level'. (comp-limplify-top-level): Use `comp-func-l'. (comp-limplify-function): Emit arg prologue only for dynamic scoped functions. (comp-call-optim-form-call): Use `comp-func-l'. (comp-call-optim, comp-tco): Do not optimize dynamic scoped code. --- lisp/emacs-lisp/comp.el | 146 +++++++++++++++++++++++----------------- src/alloc.c | 1 + src/comp.c | 63 +++++++++++------ src/eval.c | 24 +++++-- src/lisp.h | 13 ++++ src/pdumper.c | 5 +- 6 files changed, 162 insertions(+), 90 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5027d1da088..e7bd0690727 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -354,7 +354,6 @@ into it.") :documentation "SSA status either: 'nil', 'dirty' or 't'. Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") - (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -372,6 +371,16 @@ structure.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.")) +(cl-defstruct (comp-func-l (:include comp-func)) + "Lexical scoped function." + (args nil :type comp-args-base + :documentation "Argument specification of the function")) + +(cl-defstruct (comp-func-d (:include comp-func)) + "Dynamic scoped function." + (lambda-list nil :type list + :documentation "Original lambda-list.")) + (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) @@ -600,10 +609,10 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) - (func (make-comp-func :name function-name - :c-name c-name - :doc (documentation f) - :int-spec (interactive-form f)))) + (func (make-comp-func-l :name function-name + :c-name c-name + :doc (documentation f) + :int-spec (interactive-form f)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -615,7 +624,7 @@ Put PREFIX in front of it." (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) + (setf (comp-func-l-args func) (comp-decrypt-arg-list arg-list function-name) (comp-func-lap func) lap @@ -631,8 +640,7 @@ Put PREFIX in front of it." (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) - (let* ((byte-func (byte-to-native-lambda-byte-func obj)) - (lap (byte-to-native-lambda-lap obj)) + (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-func-def-p form) @@ -640,31 +648,32 @@ Put PREFIX in front of it." byte-func)) return form)) (name (when top-l-form - (byte-to-native-func-def-name top-l-form)))) - ;; Do not refuse to compile if a dynamic byte-compiled lambda - ;; leaks here (advice). - (when (or name (comp-lex-byte-func-p byte-func)) - (let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)))) - ;; Store the c-name to have it retrivable from - ;; `comp-ctxt-top-level-forms'. - (when top-l-form - (setf (byte-to-native-func-def-c-name top-l-form) c-name)) - (unless name - (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))))) + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (if (comp-lex-byte-func-p byte-func) + (make-comp-func-l + :args (comp-decrypt-arg-list (aref byte-func 0) + name)) + (make-comp-func-d :lambda-list (aref byte-func 0))))) + (setf (comp-func-name func) name + (comp-func-byte-func func) byte-func + (comp-func-doc func) (documentation byte-func) + (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-c-name func) c-name + (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size byte-func)) + + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." @@ -1321,6 +1330,17 @@ the annotation emission." (comp-log-func func 2) func) +(defun comp-prepare-args-for-top-level (function) + "Given FUNCTION return the two args arguments for comp--register-..." + (if (comp-func-l-p function) + (let ((args (comp-func-l-args function))) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many))) + (cons (func-arity (comp-func-byte-func function)) + (comp-func-d-lambda-list function)))) + (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") @@ -1329,16 +1349,14 @@ the annotation emission." (let* ((name (byte-to-native-func-def-name form)) (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f))) + (args (comp-prepare-args-for-top-level f))) (cl-assert (and name f)) (comp-emit (comp-call (if for-late-load 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant c-name) (make-comp-mvar :constant @@ -1364,7 +1382,7 @@ the annotation emission." (defun comp-emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." - (let ((args (comp-func-args func))) + (let ((args (comp-prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) (comp-add-const-to-relocs (comp-func-byte-func func))) (comp-emit @@ -1376,10 +1394,8 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1404,14 +1420,14 @@ into the C code forwarding the compilation unit." ;; reasons to be execute ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) - (func (make-comp-func :name (if for-late-load - 'late-top-level-run - 'top-level-run) - :c-name (if for-late-load - "late_top_level_run" - "top_level_run") - :args (make-comp-args :min 1 :max 1) - :frame-size 1)) + (func (make-comp-func-l :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") + :args (make-comp-args :min 1 :max 1) + :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -1475,20 +1491,22 @@ into the C code forwarding the compilation unit." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size))) - (args (comp-func-args func))) + :frame (comp-new-frame frame-size)))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (comp-emit-narg-prologue (comp-args-base-min args) - (comp-nargs-nonrest args) - (comp-nargs-rest args))) + ;; Dynamic functions have parameters bound by the trampoline. + (when (comp-func-l-p func) + (let ((args (comp-func-l-args func))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))))) (comp-emit '(jump bb_0)) ;; Body (comp-bb-maybe-add 0 (comp-sp)) @@ -2096,7 +2114,7 @@ FUNCTION can be a function-name or byte compiled function." ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. (byte-code-function-p callee)))) - (let* ((func-args (comp-func-args comp-func-callee)) + (let* ((func-args (comp-func-l-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) (args (if (eq call-type 'direct-callref) @@ -2128,7 +2146,8 @@ FUNCTION can be a function-name or byte compiled function." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-call-optim-func))) + (when (comp-func-l-p f) + (comp-call-optim-func)))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -2234,7 +2253,8 @@ Return the list of m-var ids nuked." (when (>= comp-speed 3) (maphash (lambda (_ f) (let ((comp-func f)) - (unless (comp-func-has-non-local comp-func) + (when (and (comp-func-l-p f) + (not (comp-func-has-non-local comp-func))) (comp-tco-func) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) diff --git a/src/alloc.c b/src/alloc.c index 42a53276bc8..a31b4a045e2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6723,6 +6723,7 @@ mark_object (Lisp_Object arg) struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); + mark_object (subr->lambda_list[0]); } break; diff --git a/src/comp.c b/src/comp.c index 24d69b2b1ef..781ad3e08e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3655,14 +3655,12 @@ define_bool_to_lisp_obj (void) emit_lisp_obj_rval (Qnil)); } -/* Declare a function being compiled and add it to comp.exported_funcs_h. */ - -static void -declare_function (Lisp_Object func) +static gcc_jit_function * +declare_lex_function (Lisp_Object func) { - gcc_jit_function *gcc_func; + gcc_jit_function *res; char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); - Lisp_Object args = CALL1I (comp-func-args, func); + Lisp_Object args = CALL1I (comp-func-l-args, func); bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -3673,23 +3671,23 @@ declare_function (Lisp_Object func) for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; - gcc_jit_param **param = SAFE_ALLOCA (max_args * sizeof (*param)); + gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params)); for (int i = 0; i < max_args; ++i) - param[i] = gcc_jit_context_new_param (comp.ctxt, + params[i] = gcc_jit_context_new_param (comp.ctxt, NULL, type[i], format_string ("par_%d", i)); - gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_name, - max_args, - param, - 0); + res = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + params, + 0); } else { - gcc_jit_param *param[] = + gcc_jit_param *params[] = { gcc_jit_context_new_param (comp.ctxt, NULL, comp.ptrdiff_type, @@ -3698,19 +3696,34 @@ declare_function (Lisp_Object func) NULL, comp.lisp_obj_ptr_type, "args") }; - gcc_func = + res = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, 2, param, 0); + c_name, ARRAYELTS (params), params, 0); } + SAFE_FREE (); + return res; +} +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ + +static void +declare_function (Lisp_Object func) +{ + gcc_jit_function *gcc_func = + !NILP (CALL1I (comp-func-l-p, func)) + ? declare_lex_function (func) + : gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (CALL1I (comp-func-c-name, func)), + 0, NULL, 0); Fputhash (CALL1I (comp-func-c-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); - - SAFE_FREE (); } static void @@ -4685,12 +4698,20 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); - union Aligned_Lisp_Subr *x = (union Aligned_Lisp_Subr *) allocate_pseudovector ( VECSIZE (union Aligned_Lisp_Subr), 0, VECSIZE (union Aligned_Lisp_Subr), PVEC_SUBR); + if (CONSP (minarg)) + { + /* Dynamic code. */ + x->s.lambda_list[0] = maxarg; + maxarg = XCDR (minarg); + minarg = XCAR (minarg); + } + else + x->s.lambda_list[0] = Qnil; x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; diff --git a/src/eval.c b/src/eval.c index 9e86a185908..f2a85691b42 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2275,7 +2275,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); @@ -2378,7 +2378,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 { @@ -2854,9 +2856,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 { @@ -3066,6 +3070,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 (); @@ -3126,6 +3135,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); diff --git a/src/lisp.h b/src/lisp.h index bef2e8079e1..70ef7db8ee4 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,6 +2096,7 @@ struct Lisp_Subr 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]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4759,6 +4760,12 @@ 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 struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { @@ -4772,6 +4779,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return false; } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/pdumper.c b/src/pdumper.c index e6c877cbbe2..2bda3a85cd1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,7 @@ 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_92BED44D81) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_35CE99B716) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2968,8 +2968,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) 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_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG && ctx->flags.dump_object_contents From 47ab6c237e703cf4b5bbcd3c301e324e0deb1173 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 10 Dec 2019 12:55:34 +0100 Subject: [PATCH 0937/1452] Add some testing for dynamic scope * test/src/comp-test-funcs-dyn.el: New file. * test/src/comp-tests.el (comp-tests-dynamic-ffuncall): Add new tests. --- test/src/comp-test-funcs-dyn.el | 40 ++++++++++++++++++++++++++++ test/src/comp-tests.el | 46 ++++++++++++++++++++++++++++++--- 2 files changed, 82 insertions(+), 4 deletions(-) create mode 100644 test/src/comp-test-funcs-dyn.el diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el new file mode 100644 index 00000000000..0e342a39d3e --- /dev/null +++ b/test/src/comp-test-funcs-dyn.el @@ -0,0 +1,40 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; 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 . + +;;; Commentary: + +;;; Code: + +(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)) + +(provide 'comp-test-dyn-funcs) + +;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 3e40dba10b4..ee96d5656e7 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -34,8 +34,14 @@ (defconst comp-test-src (concat comp-test-directory "comp-test-funcs.el")) -(message "Compiling %s" comp-test-src) +(defconst comp-test-dyn-src + (concat comp-test-directory "comp-test-funcs-dyn.el")) + +(message "Compiling tests...") (load (native-compile comp-test-src)) +(load (native-compile comp-test-dyn-src)) + + (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. @@ -353,9 +359,9 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-40187-2-f) 'bar))) -;;;;;;;;;;;;;;;;;;;; -;; Tromey's tests ;; -;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests. ;; +;;;;;;;;;;;;;;;;;;;;; (ert-deftest comp-consp () (should-not (comp-test-consp 23)) @@ -520,4 +526,36 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." nil)) (should (eq comp-test-up-val 999))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tests for dynamic scope. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(ert-deftest comp-tests-dynamic-ffuncall () + "Test calling convention for dynamic binding." + + (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2) + '(1 2))) + + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2) + '(1 2 nil nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) + '(1 2 3 (4))))) + ;;; comp-tests.el ends here From 29b2a08c36554ec26f8f3c51da2a2a26b13bfe8f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Jun 2020 11:08:50 +0100 Subject: [PATCH 0938/1452] Execute top level forms in the right lex/dyn scope. * lisp/emacs-lisp/bytecomp.el (byte-to-native-top-level): Add 'lexical' slot. (byte-compile-output-file-form): Update for new slot. (byte-compile-file-form-defmumble): Capture scope. * lisp/emacs-lisp/comp.el (comp-emit-for-top-level): Specify execution scope. --- lisp/emacs-lisp/bytecomp.el | 7 ++++--- lisp/emacs-lisp/comp.el | 12 +++++++----- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9e39b8f78ac..c7d2344dbd2 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -585,7 +585,7 @@ Each element is (INDEX . VALUE)") name c-name byte-func) (cl-defstruct byte-to-native-top-level "All other top-level forms." - form) + form lexical) (defvar byte-native-compiling nil "Non nil while native compiling.") @@ -2248,7 +2248,7 @@ Call from the source buffer." ;; it here. (when byte-native-compiling ;; Spill output for the native compiler here - (push (make-byte-to-native-top-level :form form) + (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) @@ -2707,7 +2707,8 @@ not to take responsibility for the actual compilation of the code." ;; Spill output for the native compiler here. (push (if macro (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil)) + :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)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e7bd0690727..928fa516ed5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1373,11 +1373,13 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) for-late-load) (unless for-late-load - (let ((form (byte-to-native-top-level-form form))) - (comp-emit (comp-call 'eval - (let ((comp-curr-allocation-class 'd-impure)) - (make-comp-mvar :constant form)) - (make-comp-mvar :constant t)))))) + (comp-emit + (comp-call 'eval + (let ((comp-curr-allocation-class 'd-impure)) + (make-comp-mvar :constant + (byte-to-native-top-level-form form))) + (make-comp-mvar :constant + (byte-to-native-top-level-lexical form)))))) (defun comp-emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. From decced8337278e3e21e9926819edd7eab003587a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 15 Jun 2020 20:26:00 +0200 Subject: [PATCH 0939/1452] Allow per function speed declaration * src/comp.c (COMP_SPEED): Rename. (comp_t): Add 'func_speed' field. (emit_mvar_lval, compile_function): Update for per function speed. (Fcomp__compile_ctxt_to_file): COMP_SPEED renamed. * lisp/emacs-lisp/comp.el (comp-speed): Doc update. (comp-func): New 'speed' slot. (comp-spill-speed): New function. (comp-spill-lap-function, comp-intern-func-in-ctxt): Fill 'speed' slot. (comp-spill-lap-function): Gate -1 speed functions for native compilation and emit bytecode instead. (comp-spill-lap): Close over `byte-to-native-plist-environment'. (comp-latch-make-fill): Update for per function speed. (comp-limplify-top-level): Fill speed. (comp-propagate1, comp-call-optim-form-call, comp-call-optim) (comp-dead-code, comp-tco, comp-remove-type-hints): Update for per function speed. --- lisp/emacs-lisp/byte-run.el | 8 ++- lisp/emacs-lisp/bytecomp.el | 8 ++- lisp/emacs-lisp/comp.el | 129 ++++++++++++++++++++++-------------- src/comp.c | 10 +-- 4 files changed, 98 insertions(+), 57 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 88e21b73fed..4c1dce264a7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -143,6 +143,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)))) + ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list @@ -159,7 +164,8 @@ This may shift errors from run-time to compile-time.") 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 'indent #'byte-run--set-indent) + (list 'speed #'byte-run--set-speed)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c7d2344dbd2..7a56aa2df29 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -601,6 +601,8 @@ Each element is (INDEX . VALUE)") "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 @@ -1740,7 +1742,11 @@ extra args." ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) ) - ,@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)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 928fa516ed5..3372400a6d3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -49,10 +49,11 @@ the native compiled one." :group 'comp) (defcustom comp-speed 2 - "Compiler optimization level. From 0 to 3. -- 0 no optimizations are performed, compile time is favored. + "Compiler optimization level. From -1 to 3. +- -1 functions are kept in bytecode form and no native compilation is performed. +- 0 native compilation is performed with no optimizations. - 1 lite optimizations. -- 2 heavy optimizations. +- 2 max optimization level fully adherent to the language semantic. - 3 max optimization level, to be used only when necessary. Warning: the compiler is free to perform dangerous optimizations." :type 'number @@ -369,7 +370,9 @@ structure.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") (array-h (make-hash-table) :type hash-table - :documentation "array idx -> array length.")) + :documentation "array idx -> array length.") + (speed nil :type number + :documentation "Optimization level (see `comp-speed').")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexical scoped function." @@ -546,6 +549,12 @@ instruction." (and (byte-code-function-p f) (fixnump (aref f 0)))) +(defun comp-spill-speed (fuction-name) + "Return the speed for SYMBOL-FUNCTION." + (or (plist-get (cdr (assq fuction-name byte-to-native-plist-environment)) + 'speed) + comp-speed)) + (defun comp-c-func-name (name prefix) "Given NAME return a name suitable for the native code. Put PREFIX in front of it." @@ -612,7 +621,8 @@ Put PREFIX in front of it." (func (make-comp-func-l :name function-name :c-name c-name :doc (documentation f) - :int-spec (interactive-form f)))) + :int-spec (interactive-form f) + :speed (comp-spill-speed function-name)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -661,7 +671,8 @@ Put PREFIX in front of it." (comp-func-int-spec func) (interactive-form byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap - (comp-func-frame-size func) (comp-byte-frame-size byte-func)) + (comp-func-frame-size func) (comp-byte-frame-size byte-func) + (comp-func-speed func) (comp-spill-speed name)) ;; Store the c-name to have it retrivable from ;; `comp-ctxt-top-level-forms'. @@ -681,7 +692,21 @@ Put PREFIX in front of it." (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) - (reverse byte-to-native-top-level-forms)) + (cl-loop + for form in (reverse byte-to-native-top-level-forms) + collect + (if (and (byte-to-native-func-def-p form) + (eq -1 + (comp-spill-speed (byte-to-native-func-def-name form)))) + (let ((byte-code (byte-to-native-func-def-byte-func form))) + (remhash byte-code byte-to-native-lambdas-h) + (make-byte-to-native-top-level + :form `(defalias + ',(byte-to-native-func-def-name form) + ,byte-code + nil) + :lexical (comp-lex-byte-func-p byte-code))) + form))) (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) (defun comp-spill-lap (input) @@ -690,7 +715,8 @@ If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lambdas-h (make-hash-table :test #'eq)) - (byte-to-native-top-level-forms ())) + (byte-to-native-top-level-forms ()) + (byte-to-native-plist-environment ())) (comp-spill-lap-function input))) @@ -867,7 +893,7 @@ Return the created latch" (curr-bb (comp-limplify-curr-block comp-pass))) ;; See `comp-make-curr-block'. (setf (comp-limplify-curr-block comp-pass) latch) - (when (< comp-speed 3) + (when (< (comp-func-speed comp-func) 3) ;; At speed 3 the programmer is responsible to manually ;; place `comp-maybe-gc-or-quit'. (comp-emit '(call comp-maybe-gc-or-quit))) @@ -1429,7 +1455,8 @@ into the C code forwarding the compilation unit." "late_top_level_run" "top_level_run") :args (make-comp-args :min 1 :max 1) - :frame-size 1)) + :frame-size 1 + :speed comp-speed)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -2029,18 +2056,18 @@ Return t if something was changed." (defun comp-propagate1 (backward) (comp-ssa) - (when (>= comp-speed 2) - (maphash (lambda (_ f) - ;; FIXME remove the following condition when tested. - (unless (comp-func-has-non-local f) - (let ((comp-func f)) - (comp-propagate-prologue backward) - (cl-loop - for i from 1 - while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-log-func comp-func 3)))) - (comp-ctxt-funcs-h comp-ctxt)))) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + ;; FIXME remove the following condition when tested. + (not (comp-func-has-non-local f))) + (let ((comp-func f)) + (comp-propagate-prologue backward) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) (defun comp-propagate (_) "Forward propagate types and consts within the lattice." @@ -2110,9 +2137,9 @@ FUNCTION can be a function-name or byte compiled function." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and comp-func-callee - (or (and (>= comp-speed 3) + (or (and (>= (comp-func-speed comp-func) 3) (comp-func-unique-in-cu-p callee)) - (and (>= comp-speed 2) + (and (>= (comp-func-speed comp-func) 2) ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. (byte-code-function-p callee)))) @@ -2145,12 +2172,12 @@ FUNCTION can be a function-name or byte compiled function." (defun comp-call-optim (_) "Try to optimize out funcall trampoline usage when possible." - (when (>= comp-speed 2) - (maphash (lambda (_ f) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + (comp-func-l-p f)) (let ((comp-func f)) - (when (comp-func-l-p f) - (comp-call-optim-func)))) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-call-optim-func)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Dead code elimination pass specific code. @@ -2209,17 +2236,17 @@ Return the list of m-var ids nuked." (defun comp-dead-code (_) "Dead code elimination." - (when (>= comp-speed 2) - (maphash (lambda (_ f) - (let ((comp-func f)) - ;; FIXME remove the following condition when tested. - (unless (comp-func-has-non-local comp-func) - (cl-loop - for i from 1 - while (comp-dead-assignments-func) - finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3))))) - (comp-ctxt-funcs-h comp-ctxt)))) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + ;; FIXME remove the following condition when tested. + (not (comp-func-has-non-local f))) + (cl-loop + for comp-func = f + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Tail Call Optimization pass specific code. @@ -2252,14 +2279,14 @@ Return the list of m-var ids nuked." (defun comp-tco (_) "Simple peephole pass performing self TCO." - (when (>= comp-speed 3) - (maphash (lambda (_ f) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 3) + (comp-func-l-p f) + (not (comp-func-has-non-local f))) (let ((comp-func f)) - (when (and (comp-func-l-p f) - (not (comp-func-has-non-local comp-func))) - (comp-tco-func) - (comp-log-func comp-func 3)))) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-tco-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Type hint removal pass specific code. @@ -2279,12 +2306,12 @@ These are substituted with a normal 'set' op." (defun comp-remove-type-hints (_) "Dead code elimination." - (when (>= comp-speed 2) - (maphash (lambda (_ f) + (maphash (lambda (_ f) + (when (>= (comp-func-speed f) 2) (let ((comp-func f)) (comp-remove-type-hints-func) - (comp-log-func comp-func 3))) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Final pass specific code. diff --git a/src/comp.c b/src/comp.c index 781ad3e08e4..82a092ad356 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,7 +411,7 @@ load_gccjit_if_necessary (bool mandatory) #define TEXT_FDOC_SYM "text_data_fdoc" -#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) +#define COMP_SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) #define STR_VALUE(s) #s @@ -536,6 +536,7 @@ typedef struct { size_t cast_union_field_biggest_type; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ + EMACS_INT func_speed; /* From comp-func speed slot. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ @@ -734,7 +735,7 @@ emit_mvar_lval (Lisp_Object mvar) EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); EMACS_INT slot_n = XFIXNUM (mvar_slot); - if (comp.func_has_non_local || (SPEED < 2)) + if (comp.func_has_non_local || (comp.func_speed < 2)) return comp.arrays[arr_idx][slot_n]; else { @@ -3736,6 +3737,7 @@ compile_function (Lisp_Object func) comp.exported_funcs_h, Qnil)); comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); + comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); struct Lisp_Hash_Table *array_h = XHASH_TABLE (CALL1I (comp-func-array-h, func)); @@ -3775,7 +3777,7 @@ compile_function (Lisp_Object func) - Allow gcc to trigger other optimizations that are prevented by memory referencing. */ - if (SPEED >= 2) + if (comp.func_speed >= 2) { comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); for (ptrdiff_t i = 0; i < frame_size; ++i) @@ -4030,7 +4032,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - SPEED); + COMP_SPEED); comp.d_default_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); comp.d_impure_idx = From 34117dea7736012114e5c20fcf9f328e0658f8b3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 15 Jun 2020 21:27:00 +0200 Subject: [PATCH 0940/1452] Add a test for speed -1 * test/src/comp-tests.el (comp-test-speed--1): New test * test/src/comp-test-funcs.el (comp-test-speed--1-f): New function. --- test/src/comp-test-funcs.el | 4 ++++ test/src/comp-tests.el | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5e04be4459f..168819b17d6 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -286,6 +286,10 @@ (defun comp-test-40187-2-f () 'bar) +(defun comp-test-speed--1-f () + (declare (speed -1)) + 3) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ee96d5656e7..d6fff8233c0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -358,6 +358,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-40187-1-f) 'foo)) (should (eq (comp-test-40187-2-f) 'bar))) +(ert-deftest comp-test-speed--1 () + "Check that at speed -1 we do not native compile." + (should (= (comp-test-speed--1-f) 3)) + (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 51df0ab6f6dc8085be6140fa9b87e4a124ce5ad9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 17 Jun 2020 22:17:57 +0200 Subject: [PATCH 0941/1452] Do not native compile two functions to allow cc-mode hack * lisp/progmodes/cc-langs.el (c-populate-syntax-table): Declare with speed -1. * lisp/progmodes/cc-bytecomp.el (cc-bytecomp-compiling-or-loading): Declare with speed -1. --- lisp/progmodes/cc-bytecomp.el | 2 ++ lisp/progmodes/cc-langs.el | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 959261c9eb6..5eb8af25343 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -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) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index dcffc0d31b4..3ac4aad90b8 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -337,7 +337,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) From 1179a1c748f7c18b8b82f14608f8f86790814a25 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 17 Jun 2020 22:46:48 +0200 Subject: [PATCH 0942/1452] * Add a func-arity test for dynamic functions * test/src/comp-tests.el (comp-tests-dynamic-arity): New test. --- test/src/comp-tests.el | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d6fff8233c0..51586d2f9e8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -563,4 +563,15 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) '(1 2 3 (4))))) +(ert-deftest comp-tests-dynamic-arity () + "Test func-arity on dynamic scope functions." + (should (equal '(2 . 2) + (func-arity #'comp-tests-ffuncall-callee-dyn-f))) + (should (equal '(2 . 4) + (func-arity #'comp-tests-ffuncall-callee-opt-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-rest-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) + ;;; comp-tests.el ends here From cfb871add49096f38c5a8ff0882a7e111943ee52 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Jun 2020 23:04:55 +0200 Subject: [PATCH 0943/1452] * Handle correctly pure delaration specifier. * lisp/emacs-lisp/comp.el (comp-func): New slot 'pure'. (comp-spill-decl-spec): New function. (comp-spill-speed): Rework to use the later. (comp-spill-lap-function, comp-intern-func-in-ctxt): Spill pure decl value. (comp-function-optimizable-p): Check in the compiler env too if pure. --- lisp/emacs-lisp/comp.el | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3372400a6d3..e5674ccc95e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -372,7 +372,9 @@ structure.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.") (speed nil :type number - :documentation "Optimization level (see `comp-speed').")) + :documentation "Optimization level (see `comp-speed').") + (pure nil :type boolean + :documentation "t if declared pure nil otherwise.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexical scoped function." @@ -549,10 +551,14 @@ instruction." (and (byte-code-function-p f) (fixnump (aref f 0)))) -(defun comp-spill-speed (fuction-name) - "Return the speed for SYMBOL-FUNCTION." - (or (plist-get (cdr (assq fuction-name byte-to-native-plist-environment)) - 'speed) +(defun comp-spill-decl-spec (function-name spec) + "Return the declared specifier SPEC for FUNCTION-NAME." + (plist-get (cdr (assq function-name byte-to-native-plist-environment)) + spec)) + +(defun comp-spill-speed (function-name) + "Return the speed for FUNCTION-NAME." + (or (comp-spill-decl-spec function-name 'speed) comp-speed)) (defun comp-c-func-name (name prefix) @@ -622,7 +628,9 @@ Put PREFIX in front of it." :c-name c-name :doc (documentation f) :int-spec (interactive-form f) - :speed (comp-spill-speed function-name)))) + :speed (comp-spill-speed function-name) + :pure (comp-spill-decl-spec function-name + 'pure)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -672,7 +680,8 @@ Put PREFIX in front of it." (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) - (comp-func-speed func) (comp-spill-speed name)) + (comp-func-speed func) (comp-spill-speed name) + (comp-func-pure func) (comp-spill-decl-spec name 'pure)) ;; Store the c-name to have it retrivable from ;; `comp-ctxt-top-level-forms'. @@ -1960,7 +1969,12 @@ Here goes everything that can be done not iteratively (read once). (defsubst comp-function-optimizable-p (f args) "Given function F called with ARGS return non nil when optimizable." (when (cl-every #'comp-mvar-const-vld args) - (or (get f 'pure) + (or (when-let ((func (gethash (gethash f + (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-pure func)) + (get f 'pure) (memq (get f 'byte-optimizer) comp-propagate-classes) (let ((values (mapcar #'comp-mvar-constant args))) (pcase f From 89b6f56de011fa45934800a60bf631fc99ef2a4c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Jun 2020 23:14:06 +0200 Subject: [PATCH 0944/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Confine gcc optim level in [0, 3]. --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 82a092ad356..7547a40019d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4032,7 +4032,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - COMP_SPEED); + COMP_SPEED < 0 ? 0 + : (COMP_SPEED > 3 ? 3 : COMP_SPEED)); comp.d_default_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); comp.d_impure_idx = From 0a70ed9df274f7b262862ddd08a2fd61e2fea42b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Jun 2020 23:21:32 +0200 Subject: [PATCH 0945/1452] ;* src/comp.c (define_maybe_gc_or_quit): Fix a comment. --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 7547a40019d..29aa6352085 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3590,8 +3590,8 @@ define_maybe_gc_or_quit (void) 9)), /* 9 translates into checking for GC or quit every 512 calls to 'maybe_gc_quit'. This is the smallest value I could find with - no performance impact running elisp-banechmarks. Byte - intepreter uses 256 (see 'exec_byte_code'). */ + no performance impact running elisp-banechmarks and the same + used by the byte intepreter (see 'exec_byte_code'). */ maybe_do_it_block, pass_block); From f0e9fdd1f9a9989b457cbc382e0cf12c161a8e6c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Jun 2020 20:52:52 +0200 Subject: [PATCH 0946/1452] Two `load-history' eln related fixes. * src/lread.c (Fload): Fix `load-history' filling for elns non in root lisp-dir. * lisp/startup.el (command-line): Fix `load-history' fixup algorith for eln files. --- lisp/startup.el | 7 ++++++- src/lread.c | 3 ++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/startup.el b/lisp/startup.el index bff10003f84..e58f27e7ebc 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1061,7 +1061,12 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq lisp-dir + (file-truename + (if (string-match "\\.eln\\'" simple-file-name) + (expand-file-name + (concat (file-name-directory simple-file-name) "../")) + (file-name-directory simple-file-name)))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) diff --git a/src/lread.c b/src/lread.c index 0530848c2b7..f5a7d44a1e0 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1506,7 +1506,8 @@ Return t if the file exists and loads successfully. */) specbind (Qcurrent_load_list, Qnil); if (!NILP (Vpurify_flag)) { - Lisp_Object base = parent_directory (Ffile_name_directory (found)); + Lisp_Object base = concat2 (parent_directory (Vinvocation_directory), + build_string ("lisp/")); Lisp_Object offset = Flength (base); hist_file_name = Fsubstring (found, offset, Qnil); } From 801e19d0ba8e048a9faa5d5169ec4183e41b0148 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 23 Jun 2020 00:33:09 +0200 Subject: [PATCH 0947/1452] * lisp/gnus/gnus.el (gnus): Fix a check to handle native compilation. --- lisp/gnus/gnus.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index caeab7f55af..89d5d120549 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -4126,8 +4126,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 slave) From 24f68d6bfc83b5514d928853ffd86b97c53e1623 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 27 Jun 2020 20:59:22 +0100 Subject: [PATCH 0948/1452] src/comp.c (Fcomp__register_subr): Handle advice activation (bug#42038). --- src/comp.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 29aa6352085..6909aefda76 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4769,9 +4769,17 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); - set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); + { /* Handle automatic advice activation (bug#42038). + See `defalias'. */ + Lisp_Object hook = Fget (name, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, name, tem); + else + Ffset (name, tem); + } + return tem; } From 7f8512765a50858d51805762e88d291fc31b3490 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 28 Jun 2020 13:33:11 +0100 Subject: [PATCH 0949/1452] * Setup correctly the printer while dumping objs in native CU (bug#42088) * src/comp.c (emit_static_object): Bind a bunch of special variables to setup `prin1-to-string' as `byte-compile-output-file-form' does. This to preserve uninterned symbols. --- src/comp.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/comp.c b/src/comp.c index 6909aefda76..bb416ecb19a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2339,7 +2339,19 @@ emit_static_object (const char *name, Lisp_Object obj) strings cause of this funny bug that will affect all pre gcc10 era gccs: https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + ptrdiff_t count = SPECPDL_INDEX (); + /* Preserve uninterned symbols, this is specifically necessary for + CL macro expansion in dynamic scope code (bug#42088). See + `byte-compile-output-file-form'. */ + specbind (intern_c_string ("print-escape-newlines"), Qt); + specbind (intern_c_string ("print-length"), Qnil); + specbind (intern_c_string ("print-level"), Qnil); + specbind (intern_c_string ("print-quoted"), Qt); + specbind (intern_c_string ("print-gensym"), Qt); + specbind (intern_c_string ("print-circle"), Qt); Lisp_Object str = Fprin1_to_string (obj, Qnil); + unbind_to (count, Qnil); + ptrdiff_t len = SBYTES (str); const char *p = SSDATA (str); From 5b8b2982830028303d207d111095e35c90ae6805 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 28 Jun 2020 13:45:49 +0100 Subject: [PATCH 0950/1452] Add a test to verify CL macro expansion in dynamic scope * test/src/comp-tests.el (comp-tests-cl-macro-exp): New test. * test/src/comp-test-funcs-dyn.el: Require `cl-lib'. (comp-tests-cl-macro-exp-f): New function. --- test/src/comp-test-funcs-dyn.el | 7 +++++++ test/src/comp-tests.el | 4 ++++ 2 files changed, 11 insertions(+) diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 0e342a39d3e..50a72807be7 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -23,6 +23,8 @@ ;;; Code: +(require 'cl-lib) + (defun comp-tests-ffuncall-callee-dyn-f (a b) (list a b)) @@ -35,6 +37,11 @@ (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)) + (provide 'comp-test-dyn-funcs) ;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 51586d2f9e8..fe818960dd2 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -574,4 +574,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) +(ert-deftest comp-tests-cl-macro-exp () + "Verify CL macro expansion (bug#42088)." + (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) + ;;; comp-tests.el ends here From 6c7f615ae59b636efe5012f761a25acfd956480d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 28 Jun 2020 15:38:48 +0100 Subject: [PATCH 0951/1452] * src/comp.c (Fcomp__register_subr): Remove code duplication using Fdefalias. --- src/comp.c | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/comp.c b/src/comp.c index bb416ecb19a..3abcabc8933 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4780,17 +4780,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); - - LOADHIST_ATTACH (Fcons (Qdefun, name)); - - { /* Handle automatic advice activation (bug#42038). - See `defalias'. */ - Lisp_Object hook = Fget (name, Qdefalias_fset_function); - if (!NILP (hook)) - call2 (hook, name, tem); - else - Ffset (name, tem); - } + Fdefalias (name, tem, Qnil); return tem; } From 1dd2c8cd0770040b616803f4b6a4a81ff314ea6a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 28 Jun 2020 20:38:13 +0100 Subject: [PATCH 0952/1452] * Enable deferred compilation for dynamic scoped code * src/comp.c (maybe_defer_native_compilation): Trigger for dynamic code and add a comment. --- src/comp.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 3abcabc8933..28f10bed6d1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4411,6 +4411,14 @@ dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) loaded the compiler and its dependencies. */ static Lisp_Object delayed_sources; + +/* Queue an asyncronous compilation for the source file defining + FUNCTION_NAME and perform a late load. + + NOTE: ideally would be nice to move its call simply into Fload but + we need DEFINITION to guard against function redefinition while + async compilation happen. */ + void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) @@ -4443,7 +4451,6 @@ maybe_defer_native_compilation (Lisp_Object function_name, || noninteractive || !NILP (Vpurify_flag) || !COMPILEDP (definition) - || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) || !STRINGP (Vload_true_file_name) || !suffix_p (Vload_true_file_name, ".elc")) return; From 0ce4bf3ede9be928062abe47675345375e01d3c0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 28 Jun 2020 20:44:22 +0100 Subject: [PATCH 0953/1452] * Do not skip native compilation for leim subfolder during boostrap * lisp/emacs-lisp/comp.el (comp-bootstrap-black-list): Remove "^leim/". --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e5674ccc95e..cde9899d26c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -93,7 +93,7 @@ Skip if any is matching." :group 'comp) (defcustom comp-bootstrap-black-list - '("^leim/") + '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." :type 'list From d3ac3534b45f50769d866c25e795d4ca20572a18 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 29 Jun 2020 17:26:29 +0200 Subject: [PATCH 0954/1452] Revert "* src/comp.c (Fcomp__register_subr): Remove code duplication using Fdefalias." This reverts commit 6c7f615ae59b636efe5012f761a25acfd956480d. --- src/comp.c | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 28f10bed6d1..2464b58dad7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4787,7 +4787,17 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); - Fdefalias (name, tem, Qnil); + + LOADHIST_ATTACH (Fcons (Qdefun, name)); + + { /* Handle automatic advice activation (bug#42038). + See `defalias'. */ + Lisp_Object hook = Fget (name, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, name, tem); + else + Ffset (name, tem); + } return tem; } From 4681f330714b1ac1114f79d6bd2ac33150e1fcc4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 30 Jun 2020 19:10:19 +0200 Subject: [PATCH 0955/1452] Fix lambda-list relocation class Lambda-lists must stay in the same relocation class of the object referenced by code to respect uninterned symbols. * lisp/emacs-lisp/comp.el (comp-prepare-args-for-top-level): Break the original function in a generic specializing for dynamic/lexical functions. When allocating the lambda-list for dynamic functions do that in the default relocation class. (comp-emit-for-top-level): Make use of the new `comp-prepare-args-for-top-level'. (comp-emit-lambda-for-top-level): Likewise. --- lisp/emacs-lisp/comp.el | 37 +++++++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cde9899d26c..39b47f079e2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1365,16 +1365,25 @@ the annotation emission." (comp-log-func func 2) func) -(defun comp-prepare-args-for-top-level (function) - "Given FUNCTION return the two args arguments for comp--register-..." - (if (comp-func-l-p function) - (let ((args (comp-func-l-args function))) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many))) - (cons (func-arity (comp-func-byte-func function)) - (comp-func-d-lambda-list function)))) +(cl-defgeneric comp-prepare-args-for-top-level (function) + "Given FUNCTION return the two args arguments for comp--register-...") + +(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) + "Lexical scoped FUNCTION." + (let ((args (comp-func-l-args function))) + (cons (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many))))) + +(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) + "Dynamic scoped FUNCTION." + (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) + (let ((comp-curr-allocation-class 'd-default)) + ;; Lambda-lists must stay in the same relocation class of + ;; the object referenced by code to respect uninterned + ;; symbols. + (make-comp-mvar :constant (comp-func-d-lambda-list function))))) (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") @@ -1390,8 +1399,8 @@ the annotation emission." 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) - (make-comp-mvar :constant (car args)) - (make-comp-mvar :constant (cdr args)) + (car args) + (cdr args) (make-comp-mvar :constant c-name) (make-comp-mvar :constant @@ -1431,8 +1440,8 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (car args)) - (make-comp-mvar :constant (cdr args)) + (car args) + (cdr args) (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) From 0f964db32797c1525941046d565acdcfa33af42f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 30 Jun 2020 19:14:52 +0200 Subject: [PATCH 0956/1452] Add a test for lambda list containing uninterned symbols * test/src/comp-test-funcs-dyn.el (comp-tests-cl-uninterned-arg-parse-f): New function. * test/src/comp-tests.el (comp-tests-cl-uninterned-arg-parse-f): New test. --- test/src/comp-test-funcs-dyn.el | 3 +++ test/src/comp-tests.el | 5 +++++ 2 files changed, 8 insertions(+) diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 50a72807be7..5f12378bcf9 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -42,6 +42,9 @@ 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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fe818960dd2..66f7d8c1795 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -578,4 +578,9 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) +(ert-deftest comp-tests-cl-uninterned-arg-parse-f () + "Verify the parsing of a lambda list with uninterned symbols (bug#42120)." + (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) + '(1 2)))) + ;;; comp-tests.el ends here From b67e156041fb4bb3bc4a2cc60bca4408d092b59b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jul 2020 21:29:34 +0200 Subject: [PATCH 0957/1452] * Add to possibility to write per pass specific tests * lisp/emacs-lisp/comp.el (comp-post-pass-hooks): New special variable. (native-compile): Run what is registered in `comp-post-pass-hooks'. --- lisp/emacs-lisp/comp.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 39b47f079e2..205966f57c6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -172,6 +172,11 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-final) "Passes to be executed in order.") +(defvar comp-post-pass-hooks () + "Alist PASS FUNCTIONS. +Each function in FUNCTIONS is run after PASS. +Useful to hook into pass checkers.") + (defconst comp-known-ret-types '((cons . cons) (1+ . number) (1- . number) @@ -2617,7 +2622,9 @@ Return the compilation unit file name." (comp-log (format "(%s) Running pass %s:\n" function-or-file pass) 2) - (setf data (funcall pass data))) + (setf data (funcall pass data)) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data))) comp-passes) (native-compiler-error ;; Add source input. From 8f81859497b7dd0c537d24a27985a26ffc778a3a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jul 2020 21:32:09 +0200 Subject: [PATCH 0958/1452] Rework `comp-c-func-name' arguments * lisp/emacs-lisp/comp.el (comp-c-func-name): Add FIRST argument to ignore the compiler context and return the first name. * lisp/emacs-lisp/disass.el (disassemble-internal): Update the `comp-c-func-name' call. --- lisp/emacs-lisp/comp.el | 8 +++++--- lisp/emacs-lisp/disass.el | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 205966f57c6..a16cf1dcc88 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -566,9 +566,11 @@ instruction." (or (comp-spill-decl-spec function-name 'speed) comp-speed)) -(defun comp-c-func-name (name prefix) +(defun comp-c-func-name (name prefix &optional first) "Given NAME return a name suitable for the native code. -Put PREFIX in front of it." +Add PREFIX in front of it. If FIRST is not nil pick the first +available name ignoring compilation context and potential name +clashes." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: (let* ((orig-name (if (symbolp name) (symbol-name name) name)) @@ -583,7 +585,7 @@ Put PREFIX in front of it." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - (if comp-ctxt + (if (null first) ;; Prevent C namespace conflicts. (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 82c8de6e133..aa8b248f39e 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -96,7 +96,7 @@ redefine OBJECT if it is a symbol." (regexp-quote (concat "<" (comp-c-func-name - (subr-name obj) "F") + (subr-name obj) "F" t) ">:")))) (beginning-of-line) (delete-region (point-min) (point)) From 7e004d24a4abaa4b5aa9f0f1cd4bc70264396ad5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jul 2020 21:43:52 +0200 Subject: [PATCH 0959/1452] * Add a test to verify tail recursion elimination * test/src/comp-tests.el (comp-tests-tco): Compile a recursive functions at speed 3 and verify the tail recursion elimination. (comp-tests-tco-checker, comp-tests-mentioned-p) (comp-tests-mentioned-p-1): New support functions. --- test/src/comp-tests.el | 48 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 66f7d8c1795..fd1c513d13a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -583,4 +583,52 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) '(1 2)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Middle-end specific tests. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun comp-tests-mentioned-p-1 (x insn) + (cl-loop for y in insn + when (cond + ((consp y) (comp-tests-mentioned-p x y)) + ((and (comp-mvar-p y) (comp-mvar-const-vld y)) + (equal (comp-mvar-constant y) x)) + (t (equal x y))) + return t)) + +(defun comp-tests-mentioned-p (x insn) + "Check if X is actively mentioned in INSN." + (unless (eq (car-safe insn) + 'comment) + (comp-tests-mentioned-p-1 x insn))) + +(defun comp-tests-tco-checker (_) + "Check that inside `comp-tests-tco-f' we have no recursion." + (should-not + (cl-loop + named checker-loop + with func-name = (comp-c-func-name 'comp-tests-tco-f "F" t) + with f = (gethash func-name (comp-ctxt-funcs-h comp-ctxt)) + for bb being each hash-value of (comp-func-blocks f) + do (cl-loop + for insn in (comp-block-insns bb) + when (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p func-name insn)) + do (cl-return-from checker-loop 'mentioned))))) + +(ert-deftest comp-tests-tco () + "Check for tail recursion elimination." + (let ((comp-speed 3) + (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) + (comp-final comp-tests-tco-checker)))) + (eval '(defun comp-tests-tco-f (a b count) + (if (= count 0) + b + (comp-tests-tco-f (+ a b) a (- count 1)))) + t) + (load (native-compile #'comp-tests-tco-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (= (comp-tests-tco-f 1 0 10) 55)))) + ;;; comp-tests.el ends here From b0f683ec16ae55f2788e21e30db21044766fcad9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 2 Jul 2020 21:45:42 +0200 Subject: [PATCH 0960/1452] * Fix missing tail recursion elimination * lisp/emacs-lisp/comp.el (comp-tco-func): Fix tail recursion elimination given now functions in LIMPLE are expressed with the C name. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a16cf1dcc88..81612398c7b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2299,7 +2299,7 @@ Return the list of m-var ids nuked." (`((set ,l-val (direct-call ,func . ,args)) (comment ,_comment) (return ,ret-val)) - (when (and (eq func (comp-func-name comp-func)) + (when (and (string= func (comp-func-c-name comp-func)) (eq l-val ret-val)) (let ((tco-seq (comp-form-tco-call-seq args))) (setf (car insns-seq) (car tco-seq) From 2593bbee51f4d15d3a4fc1d4e2e3b215222f783a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 4 Jul 2020 15:53:15 +0100 Subject: [PATCH 0961/1452] * Relax constant folding rules * lisp/emacs-lisp/comp.el (comp-function-optimizable-p): No need to check for operands or result to be fixnums. --- lisp/emacs-lisp/comp.el | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 81612398c7b..da567fd9054 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1994,13 +1994,8 @@ Here goes everything that can be done not iteratively (read once). (memq (get f 'byte-optimizer) comp-propagate-classes) (let ((values (mapcar #'comp-mvar-constant args))) (pcase f - ;; Simple integer operation. - ;; Note: byte-opt uses `byte-opt--portable-numberp' - ;; instead of just`fixnump'. - ((or '+ '- '* '1+ '-1) (and (cl-every #'fixnump values) - (fixnump (apply f values)))) - ('/ (and (cl-every #'fixnump values) - (not (= (car (last values)) 0))))))))) + ((or '+ '- '* '1+ '-1) t) + ('/ (not (= (car (last values)) 0)))))))) (defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." From 0b81044e7e7500fcee3f984c1abeaa544118c5ee Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 10:21:21 +0100 Subject: [PATCH 0962/1452] * Clean-up some const folding logic and add `comp-function-pure-p' * lisp/emacs-lisp/comp.el (comp-function-pure-p): New predicate. (comp-function-call-maybe-remove): Update to use the `comp-function-pure-p'. --- lisp/emacs-lisp/comp.el | 35 +++++++++++------------------------ 1 file changed, 11 insertions(+), 24 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da567fd9054..ef9dc5ba1d6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -443,6 +443,15 @@ structure.") finally return t) t)) +(defsubst comp-function-pure-p (f) + "Return t if F is pure." + (or (get f 'pure) + (when-let ((func (gethash (gethash f + (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-pure func)))) + (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. Assume allocaiton class 'd-default as default." @@ -1899,17 +1908,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defvar comp-propagate-classes '(byte-optimize-associative-math - byte-optimize-binary-predicate - byte-optimize-concat - byte-optimize-equal - byte-optimize-identity - byte-optimize-member - byte-optimize-memq - byte-optimize-predicate) - "We optimize functions with 'byte-optimizer' property set to - one of these symbols. See byte-opt.el.") - (defsubst comp-strict-type-of (obj) "Given OBJ return its type understanding fixnums." ;; Should be certainly smarter but now we take advantages just from fixnums. @@ -1981,21 +1979,10 @@ Here goes everything that can be done not iteratively (read once). (comp-mvar-constant lval) (comp-mvar-constant rval) (comp-mvar-type lval) (comp-mvar-type rval))) -;; Here should fall most of (defun byte-optimize-* equivalents. (defsubst comp-function-optimizable-p (f args) "Given function F called with ARGS return non nil when optimizable." - (when (cl-every #'comp-mvar-const-vld args) - (or (when-let ((func (gethash (gethash f - (comp-ctxt-sym-to-c-name-h - comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) - (comp-func-pure func)) - (get f 'pure) - (memq (get f 'byte-optimizer) comp-propagate-classes) - (let ((values (mapcar #'comp-mvar-constant args))) - (pcase f - ((or '+ '- '* '1+ '-1) t) - ('/ (not (= (car (last values)) 0)))))))) + (and (cl-every #'comp-mvar-const-vld args) + (comp-function-pure-p f))) (defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." From b31b0ebefef3c9ea378342f624ce18a0eb6d30ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 10:23:46 +0100 Subject: [PATCH 0963/1452] * Rework some test logic for generality * test/src/comp-tests.el (comp-tests-make-insn-checker): New function splitting logic from `comp-tests-tco-checker' to have it more general. (comp-tests-tco-checker): Make use of `comp-tests-make-insn-checker'. --- test/src/comp-tests.el | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fd1c513d13a..aefb2f0601a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -603,19 +603,28 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." 'comment) (comp-tests-mentioned-p-1 x insn))) -(defun comp-tests-tco-checker (_) - "Check that inside `comp-tests-tco-f' we have no recursion." +(defun comp-tests-make-insn-checker (func-name checker) + "Apply CHECKER to each insn in FUNC-NAME. +CHECKER should always return nil to have a pass." (should-not (cl-loop named checker-loop - with func-name = (comp-c-func-name 'comp-tests-tco-f "F" t) - with f = (gethash func-name (comp-ctxt-funcs-h comp-ctxt)) + with func-c-name = (comp-c-func-name func-name "F" t) + with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt)) for bb being each hash-value of (comp-func-blocks f) do (cl-loop for insn in (comp-block-insns bb) - when (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) - (comp-tests-mentioned-p func-name insn)) - do (cl-return-from checker-loop 'mentioned))))) + when (funcall checker insn) + do (cl-return-from checker-loop 'mentioned))))) + +(defun comp-tests-tco-checker (_) + "Check that inside `comp-tests-tco-f' we have no recursion." + (comp-tests-make-insn-checker + 'comp-tests-tco-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) + insn))))) (ert-deftest comp-tests-tco () "Check for tail recursion elimination." From e6ab4e3dfe2bfc6e935b4cfa7e8f686e5d926235 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 11:11:11 +0100 Subject: [PATCH 0964/1452] * Add a test targeting forward propagation * test/src/comp-tests.el (comp-tests-fw-prop-checker-1): New function. (comp-tests-fw-prop): New test. --- test/src/comp-tests.el | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index aefb2f0601a..332facb4cf9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -640,4 +640,26 @@ CHECKER should always return nil to have a pass." (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) +(defun comp-tests-fw-prop-checker-1 (_) + "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded." + (comp-tests-make-insn-checker + 'comp-tests-fw-prop-1-f + (lambda (insn) + (or (comp-tests-mentioned-p 'concat insn) + (comp-tests-mentioned-p 'length insn))))) + +(ert-deftest comp-tests-fw-prop () + "Some tests for forward propagation." + (let ((comp-speed 2) + (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) + (eval '(defun comp-tests-fw-prop-1-f () + (let* ((a "xxx") + (b "yyy") + (c (concat a b))) ; <= has to optimize + (length c))) ; <= has to optimize + t) + (load (native-compile #'comp-tests-fw-prop-1-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (= (comp-tests-fw-prop-1-f) 6)))) + ;;; comp-tests.el ends here From 3db6ace804472ccde368e173df21484f19049317 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 18:32:32 +0100 Subject: [PATCH 0965/1452] * Define `comp-symbol-func-to-fun' * lisp/emacs-lisp/comp.el (comp-symbol-func-to-fun): New function. (comp-func-in-unit): Make use of the `comp-symbol-func-to-fun'. --- lisp/emacs-lisp/comp.el | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ef9dc5ba1d6..22575e415f1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -443,13 +443,16 @@ structure.") finally return t) t)) +(defsubst comp-symbol-func-to-fun (symbol-funcion) + "Given a function called SYMBOL-FUNCION return its `comp-func'." + (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt))) + (defsubst comp-function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (gethash (gethash f - (comp-ctxt-sym-to-c-name-h - comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) + (when-let ((func (comp-symbol-func-to-fun f))) (comp-func-pure func)))) (defsubst comp-alloc-class-to-container (alloc-class) @@ -2110,9 +2113,7 @@ Backward propagate array placement properties." "Given FUNC return the `comp-fun' definition in the current context. FUNCTION can be a function-name or byte compiled function." (if (symbolp func) - (gethash (gethash func - (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)) + (comp-symbol-func-to-fun func) (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) From 4348969536f2d2a16e794ff3ce15f855f9ec7e1e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 19:45:10 +0100 Subject: [PATCH 0966/1452] * test/src/comp-test-funcs.el (comp-tests-aref-aset-f) : Fix UB. --- test/src/comp-test-funcs.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 168819b17d6..2fe6276227a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -66,7 +66,7 @@ (length '(1 2 3))) (defun comp-tests-aref-aset-f () - (let ((vec [1 2 3])) + (let ((vec (make-vector 3 0))) (aset vec 2 100) (aref vec 2))) From 5688739c5bd742e5665f58cdcb2c588990c3f416 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 20:00:46 +0100 Subject: [PATCH 0967/1452] * Add `comp-call-op-p' * lisp/emacs-lisp/comp.el (comp-call-op-p): New predicate. (comp-limple-insn-call-p): Make use of. --- lisp/emacs-lisp/comp.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 22575e415f1..46b09fe352c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -423,9 +423,13 @@ structure.") "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) +(defsubst comp-call-op-p (op) + "Call predicate for OP." + (when (memq op comp-limple-calls) t)) + (defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." - (when (memq (car-safe insn) comp-limple-calls) t)) + (comp-call-op-p (car-safe insn))) (defsubst comp-type-hint-p (func) "Type hint predicate for function name FUNC." From 7622740e2930fea33b3381337063d2e8fb834709 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 20:26:36 +0100 Subject: [PATCH 0968/1452] * Introduce a new pass ipa-pure Add a simple pass to infer pure functions not explicitly declared as such. Use this information only during compilation (speed 3) to optimize out function calls whe possible. --- lisp/emacs-lisp/comp.el | 58 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 46b09fe352c..000af0a8b34 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,6 +164,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-limplify comp-propagate comp-call-optim + comp-ipa-pure comp-propagate comp-dead-code comp-tco @@ -379,7 +380,7 @@ structure.") (speed nil :type number :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean - :documentation "t if declared pure nil otherwise.")) + :documentation "t if pure nil otherwise.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexical scoped function." @@ -1601,6 +1602,61 @@ into the C code forwarding the compilation unit." (when (comp-ctxt-with-late-load comp-ctxt) (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + +;;; pure-func pass specific code. + +;; Simple IPA pass to infer function purity of functions not +;; explicitly declared as such. This is effective only at speed 3 to +;; avoid optimizing-out functions and preventing their redefinition +;; being effective. + +(defun comp-collect-calls (f) + "Return a list with all the functions called by F." + (cl-loop + with h = (make-hash-table :test #'eq) + for b being each hash-value of (comp-func-blocks f) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest)) + (puthash f t h)) + (`(,(pred comp-call-op-p) ,f . ,_rest) + (puthash f t h)))) + finally return (cl-loop + for f being each hash-key of h + collect (if (stringp f) + (comp-func-name + (gethash f + (comp-ctxt-funcs-h comp-ctxt))) + f)))) + +(defun comp-pure-infer-func (f) + "If all funtions called by F are pure then F is pure too." + (when (and (cl-every (lambda (x) + (or (comp-function-pure-p x) + (eq x (comp-func-name f)))) + (comp-collect-calls f)) + (not (eq (comp-func-pure f) t))) + (comp-log (format "%s inferred to be pure" (comp-func-name f))) + (setf (comp-func-pure f) t))) + +(defun comp-ipa-pure (_) + "Infer function purity." + (cl-loop + with pure-n = 0 + for n from 1 + while + (/= pure-n + (setf pure-n + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + when (and (>= (comp-func-speed f) 3) + (comp-func-l-p f) + (not (comp-func-pure f))) + do (comp-pure-infer-func f) + count (comp-func-pure f)))) + finally (comp-log (format "ipa-pure iterated %d times" n)))) + ;;; SSA pass specific code. ;; After limplification no edges are present between basic blocks and an From b4de6baa7b5cc41d15bc94cfcdbea680af6dc7b8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 22:05:36 +0100 Subject: [PATCH 0969/1452] * Optimize pure functions defined by the compilation environment * lisp/emacs-lisp/comp.el (comp-apply-in-env): New macro. (comp-function-call-maybe-remove): Update to make use of `comp-apply-in-env'. --- lisp/emacs-lisp/comp.el | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 000af0a8b34..5ff2e098371 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1995,6 +1995,22 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) +(defmacro comp-apply-in-env (func &rest args) + "Apply FUNC to ARGS in the current compilation environment." + `(let ((env (cl-loop + for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + for func-name = (comp-func-name f) + for byte-code = (comp-func-byte-func f) + when func-name + collect `(,func-name . ,(symbol-function func-name)) + and do + (setf (symbol-function func-name) byte-code)))) + (unwind-protect + (apply ,func ,@args) + (cl-loop + for (func-name . def) in env + do (setf (symbol-function func-name) def))))) + (defun comp-ref-args-to-array (args) "Given ARGS assign them to a dedicated array." (when args @@ -2064,13 +2080,17 @@ Here goes everything that can be done not iteratively (read once). (car args)))))) ((comp-function-optimizable-p f args) (ignore-errors - ;; No point to complain here because we should do basic block - ;; pruning in order to be sure that this is not dead-code. This - ;; is now left to gcc, to be implemented only if we want a - ;; reliable diagnostic here. - (rewrite-insn-as-setimm insn - (apply f - (mapcar #'comp-mvar-constant args)))))))) + ;; No point to complain here in case of error because we + ;; should do basic block pruning in order to be sure that this + ;; is not dead-code. This is now left to gcc, to be + ;; implemented only if we want a reliable diagnostic here. + (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f)) + ;; If the function is IN the compilation ctxt + ;; and know to be pure. + (comp-func-byte-func f-in-ctxt) + f)) + (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args)))) + (rewrite-insn-as-setimm insn value))))))) (defun comp-propagate-insn (insn) "Propagate within INSN." From a53b446cb021d1afb30b5c86a9b9cb7512dcf55d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 23:00:07 +0100 Subject: [PATCH 0970/1452] Add some tests for pure function optimization * test/src/comp-tests.el (comp-tests-fw-prop): Fix docstring. (comp-tests-pure-checker-1, comp-tests-pure-checker-2): New functions. (comp-tests-pure): New test testing for pure function optimization. --- test/src/comp-test-pure.el | 40 ++++++++++++++++++++++++++++++++++++++ test/src/comp-tests.el | 32 ++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+) create mode 100644 test/src/comp-test-pure.el diff --git a/test/src/comp-test-pure.el b/test/src/comp-test-pure.el new file mode 100644 index 00000000000..f606a44a10e --- /dev/null +++ b/test/src/comp-test-pure.el @@ -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 + +;; 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 . + +;;; 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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 332facb4cf9..f4bc8156d35 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -662,4 +662,36 @@ CHECKER should always return nil to have a pass." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) +(defun comp-tests-pure-checker-1 (_) + "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is + folded." + (comp-tests-make-insn-checker + 'comp-tests-pure-caller-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-callee-f "F" t) + insn))))) + +(defun comp-tests-pure-checker-2 (_) + "Check that `comp-tests-pure-fibn-f' is folded." + (comp-tests-make-insn-checker + 'comp-tests-pure-fibn-entry-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) + insn))))) + +(ert-deftest comp-tests-pure () + "Some tests for pure functions optimization." + (let ((comp-speed 3) + (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 + comp-tests-pure-checker-2)))) + (load (native-compile (concat comp-test-directory "comp-test-pure.el"))) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (= (comp-tests-pure-caller-f) 4)) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (= (comp-tests-pure-fibn-entry-f) 6765)))) + ;;; comp-tests.el ends here From 92e744d787551e339e6ddb4244008820e72b06ed Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 5 Jul 2020 23:00:14 +0100 Subject: [PATCH 0971/1452] ;* test/src/comp-test-funcs-dyn.el: Fix comment header. --- test/src/comp-test-funcs-dyn.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 5f12378bcf9..67db7587bf9 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -1,4 +1,4 @@ -;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- +;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- ;; Copyright (C) 2020 Free Software Foundation, Inc. From 9aaca828fc6a20d99e72c98e79a3b789827b25e1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 8 Jul 2020 14:23:09 +0100 Subject: [PATCH 0972/1452] * Add `comp-disabled-passes' * lisp/emacs-lisp/comp.el (comp-disabled-passes): New special variable. (native-compile): Make use of `comp-disabled-passes'. --- lisp/emacs-lisp/comp.el | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5ff2e098371..caa6613b893 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -173,6 +173,10 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-final) "Passes to be executed in order.") +(defvar comp-disabled-passes '() + "List of disabled passes. +For internal use only by the testsuite.") + (defvar comp-post-pass-hooks () "Alist PASS FUNCTIONS. Each function in FUNCTIONS is run after PASS. @@ -2684,12 +2688,13 @@ Return the compilation unit file name." (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data))) + (unless (memq pass comp-disabled-passes) + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)))) comp-passes) (native-compiler-error ;; Add source input. From 02bf2e08e27a00cde891a20affe96653fe44c7da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 8 Jul 2020 20:57:20 +0100 Subject: [PATCH 0973/1452] * Disable ipa-pure in comp-tests-tco * test/src/comp-tests.el (comp-tests-tco): Disable ipa-pure to check effectively for tail recursion elimination. --- test/src/comp-tests.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f4bc8156d35..8f0b90f8e01 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -629,6 +629,9 @@ CHECKER should always return nil to have a pass." (ert-deftest comp-tests-tco () "Check for tail recursion elimination." (let ((comp-speed 3) + ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets + ;; optimized-out. + (comp-disabled-passes '(comp-ipa-pure)) (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) (comp-final comp-tests-tco-checker)))) (eval '(defun comp-tests-tco-f (a b count) From c389feede5f1138b23e43edb23564e6ef14d4170 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Jul 2020 10:54:48 +0200 Subject: [PATCH 0974/1452] * Rework the backend to allocate arument arrays for call by references * src/comp.c (comp_t): Add 'zero' field. (emit_limple_call_ref): Allocate an array to host the parametes and generate the code moving values into. (Fcomp__init_ctxt): Initialize comp.zero. --- src/comp.c | 60 ++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 20 deletions(-) diff --git a/src/comp.c b/src/comp.c index 2464b58dad7..15c223c5641 100644 --- a/src/comp.c +++ b/src/comp.c @@ -541,6 +541,7 @@ typedef struct { gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ + gcc_jit_rvalue *zero; gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; @@ -1845,31 +1846,46 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t) #s(comp-mvar 2 6 nil nil nil t) #s(comp-mvar 3 7 t 0 fixnum t)). */ - + static int i = 0; Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - if (!nargs) - return emit_call_ref (callee, - nargs, - comp.arrays[0][0], - direct); + gcc_jit_lvalue *tmp_arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + nargs), + format_string ("call_arr_%d", i++)); - Lisp_Object first_arg = SECOND (insn); - Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg); + ptrdiff_t j = 0; + Lisp_Object arg = CDR (insn); + FOR_EACH_TAIL (arg) + { + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (tmp_arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + j)), + emit_mvar_rval (XCAR (arg))); + ++j; + } - /* Make sure all the arguments are layout-ed into the same array. */ - Lisp_Object p = XCDR (XCDR (insn)); - FOR_EACH_TAIL (p) - if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p)))) - xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"), - insn); - - EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); - return emit_call_ref (callee, - nargs, - comp.arrays[XFIXNUM (arr_idx)][first_slot], - direct); + return emit_call_ref ( + callee, + nargs, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (tmp_arr), + comp.zero), + direct); } static gcc_jit_rvalue * @@ -3966,6 +3982,10 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.lisp_obj_type = comp.lisp_word_type; #endif comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); + comp.zero = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + 0); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, From 527b697b2a1f57cf47ac74a28b7f89c91dddb1ab Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Jul 2020 11:11:41 +0200 Subject: [PATCH 0975/1452] * Rework frame allocation strategy All frame slots are now simple automatic variables given the array allocation and fill is done in 'emit_limple_call_ref'. * src/comp.c (comp_t): Remove 'f_frame' 'arrays' slots, add 'frame'. (emit_mvar_lval): Simplify to make use of 'comp.frame'. (compile_function): Clean-up and add comp.frame initialization. --- src/comp.c | 70 +++++++----------------------------------------------- 1 file changed, 9 insertions(+), 61 deletions(-) diff --git a/src/comp.c b/src/comp.c index 15c223c5641..8f7a48443cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -537,10 +537,9 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ EMACS_INT func_speed; /* From comp-func speed slot. */ - gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ - gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ + gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */ gcc_jit_rvalue *zero; gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; @@ -734,17 +733,7 @@ emit_mvar_lval (Lisp_Object mvar) return comp.scratch; } - EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); - EMACS_INT slot_n = XFIXNUM (mvar_slot); - if (comp.func_has_non_local || (comp.func_speed < 2)) - return comp.arrays[arr_idx][slot_n]; - else - { - if (arr_idx) - return comp.arrays[arr_idx][slot_n]; - else - return comp.f_frame[slot_n]; - } + return comp.frame[XFIXNUM (mvar_slot)]; } static void @@ -3767,54 +3756,13 @@ compile_function (Lisp_Object func) comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); - struct Lisp_Hash_Table *array_h = - XHASH_TABLE (CALL1I (comp-func-array-h, func)); - comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays)); - for (ptrdiff_t i = 0; i < array_h->count; i++) - { - EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i)); - comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays)); - - gcc_jit_lvalue *arr = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - array_len), - format_string ("arr_%td", i)); - - for (ptrdiff_t j = 0; j < array_len; j++) - comp.arrays[i][j] = - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (arr), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - j)); - } - - /* - The floating frame is a copy of the normal frame that can be used to store - locals if the are not going to be used in a nargs call. - This has two advantages: - - Enable gcc for better reordering (frame array is clobbered every time is - passed as parameter being involved into an nargs function call). - - Allow gcc to trigger other optimizations that are prevented by memory - referencing. - */ - if (comp.func_speed >= 2) - { - comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); - for (ptrdiff_t i = 0; i < frame_size; ++i) - comp.f_frame[i] = - gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("local%td", i)); - } + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("slot_%td", i)); comp.scratch = NULL; From 36c289ec8b848e71729bd8715bc1a606f61711c9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Jul 2020 12:22:41 +0200 Subject: [PATCH 0976/1452] * Clean-up now unnecessary backward propagation in comp.el * lisp/emacs-lisp/comp.el (comp-passes): Invoke 'comp-propagate' instead of 'comp-propagate-alloc'. (comp-mvar): Remove unnecessary `array-idx' slot. (comp-propagate-prologue): Remove. (comp-propagate-prologue): Remove `backward' parameter and backward propagation logic. (comp-propagate1): Remove and move logic into `comp-propagate'. (comp-propagate-alloc): Remove pass. --- lisp/emacs-lisp/comp.el | 60 +++++------------------------------------ 1 file changed, 7 insertions(+), 53 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index caa6613b893..9e144dc5958 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -168,7 +168,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-propagate comp-dead-code comp-tco - comp-propagate-alloc + comp-propagate comp-remove-type-hints comp-final) "Passes to be executed in order.") @@ -400,9 +400,6 @@ structure.") "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) :documentation "Unique id when in SSA form.") - ;; The following two are allocation info. - (array-idx 0 :type fixnum - :documentation "The array where the m-var gets allocated.") (slot nil :type (or fixnum symbol) :documentation "Slot number in the array if a number or 'scratch' for scratch slot.") @@ -2015,42 +2012,15 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for (func-name . def) in env do (setf (symbol-function func-name) def))))) -(defun comp-ref-args-to-array (args) - "Given ARGS assign them to a dedicated array." - (when args - (cl-loop with array-h = (comp-func-array-h comp-func) - with arr-idx = (hash-table-count array-h) - for i from 0 - for arg in args - initially - (puthash arr-idx (length args) array-h) - do - ;; We are not supposed to rename arrays more then once. - ;; This because we do only one final back propagation - ;; and arrays are used only once. - - ;; Note: this last is just a property of the code generated - ;; by the byte-compiler. - (cl-assert (= (comp-mvar-array-idx arg) 0)) - (setf (comp-mvar-slot arg) i - (comp-mvar-array-idx arg) arr-idx)))) - -(defun comp-propagate-prologue (backward) +(defun comp-propagate-prologue () "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). -- Forward propagate immediate involed in assignments. -- Backward propagate array layout when BACKWARD is non nil." +Forward propagate immediate involed in assignments." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) do (pcase insn - (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args)) - (when backward - (comp-ref-args-to-array args))) - (`(,(or 'callref 'direct-callref) ,_f . ,args) - (when backward - (comp-ref-args-to-array args))) (`(setimm ,lval ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v @@ -2130,15 +2100,7 @@ Here goes everything that can be done not iteratively (read once). (non-empty (cl-notany #'null types)) (x (car types)) (eqs (cl-every (lambda (y) (eq x y)) types))) - (setf (comp-mvar-type lval) x)) - ;; Backward propagate array index and slot. - (let ((arr-idx (comp-mvar-array-idx lval))) - (when (> arr-idx 0) - (cl-loop with slot = (comp-mvar-slot lval) - for arg in rest - do - (setf (comp-mvar-array-idx arg) arr-idx - (comp-mvar-slot arg) slot))))))) + (setf (comp-mvar-type lval) x))))) (defun comp-propagate* () "Propagate for set* and phi operands. @@ -2153,14 +2115,15 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-propagate1 (backward) +(defun comp-propagate (_) + "Forward propagate types and consts within the lattice." (comp-ssa) (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) ;; FIXME remove the following condition when tested. (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-propagate-prologue backward) + (comp-propagate-prologue) (cl-loop for i from 1 while (comp-propagate*) @@ -2168,15 +2131,6 @@ Return t if something was changed." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) -(defun comp-propagate (_) - "Forward propagate types and consts within the lattice." - (comp-propagate1 nil)) - -(defun comp-propagate-alloc (_) - "Forward propagate types and consts within the lattice. -Backward propagate array placement properties." - (comp-propagate1 t)) - ;;; Call optimizer pass specific code. ;; This pass is responsible for the following optimizations: From eb091c8647a7d10b02e49e61f3c5a0ce3d5ec0a4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 12 Jul 2020 15:05:46 +0200 Subject: [PATCH 0977/1452] * Rename `comp-propagate' into `fw-prop' * lisp/emacs-lisp/comp.el (comp-passes): Rename `comp-propagate' -> `comp-fwprop'. (comp-fwprop-prologue): Rename from `comp-propagate-prologue'. (comp-fwprop-insn): Rename from `comp-fwprop-insn'. (comp-propagate*): Rename from `comp-propagate*' and update. (comp-fwprop): Rename from `comp-propagate' and update. --- lisp/emacs-lisp/comp.el | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9e144dc5958..065417d1d97 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -162,13 +162,13 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify - comp-propagate + comp-fwprop comp-call-optim comp-ipa-pure - comp-propagate + comp-fwprop comp-dead-code comp-tco - comp-propagate + comp-fwprop comp-remove-type-hints comp-final) "Passes to be executed in order.") @@ -2012,7 +2012,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for (func-name . def) in env do (setf (symbol-function func-name) def))))) -(defun comp-propagate-prologue () +(defun comp-fwprop-prologue () "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). Forward propagate immediate involed in assignments." @@ -2066,7 +2066,7 @@ Forward propagate immediate involed in assignments." (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args)))) (rewrite-insn-as-setimm insn value))))))) -(defun comp-propagate-insn (insn) +(defun comp-fwprop-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) @@ -2102,7 +2102,7 @@ Forward propagate immediate involed in assignments." (eqs (cl-every (lambda (y) (eq x y)) types))) (setf (comp-mvar-type lval) x))))) -(defun comp-propagate* () +(defun comp-fwprop* () "Propagate for set* and phi operands. Return t if something was changed." (cl-loop with modified = nil @@ -2110,12 +2110,12 @@ Return t if something was changed." do (cl-loop for insn in (comp-block-insns b) for orig-insn = (unless modified ; Save consing after 1th change. (comp-copy-insn insn)) - do (comp-propagate-insn insn) + do (comp-fwprop-insn insn) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) finally return modified)) -(defun comp-propagate (_) +(defun comp-fwprop (_) "Forward propagate types and consts within the lattice." (comp-ssa) (maphash (lambda (_ f) @@ -2123,10 +2123,10 @@ Return t if something was changed." ;; FIXME remove the following condition when tested. (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-propagate-prologue) + (comp-fwprop-prologue) (cl-loop for i from 1 - while (comp-propagate*) + while (comp-fwprop*) finally (comp-log (format "Propagation run %d times\n" i) 2)) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) From 4c46f8bac0ad3ee89ada767a6dd651411c1319a5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 13 Jul 2020 20:35:20 +0200 Subject: [PATCH 0978/1452] * Add a simple major mode for coloring LIMPLE in the log buffer * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords): New const. (comp-limple-mode): New major mode. (comp-log-to-buffer): Enable `comp-limple-mode' in the log buffer. --- lisp/emacs-lisp/comp.el | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 065417d1d97..24b2a4f6dcd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -471,6 +471,27 @@ Assume allocaiton class 'd-default as default." (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container comp-curr-allocation-class)))) + +;;; Log rountines. + +(defconst comp-limple-lock-keywords + `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) + (,(rx "#s(" (group-n 1 "comp-mvar")) + (1 font-lock-function-name-face)) + (,(rx bol "(" (group-n 1 "phi")) + (1 font-lock-variable-name-face)) + (,(rx (group-n 1 (or "entry" + (seq (or "entry_" "entry_fallback_" "bb_") + (1+ num))))) + (1 font-lock-constant-face)) + (,(rx "(" (group-n 1 (1+ (or word "-")))) + (1 font-lock-keyword-face))) + "Highlights used by comp-limple-mode.") + +(define-derived-mode comp-limple-mode fundamental-mode "LIMPLE" + "Syntax highlight LIMPLE IR." + (setf font-lock-defaults '(comp-limple-lock-keywords))) + (cl-defun comp-log (data &optional (level 1)) "Log DATA at LEVEL. LEVEL is a number from 1-3; if it is less than `comp-verbose', do @@ -495,6 +516,8 @@ log with `comp-log-to-buffer'." (inhibit-read-only t) at-end-p) (with-current-buffer log-buffer + (unless (eq major-mode 'comp-limple-mode) + (comp-limple-mode)) (when (= (point) (point-max)) (setf at-end-p t)) (save-excursion @@ -534,6 +557,8 @@ VERBOSITY is a number between 0 and 3." 2)) edges))) + + (defun comp-output-directory (src) "Return the compilation direcotry for source SRC." (let* ((src (if (symbolp src) (symbol-name src) src)) From 82169a3d97014c3eae5e7bad4aabb9220dd26b3b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 15 Jul 2020 12:15:22 +0200 Subject: [PATCH 0979/1452] * Fix bug#42360 * src/comp.c (compile_function): Allocate function frame as array if non local exits are present to retain correct Elisp semantic. (emit_limple_call_ref): Directly use the frame array for ref calls to have GCC spills into it before calling. --- src/comp.c | 47 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 41 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8f7a48443cf..704bd4b6b35 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1839,6 +1839,17 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + if (!nargs) + return emit_call_ref (callee, 0, comp.frame[0], direct); + + if (comp.func_has_non_local || !comp.func_speed) + { + /* FIXME: See bug#42360. */ + Lisp_Object first_arg = SECOND (insn); + EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); + return emit_call_ref (callee, nargs, comp.frame[first_slot], direct); + } + gcc_jit_lvalue *tmp_arr = gcc_jit_function_new_local ( comp.func, @@ -3757,12 +3768,36 @@ compile_function (Lisp_Object func) comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (ptrdiff_t i = 0; i < frame_size; ++i) - comp.frame[i] = - gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("slot_%td", i)); + if (comp.func_has_non_local || !comp.func_speed) + { + /* FIXME: See bug#42360. */ + gcc_jit_lvalue *arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "frame"); + + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + } + else + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("slot_%td", i)); comp.scratch = NULL; From 2c2cc21f1be721e5ba30fa22aedeb5c254791193 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 15 Jul 2020 23:01:11 +0200 Subject: [PATCH 0980/1452] Add a testcase for bug#42360 * test/src/comp-tests.el (comp-test-42360): New testcase. * test/src/comp-test-funcs.el (comp-test-42360-f): New function. --- test/src/comp-test-funcs.el | 47 +++++++++++++++++++++++++++++++++++++ test/src/comp-tests.el | 5 ++++ 2 files changed, 52 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 2fe6276227a..fe9943a1b91 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -290,6 +290,53 @@ (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))))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8f0b90f8e01..092504565a6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -363,6 +363,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (= (comp-test-speed--1-f) 3)) (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) +(ert-deftest comp-test-42360 () + "." + (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) + "Nel mezzo del yyy"))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 6c108e44c9522d1a70ac49c4810ed5927b8b2223 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 26 Jul 2020 09:36:09 +0200 Subject: [PATCH 0981/1452] * Add `comp-ensure-native-compiler' guarding entry points * lisp/emacs-lisp/comp.el (comp-ensure-native-compiler): New function. (native-compile, batch-native-compile) (batch-byte-native-compile-for-bootstrap, native-compile-async): Make use of `comp-ensure-native-compiler'. --- lisp/emacs-lisp/comp.el | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 24b2a4f6dcd..c5027168be4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -417,6 +417,16 @@ structure.") +(defun comp-ensure-native-compiler () + "Make sure Emacs has native compiler support and libgccjit is laodable. +Raise and error otherwise. +To be used by all entry points." + (cond + ((null (boundp 'comp-ctxt)) + (error "Emacs not compiled with native compiler support (--with-nativecomp)")) + ((null (native-comp-available-p)) + (error "Cannot find libgccjit")))) + (defsubst comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -2652,6 +2662,7 @@ FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. When WITH-LATE-LOAD non Nil mark the compilation unit for late load once finished compiling (internal use only). Return the compilation unit file name." + (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) (signal 'native-compiler-error @@ -2687,6 +2698,7 @@ Return the compilation unit file name." (defun batch-native-compile () "Run `native-compile' on remaining command-line arguments. Ultra cheap impersonation of `batch-byte-compile'." + (comp-ensure-native-compiler) (cl-loop for file in command-line-args-left if (or (null byte-native-for-bootstrap) (cl-notany (lambda (re) (string-match re file)) @@ -2699,6 +2711,7 @@ Ultra cheap impersonation of `batch-byte-compile'." (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." + (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLE") "1") (batch-byte-compile) (cl-assert (= 1 (length command-line-args-left))) @@ -2721,6 +2734,7 @@ PATHS is one path or a list of paths to files or directories. run simultaneously. If RECURSIVELY, recurse into subdirectories of given directories. LOAD can be nil t or 'late." + (comp-ensure-native-compiler) (unless (member load '(nil t late)) (error "LOAD must be nil t or 'late")) (unless (listp paths) From 79ed90380547128b9919d407901a886fed0306b7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 26 Jul 2020 09:38:14 +0200 Subject: [PATCH 0982/1452] * Add NATIVE_COMP to `system-configuration-features' * configure.ac (emacs_config_features): Add NATIVE_COMP --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 2277f36e491..cb059303255 100644 --- a/configure.ac +++ b/configure.ac @@ -5725,7 +5725,7 @@ emacs_config_features= for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ GCONF GSETTINGS GLIB NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE HARFBUZZ M17N_FLT \ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 XDBE XIM \ - NS MODULES THREADS XWIDGETS LIBSYSTEMD JSON PDUMPER UNEXEC LCMS2 GMP; do + NS MODULES NATIVE_COMP THREADS XWIDGETS LIBSYSTEMD JSON PDUMPER UNEXEC LCMS2 GMP; do case $opt in PDUMPER) val=${with_pdumper} ;; From 80d7f710f2fab902e46aa3fddb8e1c1795420af3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 2 Aug 2020 17:01:42 +0200 Subject: [PATCH 0983/1452] * Fix defsubst missing inline Bug#42664 * lisp/emacs-lisp/byte-run.el (defsubst): Do not native compile defsubsts to have them always effective. --- lisp/emacs-lisp/byte-run.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 4c1dce264a7..539846683f0 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -364,7 +364,12 @@ You don't need this. (See bytecomp.el commentary for more details.) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) `(prog1 - (defun ,name ,arglist ,@body) + (defun ,name ,arglist + ;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664). + (declare (speed -1)) + ,@body) (eval-and-compile (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) From dd814b0a58aebe12168ffde946860e851ecf2b5b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 5 Aug 2020 08:47:56 +0200 Subject: [PATCH 0984/1452] * lisp/emacs-lisp/bytecomp.el: Guard against double native compilation. --- lisp/emacs-lisp/bytecomp.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c5b086f91a0..20a481a8a1c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5269,9 +5269,10 @@ and corresponding effects." (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 From f6502f959253b8f705e324e137c2933c5a668f62 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Aug 2020 09:45:16 +0200 Subject: [PATCH 0985/1452] ; * lisp/emacs-lisp/comp.el (comp-deferred-compilation): Fix doc. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c5027168be4..599d35b61c5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,7 +42,7 @@ :group 'lisp) (defcustom comp-deferred-compilation nil - "If t compile asyncronously all lexically bound .elc files being loaded. + "If non-nil compile asyncronously all .elc files being loaded. Once compilation happened each function definition is updated to the native compiled one." :type 'boolean From b85870e65b642d4a38d797bfe7bcab7b7f9c15f0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Aug 2020 12:47:34 +0200 Subject: [PATCH 0986/1452] * src/pdumper.c (dump_cold_native_subr): Clean-up *IMPLICIT_CONVERSION macros. --- src/pdumper.c | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index c55b6f7bb43..83410e36774 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3416,18 +3416,14 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) subr_offset + dump_offsetof (struct Lisp_Subr, symbol_name), ctx->offset); const char *symbol_name = XSUBR (subr)->symbol_name; - ALLOW_IMPLICIT_CONVERSION; dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); - DISALLOW_IMPLICIT_CONVERSION; 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]; - ALLOW_IMPLICIT_CONVERSION; dump_write (ctx, c_name, 1 + strlen (c_name)); - DISALLOW_IMPLICIT_CONVERSION; } static void From 1712311f0084af850925f4c472f6ca186ab09c54 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Aug 2020 17:13:11 +0200 Subject: [PATCH 0987/1452] * src/pdumper.c (dump_do_dump_relocation): Improve error messages. --- src/pdumper.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 83410e36774..629d0969346 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5281,12 +5281,13 @@ dump_do_dump_relocation (const uintptr_t dump_base, struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) - error ("can't relocate native subr with not loaded compilation unit"); + 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 in compilation unit"); + 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); From 3882e8fd244a66edb6ba60f40182a4d0772cfcb1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 14 Aug 2020 08:29:28 +0200 Subject: [PATCH 0988/1452] * Fix excessive echo area usage * lisp/emacs-lisp/comp.el (comp-run-async-workers): Use `with-temp-file' to fill temp-file. --- lisp/emacs-lisp/comp.el | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 599d35b61c5..a92392f63ac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2608,13 +2608,16 @@ display a message." (message "Compiling %s..." ,source-file) (native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ - (_ (progn - (comp-log "\n") - (comp-log (prin1-to-string expr)))) (temp-file (make-temp-file (concat "emacs-async-comp-" (file-name-base source-file) "-") - nil ".el" (prin1-to-string expr))) + nil ".el")) + (expr-string (prin1-to-string expr)) + (_ (progn + (with-temp-file temp-file + (insert expr-string)) + (comp-log "\n") + (comp-log expr-string))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) From f2e6168ece69d635b4f9d9a138100c6772903d0b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Aug 2020 20:22:10 +0200 Subject: [PATCH 0989/1452] * Remove a warning for conventional build * src/lread.c (parent_directory): Add ATTRIBUTE_UNUSED. --- src/lread.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index f5a7d44a1e0..f10a20ded86 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1099,7 +1099,7 @@ close_infile_unwind (void *arg) infile = prev_infile; } -static Lisp_Object +static ATTRIBUTE_UNUSED Lisp_Object parent_directory (Lisp_Object directory) { return Ffile_name_directory (Fsubstring (directory, From 3224a443060a5f21bb910064fc06fe4432810355 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 19 Jul 2020 10:46:24 +0200 Subject: [PATCH 0990/1452] Move eln files into dedicated cache directories When loading a elc file search for a corresponding eln one into `comp-eln-load-path' directories and load it if available. `comp-eln-load-path' contains by default two directory (user and system one). * src/pdumper.c (dump_do_dump_relocation): While resurrecting from load set eln cache sys dir in `Vcomp_eln_load_path'. * src/lread.c (maybe_swap_for_eln): New function. (Fload): Clean-up some now unnecessary code going back to the master one. (Fload): Make use of Vcomp_eln_to_el_h for the reverse file look-up. (openp_add_middle_dir_to_suffixes) (openp_max_middledir_and_suffix_len, openp_fill_filename_buffer): Remove functions. (openp): As for Fload revert code modifications. (openp): When a .elc file is being loaded check if a corresponding eln can be loaded in place. * src/comp.c (ELN_FILENAME_HASH_LEN): New macro. (comp_hash_string): New function. (hash_native_abi): Make use of 'comp_hash_string'. (hash_native_abi): Change `comp-native-path-postfix' format. (Fcomp_el_to_eln_filename): New function. (Fcomp__compile_ctxt_to_file): Have file_name as a input. (Vcomp_eln_to_el_h, Vcomp_eln_load_path): New global varaibles. * lisp/startup.el (normal-top-level): Add user eln cache directory in `comp-eln-load-path'. * lisp/help-fns.el (find-lisp-object-file-name): Reverse look-up files using `comp-eln-to-el-h'. * lisp/files.el (locate-file): Likewise. * lisp/emacs-lisp/find-func.el (find-library-name): Likewise. * lisp/emacs-lisp/comp.el (comp-output-directory) (comp-output-base-filename, comp-output-filename): Remove function. (comp-compile-ctxt-to-file): Create parent directories if necessary. (comp-run-async-workers, native-compile, native-compile-async): Make use `comp-el-to-eln-filename'. --- lisp/emacs-lisp/comp.el | 38 ++----- lisp/emacs-lisp/find-func.el | 6 +- lisp/files.el | 5 +- lisp/help-fns.el | 6 +- lisp/startup.el | 3 + src/comp.c | 71 ++++++++++-- src/lread.c | 214 ++++++++++++----------------------- src/pdumper.c | 17 ++- 8 files changed, 167 insertions(+), 193 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a92392f63ac..30cedf298e2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -569,28 +569,6 @@ VERBOSITY is a number between 0 and 3." -(defun comp-output-directory (src) - "Return the compilation direcotry for source SRC." - (let* ((src (if (symbolp src) (symbol-name src) src)) - (expanded-filename (expand-file-name src))) - (file-name-as-directory - (concat (file-name-directory expanded-filename) - comp-native-path-postfix)))) - -(defun comp-output-base-filename (src) - "Output filename sans extention for SRC file being native compiled." - (let* ((src (if (symbolp src) (symbol-name src) src)) - (expanded-filename (expand-file-name src)) - (output-dir (comp-output-directory src)) - (output-filename - (file-name-sans-extension - (file-name-nondirectory expanded-filename)))) - (expand-file-name output-filename output-dir))) - -(defun comp-output-filename (src) - "Output filename for SRC file being native compiled." - (concat (comp-output-base-filename src) ".eln")) - (defmacro comp-loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executning BODY. Inside BODY `insn' can be used to read or set the current @@ -2486,7 +2464,7 @@ Prepare every function for final compilation and drive the C back-end." (unless (file-exists-p dir) ;; In case it's created in the meanwhile. (ignore-error 'file-already-exists - (make-directory dir))) + (make-directory dir t))) (unless comp-dry-run (comp--compile-ctxt-to-file name)))) @@ -2597,7 +2575,7 @@ display a message." source-file) when (or comp-always-compile (file-newer-than-file-p source-file - (comp-output-filename source-file))) + (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn (require 'comp) (setf comp-speed ,comp-speed @@ -2636,7 +2614,7 @@ display a message." (when (and load1 (zerop (process-exit-status process))) (native-elisp-load - (comp-output-filename source-file1) + (comp-el-to-eln-filename source-file1) (eq load1 'late))) (comp-run-async-workers))))) (puthash source-file process comp-async-compilations)) @@ -2676,7 +2654,11 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output (comp-output-base-filename function-or-file) + :output (comp-el-to-eln-filename (if (symbolp function-or-file) + (symbol-name function-or-file) + function-or-file) + (when byte-native-for-bootstrap + (car (last comp-eln-load-path)))) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err @@ -2770,8 +2752,8 @@ queued with LOAD %" (and (eq load 'late) (cl-some (lambda (re) (string-match re file)) comp-deferred-compilation-black-list))) - (let ((out-dir (comp-output-directory file)) - (out-filename (comp-output-filename file))) + (let* ((out-filename (comp-el-to-eln-filename file)) + (out-dir (file-name-directory out-filename))) (if (or (file-writable-p out-filename) (and (not (file-exists-p out-dir)) (file-writable-p (substring out-dir 0 -1)))) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index efbcfb3a722..2db976f8c5c 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -188,11 +188,7 @@ LIBRARY should be a string (the name of the library)." ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) ((string-match "\\.eln\\'" library) - ;; From help-fns.el. - (setq library (expand-file-name (concat (file-name-base library) - ".el") - (concat (file-name-directory library) - ".."))))) + (setq library (gethash (file-name-nondirectory library) comp-eln-to-el-h)))) (or (locate-file library (or find-function-source-path load-path) diff --git a/lisp/files.el b/lisp/files.el index 9270f334afa..2aeae0a9bef 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -926,7 +926,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'." diff --git a/lisp/help-fns.el b/lisp/help-fns.el index afca2cd932e..49cdb4ed5e4 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -333,10 +333,8 @@ suitable file is found, return nil." object (or (if (symbolp type) type) 'defun)))) (file-name (if (and true-name (string-match "[.]eln\\'" true-name)) - (expand-file-name (concat (file-name-base true-name) - ".el") - (concat (file-name-directory true-name) - "..")) + (gethash (file-name-nondirectory true-name) + comp-eln-to-el-h) true-name))) (cond (autoloaded diff --git a/lisp/startup.el b/lisp/startup.el index e58f27e7ebc..e469b90bd68 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -537,6 +537,9 @@ 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 (boundp 'comp-eln-load-path) + (setq comp-eln-load-path (cons (concat user-emacs-directory "eln-cache/") + 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 diff --git a/src/comp.c b/src/comp.c index 704bd4b6b35..9582506f91b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -393,6 +393,8 @@ load_gccjit_if_necessary (bool mandatory) } +#define ELN_FILENAME_HASH_LEN 64 + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -634,6 +636,16 @@ format_string (const char *format, ...) return scratch_area; } +static Lisp_Object +comp_hash_string (Lisp_Object string) +{ + Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); + sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + + return digest; +} + /* Produce a key hashing Vcomp_subr_list. */ void @@ -641,10 +653,7 @@ hash_native_abi (void) { Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string (" ")); - Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); - - sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); - hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + Lisp_Object digest = comp_hash_string (string); /* Check runs once. */ eassert (NILP (Vcomp_abi_hash)); @@ -652,8 +661,7 @@ hash_native_abi (void) /* If 10 characters are usually sufficient for git I guess 16 are fine for us here. */ Vcomp_native_path_postfix = - concat3 (make_string ("eln-", 4), - Vsystem_configuration, + concat2 (Vsystem_configuration, concat2 (make_string ("-", 1), Fsubstring_no_properties (Vcomp_abi_hash, make_fixnum (0), @@ -3852,6 +3860,30 @@ compile_function (Lisp_Object func) /* Entry points exposed to lisp. */ /**********************************/ +DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, + Scomp_el_to_eln_filename, 1, 2, 0, + doc: /* Given a source file return the corresponding .eln true filename. +If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) + (Lisp_Object file_name, Lisp_Object base_dir) +{ + CHECK_STRING (file_name); + file_name = Fexpand_file_name (file_name, Qnil); + Lisp_Object hashed = Fsubstring (comp_hash_string (file_name), Qnil, + make_fixnum (ELN_FILENAME_HASH_LEN)); + file_name = concat2 (Ffile_name_nondirectory (Fsubstring (file_name, Qnil, + make_fixnum (-3))), + build_string ("-")); + file_name = concat3 (file_name, hashed, build_string (NATIVE_ELISP_SUFFIX)); + if (NILP (base_dir)) + base_dir = XCAR (Vcomp_eln_load_path); + + if (!file_name_absolute_p (SSDATA (base_dir))) + base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); + + return Fexpand_file_name (file_name, + concat2 (base_dir, Vcomp_native_path_postfix)); +} + DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) @@ -4039,11 +4071,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) - (Lisp_Object base_name) + (Lisp_Object file_name) { load_gccjit_if_necessary (true); - CHECK_STRING (base_name); + CHECK_STRING (file_name); + Lisp_Object base_name = Fsubstring (file_name, Qnil, make_fixnum (-4)); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -4105,19 +4138,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); - Lisp_Object out_file = CALLN (Fconcat, base_name, dot_so); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL2I (comp--replace-output-file, out_file, tmp_file); + CALL2I (comp--replace-output-file, file_name, tmp_file); if (!noninteractive) unbind_to (count, Qnil); - return out_file; + return file_name; } DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, @@ -4971,6 +5003,7 @@ syms_of_comp (void) build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); @@ -5015,6 +5048,22 @@ syms_of_comp (void) internal use during */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); + DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h, + doc: /* Hash table eln-filename -> el-filename. */); + Vcomp_eln_to_el_h = CALLN (Fmake_hash_table, QCtest, Qequal); + + DEFVAR_LISP ("comp-eln-load-path", Vcomp_eln_load_path, + doc: /* List of eln cache directories. + +If a directory is non absolute is assumed to be relative to +`invocation-directory'. +The last directory of this list is assumed to be the system one. */); + + /* Temporary value in use for boostrap. We can't do better as + `invocation-directory' is still unset, will be fixed up during + dump reload. */ + Vcomp_eln_load_path = Fcons (build_string ("../eln-cache/"), Qnil); + #endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); diff --git a/src/lread.c b/src/lread.c index f10a20ded86..c5bec0633df 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1231,8 +1231,7 @@ 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); } if (fd == -1) @@ -1478,9 +1477,8 @@ Return t if the file exists and loads successfully. */) same folder of their respective sources therfore not to break packages we fake `load-file-name' here. The non faked version of it is `load-true-file-name'. */ - specbind (Qload_file_name, - concat2 (parent_directory (Ffile_name_directory (found)), - Ffile_name_nondirectory (found))); + specbind (Qload_file_name, Fgethash (Ffile_name_nondirectory (found), + Vcomp_eln_to_el_h, Qnil)); } else specbind (Qload_file_name, found); @@ -1608,118 +1606,51 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) return file; } -/* This function turns a list of suffixes into a list of middle dirs - and suffixes. If the suffix is not NATIVE_ELISP_SUFFIX then its - suffix is nil and it is added to the list as is. Instead, if it - suffix is NATIVE_ELISP_SUFFIX then two elements are added to the - list. The first one has middledir equal to nil and the second uses - comp-native-path-postfix as middledir. This is because we'd like - to search for dir/foo.eln before dir/middledir/foo.eln. +/* Look for a suitable .eln file to be loaded in place of FILENAME. + If found replace the content of FILENAME and FD. */ -For example, it turns this: - -(".eln" ".elc" ".elc.gz" ".el" ".el.gz") - - into this: - -((nil . ".eln") - (comp-native-path-postfix . ".eln") - (nil . ".elc") - (nil . ".elc.gz") - (nil . ".el") - (nil . ".el.gz")) -*/ -static Lisp_Object -openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) +static void +maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) { - Lisp_Object tail = suffixes; - Lisp_Object extended_suf = Qnil; - FOR_EACH_TAIL_SAFE (tail) - { - /* suffixes may be a stack-based cons pointing to stack-based - strings. We must copy the suffix if we are putting it into - a heap-based cons to avoid a dangling reference. This would - lead to crashes during the GC. */ - CHECK_STRING_CAR (tail); - char * suf = SSDATA (XCAR (tail)); - Lisp_Object copied_suffix = build_string (suf); #ifdef HAVE_NATIVE_COMP - if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) - { - CHECK_STRING (Vcomp_native_path_postfix); - /* Here we add them in the opposite order so that nreverse - corrects it. */ - extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); - extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, - copied_suffix), - extended_suf); - } - else + struct stat eln_st; + + if (!suffix_p (*filename, ".elc")) + return; + + /* Search eln in the eln-cache directories. */ + Lisp_Object eln_path_tail = Vcomp_eln_load_path; + FOR_EACH_TAIL_SAFE (eln_path_tail) + { + Lisp_Object el_name = + Fsubstring (*filename, Qnil, make_fixnum (-1)); + Lisp_Object eln_name = + Fcomp_el_to_eln_filename (el_name, XCAR (eln_path_tail)); + 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) + { + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + el_name, Vcomp_eln_to_el_h); + return; + } + else + emacs_close (eln_fd); + } + } + } #endif - extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); - } - - suffixes = Fnreverse (extended_suf); - return suffixes; -} - -/* This function takes a list of middledirs and suffixes and returns - the maximum buffer space that this part of the filename will - need. */ -static ptrdiff_t -openp_max_middledir_and_suffix_len (Lisp_Object middledir_and_suffixes) -{ - ptrdiff_t max_extra_len = 0; - Lisp_Object tail = middledir_and_suffixes; - FOR_EACH_TAIL_SAFE (tail) - { - Lisp_Object middledir_and_suffix = XCAR (tail); - Lisp_Object middledir = XCAR (middledir_and_suffix); - Lisp_Object suffix = XCDR (middledir_and_suffix); - ptrdiff_t len = SBYTES (suffix); - if (!NILP (middledir)) - len += 2 + SBYTES (middledir); /* Add two slashes. */ - max_extra_len = max (max_extra_len, len); - } - return max_extra_len; -} - -/* This function completes the FN buffer with the middledir, - basenameme, and suffix. It takes the directory length in DIRNAME, - but it requires that it has been copied already to the start of - the buffer. - - After this function the FN buffer will be (depending on middledir) - dirname/middledir/basename.suffix - or - dirname/basename.suffix -*/ -static ptrdiff_t -openp_fill_filename_buffer (char *fn, ptrdiff_t dirnamelen, - Lisp_Object basenamewext, - Lisp_Object middledir_and_suffix) -{ - Lisp_Object middledir = XCAR (middledir_and_suffix); - Lisp_Object suffix = XCDR (middledir_and_suffix); - ptrdiff_t basenamewext_len = SBYTES (basenamewext); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); - ptrdiff_t lmiddledir = 0; - if (!NILP (middledir)) - { - /* Add 1 for the slash. */ - lmiddledir = SBYTES (middledir) + 1; - memcpy (fn + dirnamelen, SDATA (middledir), - lmiddledir - 1); - fn[dirnamelen + (lmiddledir - 1)] = '/'; - } - - memcpy (fn + dirnamelen + lmiddledir, SDATA (basenamewext), - basenamewext_len); - /* Make complete filename by appending SUFFIX. */ - memcpy (fn + dirnamelen + lmiddledir + basenamewext_len, - SDATA (suffix), lsuffix + 1); - fnlen = dirnamelen + lmiddledir + basenamewext_len + lsuffix; - return fnlen; } /* Search for a file whose name is STR, looking in directories @@ -1759,21 +1690,23 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, ptrdiff_t want_length; Lisp_Object filename; Lisp_Object string, tail, encoded_fn, save_string; - Lisp_Object middledir_and_suffixes; - ptrdiff_t max_extra_len = 0; + ptrdiff_t max_suffix_len = 0; int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; - /* The last-modified time of the newest matching file found. Initialize it to something less than all valid timestamps. */ struct timespec save_mtime = make_timespec (TYPE_MINIMUM (time_t), -1); CHECK_STRING (str); - middledir_and_suffixes = openp_add_middle_dir_to_suffixes (suffixes); - - max_extra_len = openp_max_middledir_and_suffix_len (middledir_and_suffixes); + tail = suffixes; + FOR_EACH_TAIL_SAFE (tail) + { + CHECK_STRING_CAR (tail); + max_suffix_len = max (max_suffix_len, + SBYTES (XCAR (tail))); + } string = filename = encoded_fn = save_string = Qnil; @@ -1790,7 +1723,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, executable. */ FOR_EACH_TAIL_SAFE (path) { - ptrdiff_t dirnamelen, prefixlen; + ptrdiff_t baselen, prefixlen; if (EQ (path, just_use_str)) filename = str; @@ -1807,40 +1740,35 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, continue; } - /* Calculate maximum length of any filename made from this path element/specified file name and any possible suffix. */ - want_length = max_extra_len + SBYTES (filename); + want_length = max_suffix_len + SBYTES (filename); if (fn_size <= want_length) { fn_size = 100 + want_length; fn = SAFE_ALLOCA (fn_size); } - Lisp_Object dirnamewslash = Ffile_name_directory (filename); - Lisp_Object basenamewext = Ffile_name_nondirectory (filename); - /* Copy FILENAME's data to FN but remove starting /: if any. */ - prefixlen = ((SCHARS (dirnamewslash) > 2 - && SREF (dirnamewslash, 0) == '/' - && SREF (dirnamewslash, 1) == ':') + prefixlen = ((SCHARS (filename) > 2 + && SREF (filename, 0) == '/' + && SREF (filename, 1) == ':') ? 2 : 0); - dirnamelen = SBYTES (dirnamewslash) - prefixlen; - memcpy (fn, SDATA (dirnamewslash) + prefixlen, dirnamelen); + baselen = SBYTES (filename) - prefixlen; + memcpy (fn, SDATA (filename) + prefixlen, baselen); - /* Loop over middledir_and_suffixes. */ - AUTO_LIST1 (empty_string_only, Fcons (Qnil, empty_unibyte_string)); - tail = NILP (middledir_and_suffixes) ? empty_string_only - : middledir_and_suffixes; + /* Loop over suffixes. */ + AUTO_LIST1 (empty_string_only, empty_unibyte_string); + tail = NILP (suffixes) ? empty_string_only : suffixes; FOR_EACH_TAIL_SAFE (tail) { - Lisp_Object middledir_and_suffix = XCAR (tail); - Lisp_Object suffix = XCDR (middledir_and_suffix); + Lisp_Object suffix = XCAR (tail); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); Lisp_Object handler; - ptrdiff_t fnlen = openp_fill_filename_buffer (fn, dirnamelen, - basenamewext, - middledir_and_suffix); + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); + fnlen = baselen + lsuffix; /* Check that the file exists and is not a directory. */ /* We used to only check for handlers on non-absolute file names: @@ -1962,9 +1890,11 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { + maybe_swap_for_eln (&string, &fd, get_stat_mtime (&st)); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; + SAFE_FREE (); return fd; } @@ -1973,6 +1903,7 @@ 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 (&save_string, &save_fd, save_mtime); if (storeptr) *storeptr = save_string; SAFE_FREE (); @@ -5030,11 +4961,8 @@ to the specified file name if a suffix is allowed or required. */); Vload_suffixes = Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes); #endif -#endif -#ifdef HAVE_NATIVE_COMP - Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_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. */); #ifdef HAVE_MODULES diff --git a/src/pdumper.c b/src/pdumper.c index 629d0969346..ca055a1327c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5249,9 +5249,24 @@ dump_do_dump_relocation (const uintptr_t dump_base, { fclose (file); installation_state = INSTALLED; + /* FIXME Vcomp_eln_load_path = ?? */ } else - installation_state = LOCAL_BUILD; + { + installation_state = LOCAL_BUILD; + /* Fixup `comp-eln-load-path' so emacs can be invoked + position independently. */ + Lisp_Object eln_cache_sys = + Ffile_name_directory (concat2 (Vinvocation_directory, + XCDR (comp_u->file))); + /* One directory up... */ + eln_cache_sys = + Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, + make_fixnum (-1))); + /* FIXME for subsequent dumps we should fixup only the + last entry. */ + Vcomp_eln_load_path = Fcons (eln_cache_sys, Qnil); + } } comp_u->file = From 88b860ef6c687b8b1e3f00eb200f7fc1fb4425dd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 13 Aug 2020 23:47:54 +0200 Subject: [PATCH 0991/1452] Make comp-deferred-compilation a simple global and set it on by default * src/comp.c (comp_deferred_compilation): Doc update and set it to true by default. * lisp/emacs-lisp/comp.el (comp-deferred-compilation): Remove customize. --- lisp/emacs-lisp/comp.el | 7 ------- src/comp.c | 8 +++++++- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 30cedf298e2..5805e5c96ab 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -41,13 +41,6 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-deferred-compilation nil - "If non-nil compile asyncronously all .elc files being loaded. -Once compilation happened each function definition is updated to -the native compiled one." - :type 'boolean - :group 'comp) - (defcustom comp-speed 2 "Compiler optimization level. From -1 to 3. - -1 functions are kept in bytecode form and no native compilation is performed. diff --git a/src/comp.c b/src/comp.c index 9582506f91b..b795afae351 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4901,7 +4901,13 @@ syms_of_comp (void) #ifdef HAVE_NATIVE_COMP /* Compiler control customizes. */ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, - doc: /* If t compile asyncronously every .elc file loaded. */); + doc: /* If non-nil compile asyncronously all .elc files +being loaded. + +Once compilation happened each function definition is updated to the +native compiled one. */); + comp_deferred_compilation = true; + DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); From dbeafd34032797c5d743a741492a5d9b35dd8c7b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 14 Aug 2020 09:05:31 +0200 Subject: [PATCH 0992/1452] Some Makefile updates and clean-up * Makefile.in (clean): Remove 'eln-cache' folder. * lisp/Makefile.in (.SUFFIXES): Remove .eln. (native-compile-clean): Target remove. (compile-always, bootstrap-clean): Remove 'native-compile-clean' prerequisite. * src/Makefile.in (%.eln): Remove rule. --- Makefile.in | 1 + lisp/Makefile.in | 13 +++---------- src/Makefile.in | 4 ---- 3 files changed, 4 insertions(+), 14 deletions(-) diff --git a/Makefile.in b/Makefile.in index f28623ef565..253f7f7a54b 100644 --- a/Makefile.in +++ b/Makefile.in @@ -863,6 +863,7 @@ clean: $(clean_dirs:=_clean) [ ! -d test ] || $(MAKE) -C test $@ -rm -f ./*.tmp etc/*.tmp* -rm -rf info-dir.* + -rm -rf eln-cache ### 'bootclean' ### Delete all files that need to be remade for a clean bootstrap. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 9bcceceb0ee..164e4a01f59 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -302,7 +302,7 @@ endif # subdirectories, to make sure require's and load's in the files being # compiled find the right files. -.SUFFIXES: .eln .elc .el +.SUFFIXES: .elc .el # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. @@ -357,13 +357,6 @@ compile-main: gen-lisp compile-clean TARGETS="$$chunk"; \ done -.PHONY: native-compile-clean -native-compile-clean: -# Erase all eln output compilation folders. -ifeq ($(HAVE_NATIVE_COMP),yes) - find $(lisp) -regex ".*/eln-.*-[0-9a-z]+\\'" -type d | xargs rm -rf -endif - .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -400,7 +393,7 @@ compile: $(LOADDEFS) autoloads compile-first # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they # set the local variable no-byte-compile. -compile-always: native-compile-clean +compile-always: find $(lisp) -name '*.elc' $(FIND_DELETE) $(MAKE) compile @@ -490,7 +483,7 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el .PHONY: bootstrap-clean distclean maintainer-clean extraclean -bootstrap-clean: native-compile-clean +bootstrap-clean: find $(lisp) -name '*.elc' $(FIND_DELETE) rm -f $(AUTOGENEL) diff --git a/src/Makefile.in b/src/Makefile.in index 63a4aa80e93..7380a87644b 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -790,10 +790,6 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS @$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\ THEFILE=$< $ Date: Sat, 15 Aug 2020 10:54:22 +0200 Subject: [PATCH 0993/1452] * Prevent recursive load Prevent autoload to kicks in while running `native-compile-async'. Autoload cannot be used safely by functions serving deferred compilation as a circular load can be triggered if the dependency is not native compiled already. * lisp/emacs-lisp/comp.el (warnings): Add require. --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5805e5c96ab..99bf30a4eee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -36,6 +36,7 @@ (require 'gv) (require 'rx) (require 'subr-x) +(require 'warnings) (defgroup comp nil "Emacs Lisp native compiler." From 377ffdb528e75f7e02be5f0305cdf326da0dc451 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Aug 2020 11:29:06 +0200 Subject: [PATCH 0994/1452] * Do not fail if more then one level of directories has to be created * lisp/emacs-lisp/comp.el (native-compile-async): Call make-directory if necessary. --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99bf30a4eee..802466550dc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2748,9 +2748,9 @@ queued with LOAD %" comp-deferred-compilation-black-list))) (let* ((out-filename (comp-el-to-eln-filename file)) (out-dir (file-name-directory out-filename))) - (if (or (file-writable-p out-filename) - (and (not (file-exists-p out-dir)) - (file-writable-p (substring out-dir 0 -1)))) + (unless (file-exists-p out-dir) + (make-directory out-dir t)) + (if (file-writable-p out-filename) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))) (display-warning 'comp From b6238d826e5abd1f49144df711deac6bffa3fe32 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Aug 2020 20:12:46 +0200 Subject: [PATCH 0995/1452] * Deferred compilation must always compile despite source file timestamp * lisp/emacs-lisp/comp.el (comp-run-async-workers): Always compile if load is set. --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 802466550dc..b5ab4ebdccb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2568,6 +2568,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or comp-always-compile + load ; Always compile when the compilation is + ; commanded for late load. (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn From 171db3110159d95803dea13c4ee7bca4a795747b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Aug 2020 11:18:36 +0200 Subject: [PATCH 0996/1452] Make install target functional for new eln-cache directory arrangement * src/comp.h (fixup_eln_load_path): New extern. * src/comp.c (fixup_eln_load_path): New function. * src/pdumper.c (dump_do_dump_relocation): Update to make use of 'fixup_eln_load_path'. * lisp/loadup.el: Update to store in the compilation unit the correct eln-cache installed path. Rename --lisp-dest -> --eln-dest and. * Makefile.in: Pass the eln destination directory to src/Makefile. Rename LISP_DESTDIR -> ELN_DESTDIR. (ELN_DESTDIR): Define. (install-eln): New target. (install): Add install-eln as prerequisite. * src/Makefile.in: Rename --lisp-dest -> --eln-dest and LISP_DESTDIR -> ELN_DESTDIR. --- Makefile.in | 16 +++++++++++++--- lisp/loadup.el | 44 ++++++++++++++++++++++---------------------- src/Makefile.in | 2 +- src/comp.c | 21 +++++++++++++++++++++ src/comp.h | 2 ++ src/pdumper.c | 15 ++------------- 6 files changed, 61 insertions(+), 39 deletions(-) diff --git a/Makefile.in b/Makefile.in index 253f7f7a54b..a15850d55ef 100644 --- a/Makefile.in +++ b/Makefile.in @@ -108,6 +108,8 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ + # ==================== Where To Install Things ==================== # Location to install Emacs.app under GNUstep / macOS. @@ -330,6 +332,8 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" +ELN_DESTDIR = "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/" + all: ${SUBDIR} info .PHONY: all ${SUBDIR} blessmail epaths-force epaths-force-w32 etc-emacsver @@ -422,7 +426,7 @@ dirstate = .git/logs/HEAD VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate)) src: Makefile $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(DESTDIR)${bindir}/' \ - LISP_DESTDIR='$(DESTDIR)${lispdir}/' all + ELN_DESTDIR='$(ELN_DESTDIR)' all blessmail: Makefile src $(MAKE) -C lib-src maybe-blessmail @@ -462,14 +466,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. @@ -753,6 +757,12 @@ install-etc: done ; \ done +### Install native compiled Lisp files. +install-eln: +ifeq ($(HAVE_NATIVE_COMP),yes) + find eln-cache -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; +endif + ### Build Emacs and install it, stripping binaries while installing them. install-strip: $(MAKE) INSTALL_STRIP=-s install diff --git a/lisp/loadup.el b/lisp/loadup.el index 31843fc24d1..aaa5888bf92 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,33 +449,33 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (native-comp-available-p) +(when (boundp 'comp-ctxt) ;; Fix the compilation unit filename to have it working when ;; when installed or if the source directory got moved. This is set to be ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). (let ((h (make-hash-table :test #'eq)) - (lisp-src-dir (expand-file-name (concat default-directory "../lisp"))) (bin-dest-dir (cadr (member "--bin-dest" command-line-args))) - (lisp-dest-dir (cadr (member "--lisp-dest" command-line-args)))) - (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 _) - (native-comp-unit-set-file - cu - (cons - ;; Relative path from the installed binary. - (file-relative-name - (concat lisp-dest-dir - (replace-regexp-in-string - (regexp-quote lisp-src-dir) "" - (native-comp-unit-file cu))) - bin-dest-dir) - ;; Relative path from the built uninstalled binary. - (file-relative-name (native-comp-unit-file cu) - invocation-directory)))) - h))) + (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 "eln-cache/" comp-native-path-postfix "/")) + (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 _) + (native-comp-unit-set-file + cu + (cons + ;; Relative path from the installed binary. + (file-relative-name (concat eln-dest-dir + (file-name-nondirectory + (native-comp-unit-file cu))) + bin-dest-dir) + ;; Relative path from the built uninstalled binary. + (file-relative-name (native-comp-unit-file cu) + invocation-directory)))) + h)))) (when (hash-table-p purify-flag) (let ((strings 0) diff --git a/src/Makefile.in b/src/Makefile.in index 7380a87644b..31a5a7e7709 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -587,7 +587,7 @@ endif ifeq ($(DUMPING),pdumper) $(pdmp): emacs$(EXEEXT) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ - --bin-dest $(BIN_DESTDIR) --lisp-dest $(LISP_DESTDIR) + --bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR) cp -f $@ $(bootstrap_pdmp) endif diff --git a/src/comp.c b/src/comp.c index b795afae351..d42bb4f8eb5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4529,6 +4529,27 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Functions used to load eln files. */ /**************************************/ +/* Fixup the system eln-cache dir. This is the last entry in + `comp-eln-load-path'. */ +void +fixup_eln_load_path (Lisp_Object directory) +{ + Lisp_Object last_cell = Qnil; + Lisp_Object tmp = Vcomp_eln_load_path; + FOR_EACH_TAIL (tmp) + if (CONSP (tmp)) + last_cell = tmp; + + Lisp_Object eln_cache_sys = + Ffile_name_directory (concat2 (Vinvocation_directory, + directory)); + /* One directory up... */ + eln_cache_sys = + Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, + make_fixnum (-1))); + Fsetcar (last_cell, eln_cache_sys); +} + typedef char *(*comp_lit_str_func) (void); /* Deserialize read and return static object. */ diff --git a/src/comp.h b/src/comp.h index 687e426b1ef..9270f8bf664 100644 --- a/src/comp.h +++ b/src/comp.h @@ -101,6 +101,8 @@ extern void dispose_all_remaining_comp_units (void); extern void clean_package_user_dir_of_old_comp_units (void); +extern void fixup_eln_load_path (Lisp_Object directory); + #else /* #ifdef HAVE_NATIVE_COMP */ static inline void diff --git a/src/pdumper.c b/src/pdumper.c index ca055a1327c..8172389a49b 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5249,23 +5249,12 @@ dump_do_dump_relocation (const uintptr_t dump_base, { fclose (file); installation_state = INSTALLED; - /* FIXME Vcomp_eln_load_path = ?? */ + fixup_eln_load_path (XCAR (comp_u->file)); } else { installation_state = LOCAL_BUILD; - /* Fixup `comp-eln-load-path' so emacs can be invoked - position independently. */ - Lisp_Object eln_cache_sys = - Ffile_name_directory (concat2 (Vinvocation_directory, - XCDR (comp_u->file))); - /* One directory up... */ - eln_cache_sys = - Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, - make_fixnum (-1))); - /* FIXME for subsequent dumps we should fixup only the - last entry. */ - Vcomp_eln_load_path = Fcons (eln_cache_sys, Qnil); + fixup_eln_load_path (XCDR (comp_u->file)); } } From da54406077c5facd7187aa17c9b4f5f4ddf0e233 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Aug 2020 14:33:25 +0200 Subject: [PATCH 0997/1452] Allow for native compiling .el.gz files This is needed for installed instances compiled with NATIVE_FAST_BOOT * src/comp.c (maybe_defer_native_compilation): Search for .el.gz too as a source if the .el is not found. (Fcomp_el_to_eln_filename): Remove the .gz in case to generate the hash. * lisp/emacs-lisp/comp.el (comp-valid-source-re): New defconst. (comp-run-async-workers, native-compile-async): Make use of `comp-valid-source-re'. --- lisp/emacs-lisp/comp.el | 9 ++++++--- src/comp.c | 8 +++++++- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5ab4ebdccb..85b5562f280 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -137,6 +137,9 @@ before compilation. Usable to modify the compiler environment." (defvar comp-dry-run nil "When non nil run everything but the C back-end.") +(defconst comp-valid-source-re (rx ".el" (? ".gz") eos) + "Regexp to match filename of valid input source files.") + (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -2564,7 +2567,7 @@ display a message." (cl-loop for (source-file . load) = (pop comp-files-queue) while source-file - do (cl-assert (string-match-p (rx ".el" eos) source-file) nil + do (cl-assert (string-match-p comp-valid-source-re source-file) nil "`comp-files-queue' should be \".el\" files: %s" source-file) when (or comp-always-compile @@ -2724,8 +2727,8 @@ LOAD can be nil t or 'late." (dolist (path paths) (cond ((file-directory-p path) (dolist (file (if recursively - (directory-files-recursively path (rx ".el" eos)) - (directory-files path t (rx ".el" eos)))) + (directory-files-recursively path comp-valid-source-re) + (directory-files path t comp-valid-source-re))) (push file files))) ((file-exists-p path) (push path files)) (t (signal 'native-compiler-error diff --git a/src/comp.c b/src/comp.c index d42bb4f8eb5..f4111e2a291 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3867,6 +3867,8 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object file_name, Lisp_Object base_dir) { CHECK_STRING (file_name); + if (suffix_p (file_name, ".gz")) + file_name = Fsubstring (file_name, Qnil, make_fixnum (-3)); file_name = Fexpand_file_name (file_name, Qnil); Lisp_Object hashed = Fsubstring (comp_hash_string (file_name), Qnil, make_fixnum (ELN_FILENAME_HASH_LEN)); @@ -4494,7 +4496,11 @@ maybe_defer_native_compilation (Lisp_Object function_name, concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name), build_pure_c_string (".el")); if (NILP (Ffile_exists_p (src))) - return; + { + src = concat2 (src, build_pure_c_string (".gz")); + if (NILP (Ffile_exists_p (src))) + return; + } /* This is to have deferred compilaiton able to compile comp dependecies breaking circularity. */ From 40de06390d2cb594434ae4326b659522501882e2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Aug 2020 16:40:03 +0200 Subject: [PATCH 0998/1452] * Remove a false permission related error while native compiling * lisp/emacs-lisp/bytecomp.el (byte-compile-file): Do not crash if native compiling we have no permission to create the .elc file. We are not creating it. --- lisp/emacs-lisp/bytecomp.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 20a481a8a1c..507cfe76ffa 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2041,7 +2041,8 @@ The value is non-nil if there were no errors, nil if errors." (with-current-buffer output-buffer (goto-char (point-max)) (insert "\n") ; aaah, unix. - (if (file-writable-p target-file) + (if (or (file-writable-p target-file) + byte-native-compiling) ;; We must disable any code conversion here. (progn (let* ((coding-system-for-write 'no-conversion) @@ -2050,7 +2051,8 @@ The value is non-nil if there were no errors, nil if errors." ;; 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)) From 142cfe942f9263efd6adab5f51f2feab4740735f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Aug 2020 20:40:44 +0200 Subject: [PATCH 0999/1452] * Introduce `load-no-native' Given load loads automatically a .eln in place of a .elc we need a way to force the .elc load in the case we really want it. * src/lread.c (syms_of_lread): Define `load-no-native'. (maybe_swap_for_eln): Make use of. --- src/lread.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index c5bec0633df..521da4e1d81 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1615,7 +1615,8 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) #ifdef HAVE_NATIVE_COMP struct stat eln_st; - if (!suffix_p (*filename, ".elc")) + if (load_no_native + || !suffix_p (*filename, ".elc")) return; /* Search eln in the eln-cache directories. */ @@ -5156,6 +5157,11 @@ 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: /* Do not try to load the a .eln file in place of + a .elc one. */); + load_no_native = false; + /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); From 114b1d8f905edfeb7bd81b6a69c707336c01cde0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 16 Aug 2020 20:44:56 +0200 Subject: [PATCH 1000/1452] * test/src/comp-tests.el (comp-tests-bootstrap): Fix test for new eln setup. --- test/src/comp-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 092504565a6..33b307b1c6e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -54,7 +54,8 @@ Check that the resulting binaries do not differ." (comp-debug 0)) (copy-file comp-src comp1-src t) (copy-file comp-src comp2-src t) - (load (concat comp-src "c") nil nil t t) + (let ((load-no-native t)) + (load (concat comp-src "c") nil nil t t)) (should-not (subr-native-elisp-p (symbol-function #'native-compile))) (message "Compiling stage1...") (let ((comp1-eln (native-compile comp1-src))) From 76faab27cf4055f6ac37b9b05c98bc03939afb7e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 17 Aug 2020 11:54:55 +0200 Subject: [PATCH 1001/1452] * Improve eln filename hashing Make eln filename hashing logic insensitive to the installation process. * src/comp.c (epaths.h): New include to have PATH_DUMPLOADSEARCH, PATH_LOADSEARCH definitions. (loadsearch_re_list): New static var. (Fcomp_el_to_eln_filename): Update logic to have the eln hashing insensitive to the installation process. (syms_of_comp): GC protect 'loadsearch_re_list'. --- src/comp.c | 62 +++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 52 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index f4111e2a291..ff73245b8de 100644 --- a/src/comp.c +++ b/src/comp.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include "puresize.h" #include "window.h" @@ -3860,29 +3861,68 @@ compile_function (Lisp_Object func) /* Entry points exposed to lisp. */ /**********************************/ +/* In use by Fcomp_el_to_eln_filename. */ +static Lisp_Object loadsearch_re_list; + DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, doc: /* Given a source file return the corresponding .eln true filename. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) - (Lisp_Object file_name, Lisp_Object base_dir) + (Lisp_Object filename, Lisp_Object base_dir) { - CHECK_STRING (file_name); - if (suffix_p (file_name, ".gz")) - file_name = Fsubstring (file_name, Qnil, make_fixnum (-3)); - file_name = Fexpand_file_name (file_name, Qnil); - Lisp_Object hashed = Fsubstring (comp_hash_string (file_name), Qnil, - make_fixnum (ELN_FILENAME_HASH_LEN)); - file_name = concat2 (Ffile_name_nondirectory (Fsubstring (file_name, Qnil, + CHECK_STRING (filename); + + if (suffix_p (filename, ".gz")) + filename = Fsubstring (filename, Qnil, make_fixnum (-3)); + filename = Fexpand_file_name (filename, Qnil); + + /* We create eln filenames with an hash in order to look-up these + starting from the source filename, IOW have a relation + /absolute/path/filename.el -> eln-cache/filename-hash.eln. + + As installing .eln files compiled during the build changes their + absolute path we need an hashing mechanism that is not sensitive + to that. For this we replace if match PATH_DUMPLOADSEARCH or + PATH_LOADSEARCH with '//' before generating the hash. + + Another approach would be to hash using the source file content + but this may have a measurable performance impact. */ + + if (NILP (loadsearch_re_list)) + { + Lisp_Object loadsearch_list = + Fcons (build_string (PATH_DUMPLOADSEARCH), + Fcons (build_string (PATH_LOADSEARCH), Qnil)); + FOR_EACH_TAIL (loadsearch_list) + loadsearch_re_list = + Fcons (Fregexp_quote (XCAR (loadsearch_list)), loadsearch_re_list); + } + Lisp_Object loadsearch_res = loadsearch_re_list; + FOR_EACH_TAIL (loadsearch_res) + { + Lisp_Object match_idx = + Fstring_match (XCAR (loadsearch_res), filename, Qnil); + if (EQ (match_idx, make_fixnum (0))) + { + filename = + Freplace_match (build_string ("//"), Qt, Qt, filename, Qnil); + break; + } + } + + Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, + make_fixnum (ELN_FILENAME_HASH_LEN)); + filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), build_string ("-")); - file_name = concat3 (file_name, hashed, build_string (NATIVE_ELISP_SUFFIX)); + filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); if (NILP (base_dir)) base_dir = XCAR (Vcomp_eln_load_path); if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); - return Fexpand_file_name (file_name, + return Fexpand_file_name (filename, concat2 (base_dir, Vcomp_native_path_postfix)); } @@ -5055,6 +5095,8 @@ native compiled one. */); comp.emitter_dispatcher = Qnil; staticpro (&delayed_sources); delayed_sources = Qnil; + staticpro (&loadsearch_re_list); + loadsearch_re_list = Qnil; #ifdef WINDOWSNT staticpro (&all_loaded_comp_units_h); From fc9b68636b1aec69295726d2b3be2b520911f40b Mon Sep 17 00:00:00 2001 From: Andrew Whatson Date: Tue, 18 Aug 2020 11:29:22 +0200 Subject: [PATCH 1002/1452] * Fix async compilation `comp-eln-load-path' effectiveness (bug#42909) * lisp/emacs-lisp/comp.el (comp-run-async-workers): Forward `comp-eln-load-path' to async workers. --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 85b5562f280..3176351b37d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2580,6 +2580,7 @@ display a message." (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose + comp-eln-load-path ',comp-eln-load-path load-path ',load-path) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) From 8a931a97b8dd19a38d6f719f810280a07ba76438 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 19 Aug 2020 15:26:42 +0200 Subject: [PATCH 1003/1452] Fix native code uneffective loads after recompilation 'dlopen' can return the same handle if two shared with the same filename are loaded in two different times (even if the first was deleted!). To prevent this scenario the last modification time of the source file is included in the hashing algorithm. * src/comp.c (Fcomp_el_to_eln_filename): Update hashing algo to include the source last modification date. * src/lread.c (maybe_swap_for_eln): Do not check for eln newer then elc as this is now unnecessary. --- src/comp.c | 19 +++++++++++++++++-- src/lread.c | 20 +++++++------------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/src/comp.c b/src/comp.c index ff73245b8de..a00088bb7f8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3872,13 +3872,26 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); + if (NILP (Ffile_exists_p (filename))) + xsignal1 (Qfile_missing, filename); + + Lisp_Object last_mod_time = + Fnth (make_fixnum (5), Ffile_attributes (filename, Qnil)); + if (suffix_p (filename, ".gz")) filename = Fsubstring (filename, Qnil, make_fixnum (-3)); filename = Fexpand_file_name (filename, Qnil); /* We create eln filenames with an hash in order to look-up these starting from the source filename, IOW have a relation - /absolute/path/filename.el -> eln-cache/filename-hash.eln. + + /absolute/path/filename.el + last_mod_time -> + eln-cache/filename-hash.eln. + + 'dlopen' can return the same handle if two shared with the same + filename are loaded in two different times (even if the first was + deleted!). To prevent this scenario the last modification time + of the source file is included in the hashing algorithm. As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive @@ -3910,7 +3923,9 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) } } - Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, + Lisp_Object hash_input = + concat2 (filename, Fprin1_to_string (last_mod_time, Qnil)); + Lisp_Object hash = Fsubstring (comp_hash_string (hash_input), Qnil, make_fixnum (ELN_FILENAME_HASH_LEN)); filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), diff --git a/src/lread.c b/src/lread.c index 521da4e1d81..6b585fcaccc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1635,19 +1635,13 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) emacs_close (eln_fd); else { - struct timespec eln_mtime = get_stat_mtime (&eln_st); - if (timespec_cmp (eln_mtime, mtime) > 0) - { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - el_name, Vcomp_eln_to_el_h); - return; - } - else - emacs_close (eln_fd); + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + el_name, Vcomp_eln_to_el_h); + return; } } } From bec2adebc6a5c4984d52ea7e66a7a3632e7dc578 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs Date: Sat, 8 Aug 2020 16:22:43 -0400 Subject: [PATCH 1004/1452] Pass driver options to libgccjit where supported Add a customizable variable for driver options (such as linker flags) to pass to libgccjit (Bug #42761). * lisp/emacs-lisp/comp.el (comp-native-driver-options): New customization variable. * src/comp.c: Use comp-native-driver-options to set libgccjit's driver options, if supported on the library's ABI version. --- lisp/emacs-lisp/comp.el | 10 ++++++++++ src/comp.c | 28 ++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3176351b37d..37559c20dd4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -134,6 +134,16 @@ before compilation. Usable to modify the compiler environment." :type 'list :group 'comp) +(defcustom comp-native-driver-options nil + "Options passed verbatim to the native compiler's backend driver. +Note that not all options are meaningful; typically only the options +affecting the assembler and linker are likely to be useful. + +Passing these options is only available in libgccjit version 9 +and above." + :type 'list + :group 'comp) + (defvar comp-dry-run nil "When non nil run everything but the C back-end.") diff --git a/src/comp.c b/src/comp.c index a00088bb7f8..97a56658707 100644 --- a/src/comp.c +++ b/src/comp.c @@ -54,6 +54,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_block_end_with_return #undef gcc_jit_block_end_with_void_return #undef gcc_jit_context_acquire +#undef gcc_jit_context_add_driver_option #undef gcc_jit_context_compile_to_file #undef gcc_jit_context_dump_reproducer_to_file #undef gcc_jit_context_dump_to_file @@ -119,6 +120,8 @@ DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, (gcc_jit_function *func, const char *name)); DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (void, gcc_jit_context_add_driver_option, + (gcc_jit_context *ctxt, const char *optname)); DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, const char *name)); @@ -256,6 +259,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_block_end_with_return); LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); LOAD_DLL_FN (library, gcc_jit_context_acquire); + LOAD_DLL_FN (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); @@ -317,6 +321,7 @@ init_gccjit_functions (void) #define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return #define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return #define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option #define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file #define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file #define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file @@ -4117,6 +4122,26 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +static void +add_driver_options () +{ + Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); + +#ifdef LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option + while (CONSP (options)) + { + gcc_jit_context_add_driver_option (comp.ctxt, SSDATA (XCAR (options))); + options = XCDR (options); + } +#else + if (CONSP (options)) + { + xsignal1 (Qnative_compiler_error, + build_string ("Customizing native compiler options via `comp-native-driver-options' is only available on libgccjit version 9 and above.")); + } +#endif +} + static void restore_sigmask (void) { @@ -4186,6 +4211,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); + add_driver_options (); + if (COMP_DEBUG) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (base_name)), @@ -4992,6 +5019,7 @@ native compiled one. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); + DEFSYM (Qcomp_native_driver_options, "comp-native-driver-options"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); From c818c29771d3cb51875643b2f6c894073e429dd2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 20 Aug 2020 12:36:39 +0200 Subject: [PATCH 1005/1452] Revert "Fix native code uneffective loads after recompilation" (bug#42944) This reverts commit 8a931a97b8dd19a38d6f719f810280a07ba76438. This introduced bug#42944. --- src/comp.c | 19 ++----------------- src/lread.c | 20 +++++++++++++------- 2 files changed, 15 insertions(+), 24 deletions(-) diff --git a/src/comp.c b/src/comp.c index a00088bb7f8..ff73245b8de 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3872,26 +3872,13 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); - if (NILP (Ffile_exists_p (filename))) - xsignal1 (Qfile_missing, filename); - - Lisp_Object last_mod_time = - Fnth (make_fixnum (5), Ffile_attributes (filename, Qnil)); - if (suffix_p (filename, ".gz")) filename = Fsubstring (filename, Qnil, make_fixnum (-3)); filename = Fexpand_file_name (filename, Qnil); /* We create eln filenames with an hash in order to look-up these starting from the source filename, IOW have a relation - - /absolute/path/filename.el + last_mod_time -> - eln-cache/filename-hash.eln. - - 'dlopen' can return the same handle if two shared with the same - filename are loaded in two different times (even if the first was - deleted!). To prevent this scenario the last modification time - of the source file is included in the hashing algorithm. + /absolute/path/filename.el -> eln-cache/filename-hash.eln. As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive @@ -3923,9 +3910,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) } } - Lisp_Object hash_input = - concat2 (filename, Fprin1_to_string (last_mod_time, Qnil)); - Lisp_Object hash = Fsubstring (comp_hash_string (hash_input), Qnil, + Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, make_fixnum (ELN_FILENAME_HASH_LEN)); filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), diff --git a/src/lread.c b/src/lread.c index 6b585fcaccc..521da4e1d81 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1635,13 +1635,19 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) emacs_close (eln_fd); else { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - el_name, Vcomp_eln_to_el_h); - return; + struct timespec eln_mtime = get_stat_mtime (&eln_st); + if (timespec_cmp (eln_mtime, mtime) > 0) + { + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + el_name, Vcomp_eln_to_el_h); + return; + } + else + emacs_close (eln_fd); } } } From 9baa0296aaca6ff1b547817a4eba5d8740ae3e5e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Aug 2020 10:28:17 +0200 Subject: [PATCH 1006/1452] * Import lib/af_alg.h from gnulib * lib/af_alg.h: New file. --- lib/af_alg.h | 115 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) create mode 100644 lib/af_alg.h diff --git a/lib/af_alg.h b/lib/af_alg.h new file mode 100644 index 00000000000..4c5854cc99b --- /dev/null +++ b/lib/af_alg.h @@ -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 . */ + +/* Written by Matteo Croce , 2018. + Documentation by Bruno Haible , 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 +# include + +# 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 */ From 5f5d664c734414597c1c7d9981b1ceb9ff69c5b1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 22 Aug 2020 11:11:21 +0200 Subject: [PATCH 1007/1452] Rework eln hash filename strategy Generate eln filename hashing also the source file content in the form: /absolute/path/filename.el + content -> eln-cache/filename-path_hash-content_hash.eln * src/lread.c (maybe_swap_for_eln): Always call Fcomp_el_to_eln_filename on an existing source file. * src/comp.c (md5.h, sysstdio.h, zlib.h): New include. (comp_hash_string): Use md5 instead of sha512. (MD5_BLOCKSIZE): New macro. (accumulate_and_process_md5, final_process_md5, md5_gz_stream) (comp_hash_source_file): New functions. (Fcomp_el_to_eln_filename): Rework for hasing using also source file content. * src/lread.c (maybe_swap_for_eln): Rename el_name -> src_name as this can be also a have .el.gz extention. --- configure.ac | 9 ++- lib/Makefile.in | 6 ++ src/comp.c | 161 +++++++++++++++++++++++++++++++++++++++++++----- src/lread.c | 13 +++- 4 files changed, 167 insertions(+), 22 deletions(-) diff --git a/configure.ac b/configure.ac index 0582b2f61c5..cdc18eab19e 100644 --- a/configure.ac +++ b/configure.ac @@ -3787,6 +3787,12 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= if test "${with_nativecomp}" != "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 emacs_save_LIBS=$LIBS LIBS="-lgccjit" AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], @@ -3800,9 +3806,6 @@ if test "${with_nativecomp}" != "no"; then NEED_DYNLIB=yes AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) fi -if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then - AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) -fi AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) diff --git a/lib/Makefile.in b/lib/Makefile.in index 06d8e56421b..8d97d3bcfbb 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -50,12 +50,18 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = +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 diff --git a/src/comp.c b/src/comp.c index ff73245b8de..5f1257f6be1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -36,7 +36,9 @@ along with GNU Emacs. If not, see . */ #include "dynlib.h" #include "buffer.h" #include "blockinput.h" -#include "sha512.h" +#include "md5.h" +#include "sysstdio.h" +#include "zlib.h" /********************************/ @@ -394,8 +396,6 @@ load_gccjit_if_necessary (bool mandatory) } -#define ELN_FILENAME_HASH_LEN 64 - /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -640,9 +640,123 @@ format_string (const char *format, ...) static Lisp_Object comp_hash_string (Lisp_Object string) { - Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); - sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); - hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); + md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); + + return digest; +} + +#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 I'll not 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; + } +} + +static int +md5_gz_stream (FILE *source, void *resblock) +{ + z_stream stream; + unsigned char in[MD5_BLOCKSIZE]; + unsigned char out[MD5_BLOCKSIZE]; + + 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 + +static Lisp_Object +comp_hash_source_file (Lisp_Object filename) +{ + /* Can't use Finsert_file_contents + Fbuffer_hash as this is called + by Fcomp_el_to_eln_filename too early during bootstrap. */ + bool is_gz = suffix_p (filename, ".gz"); + FILE *f = emacs_fopen (SSDATA (filename), is_gz ? "rb" : "r"); + + if (!f) + report_file_error ("Opening source file", filename); + + Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); + + int res = is_gz + ? md5_gz_stream (f, SSDATA (digest)) + : md5_stream (f, SSDATA (digest)); + fclose (f); + + if (res) + xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename); + + hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE); return digest; } @@ -3872,21 +3986,36 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); + filename = Fexpand_file_name (filename, Qnil); + + if (NILP (Ffile_exists_p (filename))) + xsignal1 (Qfile_missing, filename); + + Lisp_Object content_hash = comp_hash_source_file (filename); + if (suffix_p (filename, ".gz")) filename = Fsubstring (filename, Qnil, make_fixnum (-3)); - filename = Fexpand_file_name (filename, Qnil); /* We create eln filenames with an hash in order to look-up these starting from the source filename, IOW have a relation - /absolute/path/filename.el -> eln-cache/filename-hash.eln. + + /absolute/path/filename.el + content -> + eln-cache/filename-path_hash-content_hash.eln. + + 'dlopen' can return the same handle if two shared with the same + filename are loaded in two different times (even if the first was + deleted!). To prevent this scenario the source file content is + included in the hashing algorithm. + + As at any point in time no more then one file can exist with the + same filename, should be possibile to clean up all + filename-path_hash-* except the most recent one (or the new one + being recompiled). As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive to that. For this we replace if match PATH_DUMPLOADSEARCH or - PATH_LOADSEARCH with '//' before generating the hash. - - Another approach would be to hash using the source file content - but this may have a measurable performance impact. */ + PATH_LOADSEARCH with '//' before generating the hash. */ if (NILP (loadsearch_re_list)) { @@ -3909,12 +4038,12 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) break; } } - - Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, - make_fixnum (ELN_FILENAME_HASH_LEN)); + Lisp_Object separator = build_string ("-"); + Lisp_Object path_hash = comp_hash_string (filename); filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), - build_string ("-")); + separator); + Lisp_Object hash = concat3 (path_hash, separator, content_hash); filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); if (NILP (base_dir)) base_dir = XCAR (Vcomp_eln_load_path); diff --git a/src/lread.c b/src/lread.c index 521da4e1d81..3d0de495605 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1623,10 +1623,17 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) Lisp_Object eln_path_tail = Vcomp_eln_load_path; FOR_EACH_TAIL_SAFE (eln_path_tail) { - Lisp_Object el_name = + 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))) + /* Can't find the corresponding source file. */ + return; + } Lisp_Object eln_name = - Fcomp_el_to_eln_filename (el_name, XCAR (eln_path_tail)); + Fcomp_el_to_eln_filename (src_name, XCAR (eln_path_tail)); int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); if (eln_fd > 0) @@ -1643,7 +1650,7 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) *fd = eln_fd; /* Store the eln -> el relation. */ Fputhash (Ffile_name_nondirectory (eln_name), - el_name, Vcomp_eln_to_el_h); + src_name, Vcomp_eln_to_el_h); return; } else From 6088d199595d102ad6701512560322e74e181d27 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Aug 2020 11:31:31 +0200 Subject: [PATCH 1008/1452] * A cc-mode fix to be compiled correctly once installed * lisp/progmodes/cc-bytecomp.el (cc-bytecomp-load): If cc-mode is not compiled during the initial build (read NATIVE_FAST_BOOT) it will be when already in el.gz form. --- lisp/progmodes/cc-bytecomp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 5eb8af25343..ad884288a6d 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -286,7 +286,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) From 337367a733e107df1ecb89955f0a249491bc62d9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 23 Aug 2020 12:36:07 +0200 Subject: [PATCH 1009/1452] * lisp/emacs-lisp/comp.el (native-compile): Fix free function compilation. --- lisp/emacs-lisp/comp.el | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3176351b37d..28dbd567474 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2654,11 +2654,11 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output (comp-el-to-eln-filename (if (symbolp function-or-file) - (symbol-name function-or-file) - function-or-file) - (when byte-native-for-bootstrap - (car (last comp-eln-load-path)))) + :output (if (symbolp function-or-file) + (make-temp-file (symbol-name function-or-file) nil ".eln") + (comp-el-to-eln-filename function-or-file + (when byte-native-for-bootstrap + (car (last comp-eln-load-path))))) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err From 2772e835b61774ca83cbd2bf79c2534b2d1c6f49 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs Date: Mon, 10 Aug 2020 09:48:57 -0400 Subject: [PATCH 1010/1452] Set native driver options in async compiles, also Ensure the variable is set to the value that was customized in the parent process in child compilation processes, also. --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 37559c20dd4..75c51b03ec8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2591,6 +2591,8 @@ display a message." comp-debug ,comp-debug comp-verbose ,comp-verbose comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options load-path ',load-path) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) From c00aedb4a591fc19818ad28846b7cf03c744a730 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs Date: Wed, 19 Aug 2020 08:16:50 -0400 Subject: [PATCH 1011/1452] Fix windows NT handling for [...]_add_driver_options * Instead of conditionalizing on the wrong preprocessor flag, now use the right one: LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option * Also perform the driver-option-adding step on win NT, but only if the function is non-NULL. * Make the function declaration for add_driver_options non-old-style. --- src/comp.c | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 97a56658707..03409cba0cd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4123,23 +4123,34 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, } static void -add_driver_options () +add_driver_options (void) { Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); -#ifdef LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option - while (CONSP (options)) +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + || defined (WINDOWSNT) +#pragma GCC diagnostic ignored "-Waddress" + if (gcc_jit_context_add_driver_option) { - gcc_jit_context_add_driver_option (comp.ctxt, SSDATA (XCAR (options))); - options = XCDR (options); + while (CONSP (options)) + { + gcc_jit_context_add_driver_option (comp.ctxt, + SSDATA (XCAR (options))); + options = XCDR (options); + } + + return; } -#else +#pragma GCC diagnostic pop +#endif if (CONSP (options)) { xsignal1 (Qnative_compiler_error, - build_string ("Customizing native compiler options via `comp-native-driver-options' is only available on libgccjit version 9 and above.")); + build_string ("Customizing native compiler options" + " via `comp-native-driver-options' is" + " only available on libgccjit version 9" + " and above.")); } -#endif } static void From 1f105d5554e37a0c4994806a0f910c6686f2014d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 19 Aug 2020 17:47:37 +0200 Subject: [PATCH 1012/1452] * Improve 'add_driver_options' * src/comp.c (add_driver_options): Use load_gccjit_if_necessary and FOR_EACH_TAIL + GNU style. --- src/comp.c | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/src/comp.c b/src/comp.c index 03409cba0cd..6cde761f761 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4130,27 +4130,19 @@ add_driver_options (void) #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) #pragma GCC diagnostic ignored "-Waddress" - if (gcc_jit_context_add_driver_option) - { - while (CONSP (options)) - { - gcc_jit_context_add_driver_option (comp.ctxt, - SSDATA (XCAR (options))); - options = XCDR (options); - } - - return; - } + load_gccjit_if_necessary (true); + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + SSDATA (XCAR (options))); + return; #pragma GCC diagnostic pop #endif if (CONSP (options)) - { - xsignal1 (Qnative_compiler_error, - build_string ("Customizing native compiler options" - " via `comp-native-driver-options' is" - " only available on libgccjit version 9" - " and above.")); - } + xsignal1 (Qnative_compiler_error, + build_string ("Customizing native compiler options" + " via `comp-native-driver-options' is" + " only available on libgccjit version 9" + " and above.")); } static void From c17013ae766d7d3dd79122e1ee99d3f2ec4d9f04 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs Date: Thu, 20 Aug 2020 21:05:37 -0400 Subject: [PATCH 1013/1452] * Add 'comp-native-driver-options-available-p' * src/comp.c (comp-native-driver-options-available-p): New function that returns t if driver options can be used. --- src/comp.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/comp.c b/src/comp.c index 6cde761f761..5bfbfbaf3c9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4122,6 +4122,23 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +DEFUN ("comp-native-driver-options-available-p", Fcomp_native_driver_options_available_p, + Scomp_native_driver_options_available_p, + 0, 0, 0, + doc: /* Return t if `comp-native-driver-options' can be used. */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + || defined (WINDOWSNT) +#pragma GCC diagnostic ignored "-Waddress" + if (gcc_jit_context_add_driver_option) + return Qt; +#pragma GCC diagnostic pop +#endif + return Qnil; +} + + static void add_driver_options (void) { @@ -5123,6 +5140,7 @@ native compiled one. */); "configuration, please recompile")); defsubr (&Scomp_el_to_eln_filename); + defsubr (&Scomp_native_driver_options_available_p); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); From f8321f07ce874e9c7294cdb8e15f8a08ba064aa7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Aug 2020 10:25:36 +0200 Subject: [PATCH 1014/1452] * src/comp.c (add_driver_options): Fix missing condition + clean-up pragma --- src/comp.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5bfbfbaf3c9..7f6bbe395b5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4146,13 +4146,12 @@ add_driver_options (void) #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) -#pragma GCC diagnostic ignored "-Waddress" load_gccjit_if_necessary (true); - FOR_EACH_TAIL (options) - gcc_jit_context_add_driver_option (comp.ctxt, - SSDATA (XCAR (options))); + if (!NILP (Fcomp_native_driver_options_available_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + SSDATA (XCAR (options))); return; -#pragma GCC diagnostic pop #endif if (CONSP (options)) xsignal1 (Qnative_compiler_error, From 63f041c0a467e49599facf8a6992dcc20ef71eaf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Aug 2020 10:27:40 +0200 Subject: [PATCH 1015/1452] * Rename comp-native-driver-options-available-p * src/comp.c (Fcomp_native_driver_options_effective_p) Rename plus better doc. (add_driver_options, syms_of_comp): Rename `comp-native-driver-options-available-p' into comp-native-driver-options-effective-p. --- src/comp.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/comp.c b/src/comp.c index 7f6bbe395b5..a553a4bc7e3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4122,10 +4122,12 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } -DEFUN ("comp-native-driver-options-available-p", Fcomp_native_driver_options_available_p, - Scomp_native_driver_options_available_p, +DEFUN ("comp-native-driver-options-effective-p", + Fcomp_native_driver_options_effective_p, + Scomp_native_driver_options_effective_p, 0, 0, 0, - doc: /* Return t if `comp-native-driver-options' can be used. */) + doc: /* Return t if `comp-native-driver-options' is + effective nil otherwise. */) (void) { #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ @@ -4147,7 +4149,7 @@ add_driver_options (void) #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) load_gccjit_if_necessary (true); - if (!NILP (Fcomp_native_driver_options_available_p ())) + if (!NILP (Fcomp_native_driver_options_effective_p ())) FOR_EACH_TAIL (options) gcc_jit_context_add_driver_option (comp.ctxt, SSDATA (XCAR (options))); @@ -5139,7 +5141,7 @@ native compiled one. */); "configuration, please recompile")); defsubr (&Scomp_el_to_eln_filename); - defsubr (&Scomp_native_driver_options_available_p); + defsubr (&Scomp_native_driver_options_effective_p); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); From 51acfeef6a5cf4dce2c80f56fbe0d8b0aa3d660c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 24 Aug 2020 10:28:59 +0200 Subject: [PATCH 1016/1452] * Init gcc_jit_context_add_driver_option as optional * src/comp.c (init_gccjit_functions): Use LOAD_DLL_FN_OPT to init 'gcc_jit_context_add_driver_option' as this is optional. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index a553a4bc7e3..e6fa10cf553 100644 --- a/src/comp.c +++ b/src/comp.c @@ -259,7 +259,6 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_block_end_with_return); LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); LOAD_DLL_FN (library, gcc_jit_context_acquire); - LOAD_DLL_FN (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); @@ -305,6 +304,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN_OPT (library, gcc_jit_version_major); LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); From 696ab2eb17cf8850a65814f428287848b7d23d64 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 28 Aug 2020 18:37:44 +0200 Subject: [PATCH 1017/1452] * src/lread.c (Fload): Bind load-file-name to the .elc filename. --- src/lread.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/lread.c b/src/lread.c index 3d0de495605..5b77868a63b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1477,8 +1477,10 @@ Return t if the file exists and loads successfully. */) same folder of their respective sources therfore not to break packages we fake `load-file-name' here. The non faked version of it is `load-true-file-name'. */ - specbind (Qload_file_name, Fgethash (Ffile_name_nondirectory (found), - Vcomp_eln_to_el_h, Qnil)); + Lisp_Object el_name = Fgethash (Ffile_name_nondirectory (found), + Vcomp_eln_to_el_h, Qnil); + specbind (Qload_file_name, + NILP (el_name) ? Qnil : concat2 (el_name, build_string ("c"))); } else specbind (Qload_file_name, found); From 38b0ead7c1a8475bef7f811b07beed2c23cbc593 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Aug 2020 10:15:55 +0200 Subject: [PATCH 1018/1452] * Back using `load-file-name' when reading '#$' (bug#42961) * src/lread.c (read1, read_list): Use again load-file-name when reading '#$'. (syms_of_lread): Update `load-file-name' doc. --- src/lread.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/lread.c b/src/lread.c index 5b77868a63b..326af307f9c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3261,7 +3261,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; } if (c == '$') - return Vload_true_file_name; + return Vload_file_name; if (c == '\'') return list2 (Qfunction, read0 (readcharfun)); /* #:foo is the uninterned symbol named foo. */ @@ -4062,7 +4062,7 @@ read_list (bool flag, Lisp_Object readcharfun) first_in_list = 0; /* While building, if the list starts with #$, treat it specially. */ - if (EQ (elt, Vload_true_file_name) + if (EQ (elt, Vload_file_name) && ! NILP (elt) && !NILP (Vpurify_flag)) { @@ -4083,7 +4083,7 @@ read_list (bool flag, Lisp_Object readcharfun) elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); } } - else if (EQ (elt, Vload_true_file_name) + else if (EQ (elt, Vload_file_name) && ! NILP (elt) && load_force_doc_strings) doc_reference = 2; @@ -5039,8 +5039,10 @@ directory. These file names are converted to absolute at startup. */); DEFVAR_LISP ("load-file-name", Vload_file_name, doc: /* Full name of file being loaded by `load'. -In case a .eln file is being loaded this is unreliable and `load-true-file-name' -should be used instead. */); + +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, From 87b9c3e71840f480c2ce05eb51d71156790a5434 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Aug 2020 11:29:01 +0200 Subject: [PATCH 1019/1452] Have .elc files in `load-history' when loading native code (bug#43089) * src/lread.c (Fload): Add the corresponding .elc file to `load-history' when loading native code. * lisp/subr.el (eval-after-load): Use `load-file-name' instead of `load-true-file-name'. --- lisp/subr.el | 4 ++-- src/lread.c | 24 +++++++++++++++--------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index 6e866015509..b020d09280a 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4613,10 +4613,10 @@ This function makes or adds to an entry on `after-load-alist'." ;; So add an indirection to make sure that `func' is really run ;; "after-load" in case the provide call happens early. (lambda () - (if (not load-true-file-name) + (if (not load-file-name) ;; Not being provided from a file, run func right now. (funcall func) - (let ((lfn load-true-file-name) + (let ((lfn load-file-name) ;; Don't use letrec, because equal (in ;; add/remove-hook) would get trapped in a cycle. (fun (make-symbol "eval-after-load-helper"))) diff --git a/src/lread.c b/src/lread.c index 326af307f9c..ac5b2838eef 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1322,10 +1322,23 @@ Return t if the file exists and loads successfully. */) specbind (Qlexical_binding, Qnil); /* Get the name for load-history. */ + Lisp_Object found_for_hist; + if (is_native_elisp) + { + /* Reconstruct the .elc filename. */ + Lisp_Object src_name = Fgethash (Ffile_name_nondirectory (found), + Vcomp_eln_to_el_h, Qnil); + if (suffix_p (src_name, "el.gz")) + src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); + found_for_hist = concat2 (src_name, build_string ("c")); + } + else + found_for_hist = found; + hist_file_name = (! NILP (Vpurify_flag) ? concat2 (Ffile_name_directory (file), - Ffile_name_nondirectory (found)) - : found) ; + Ffile_name_nondirectory (found_for_hist)) + : found_for_hist); version = -1; @@ -1504,13 +1517,6 @@ Return t if the file exists and loads successfully. */) { #ifdef HAVE_NATIVE_COMP specbind (Qcurrent_load_list, Qnil); - if (!NILP (Vpurify_flag)) - { - Lisp_Object base = concat2 (parent_directory (Vinvocation_directory), - build_string ("lisp/")); - Lisp_Object offset = Flength (base); - hist_file_name = Fsubstring (found, offset, Qnil); - } LOADHIST_ATTACH (hist_file_name); Fnative_elisp_load (found, Qnil); build_load_history (hist_file_name, true); From 59a40b0d75526c973b5bdd25c41824879aafa515 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Aug 2020 15:10:37 +0200 Subject: [PATCH 1020/1452] * lisp/startup.el (command-line): Clean-up logic for new .eln disposition. --- lisp/startup.el | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/lisp/startup.el b/lisp/startup.el index 0a81c878af8..e39df7568ca 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1059,12 +1059,7 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir - (file-truename - (if (string-match "\\.eln\\'" simple-file-name) - (expand-file-name - (concat (file-name-directory simple-file-name) "../")) - (file-name-directory simple-file-name)))) + (setq lisp-dir (file-truename (file-name-directory simple-file-name))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) From ea35a62e6e200f00e22828a7d0994ee2a4d2fc6a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 29 Aug 2020 15:15:46 +0200 Subject: [PATCH 1021/1452] * test/src/comp-tests.el (comp-tests-doc): Update test. --- test/src/comp-tests.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 33b307b1c6e..2a078be8cb0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -322,7 +322,9 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-doc () (should (string= (documentation #'comp-tests-doc-f) "A nice docstring")) - (should (string-match "\\.*.eln\\'" (symbol-file #'comp-tests-doc-f)))) + ;; Check a preloaded function, we can't use `comp-tests-doc-f' now + ;; as this is loaded manually with no .elc. + (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) (ert-deftest comp-test-interactive-form () (should (equal (interactive-form #'comp-test-interactive-form0-f) From bce9cad4213f9af8be08311ac2b93add5c93a997 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 30 Aug 2020 10:23:49 +0200 Subject: [PATCH 1022/1452] * Store raw documentation during native compilation (bug#42974) * lisp/emacs-lisp/comp.el (comp-spill-lap-function) (comp-intern-func-in-ctxt): Use raw documentation. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 238bdcd5dbd..84b5a8bc873 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -671,7 +671,7 @@ clashes." (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name :c-name c-name - :doc (documentation f) + :doc (documentation f t) :int-spec (interactive-form f) :speed (comp-spill-speed function-name) :pure (comp-spill-decl-spec function-name @@ -720,7 +720,7 @@ clashes." (make-comp-func-d :lambda-list (aref byte-func 0))))) (setf (comp-func-name func) name (comp-func-byte-func func) byte-func - (comp-func-doc func) (documentation byte-func) + (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap From c6f42387e32a4e99cd9ddd203ab51f3c5694054e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 31 Aug 2020 22:06:49 +0200 Subject: [PATCH 1023/1452] Fix describe function arglist for native compiled lisp/d (bug#42572) * lisp/help.el (help-function-arglist): Handle the case of native compiled lisp/d. * src/data.c (syms_of_data): Register new subrs. (Fsubr_native_dyn_p, Fsubr_native_lambda_list): New primitives. * test/src/comp-tests.el (comp-tests-dynamic-help-arglist): New test. --- lisp/help.el | 1 + src/data.c | 29 +++++++++++++++++++++++++++-- test/src/comp-tests.el | 7 +++++++ 3 files changed, 35 insertions(+), 2 deletions(-) diff --git a/lisp/help.el b/lisp/help.el index 1b0149616f2..01817ab95db 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1337,6 +1337,7 @@ 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)) + ((subr-native-dyn-p 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 diff --git a/src/data.c b/src/data.c index 33711368f13..b7955932b85 100644 --- a/src/data.c +++ b/src/data.c @@ -875,14 +875,37 @@ SUBR must be a built-in function. */) } 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. */) + 0, doc: /* Return t if the object is native compiled lisp +function, nil otherwise. */) (Lisp_Object object) { return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } #ifdef HAVE_NATIVE_COMP + +DEFUN ("subr-native-dyn-p", Fsubr_native_dyn_p, + Ssubr_native_dyn_p, 1, 1, 0, + doc: /* Return t if the subr is native compiled lisp/d +function, nil otherwise. */) + (Lisp_Object subr) +{ + return SUBR_NATIVE_COMPILED_DYNP (subr) ? Qt : Qnil; +} + +DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, + Ssubr_native_lambda_list, 1, 1, 0, + doc: /* Return the lambda list of native compiled lisp/d +function. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + + return SUBR_NATIVE_COMPILED_DYNP (subr) + ? XSUBR (subr)->lambda_list[0] + : Qnil; +} + DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) @@ -4028,6 +4051,8 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); #ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_dyn_p); + defsubr (&Ssubr_native_lambda_list); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2a078be8cb0..b147bd6789c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -582,6 +582,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) +(ert-deftest comp-tests-dynamic-help-arglist () + "Test `help-function-arglist' works on lisp/d (bug#42572)." + (should (equal (help-function-arglist + (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + t) + '(a b &optional c &rest d)))) + (ert-deftest comp-tests-cl-macro-exp () "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) From ba0a61d10a5aedaf4b7bb61aa3626f385d6aba12 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 31 Aug 2020 22:21:22 +0200 Subject: [PATCH 1024/1452] * src/lread.c (Fload): Fix for manual eln load. --- src/lread.c | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/lread.c b/src/lread.c index ac5b2838eef..80d36f571c2 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1328,9 +1328,15 @@ Return t if the file exists and loads successfully. */) /* Reconstruct the .elc filename. */ Lisp_Object src_name = Fgethash (Ffile_name_nondirectory (found), Vcomp_eln_to_el_h, Qnil); - if (suffix_p (src_name, "el.gz")) - src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); - found_for_hist = concat2 (src_name, build_string ("c")); + if (NILP (src_name)) + /* Manual eln load. */ + found_for_hist = found; + else + { + if (suffix_p (src_name, "el.gz")) + src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); + found_for_hist = concat2 (src_name, build_string ("c")); + } } else found_for_hist = found; From 78e8f991542160239049a50386ced50e456dc5c4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 1 Sep 2020 10:28:29 +0200 Subject: [PATCH 1025/1452] Rework native compiled lisp/d lambda list accessor * lisp/help.el (help-function-arglist): Logic update for new 'Fsubr_native_lambda_list'. * src/data.c (Fsubr_native_dyn_p): Remove. (Fsubr_native_lambda_list): Return t when the input is not a compiled lisp/d subr. (syms_of_data): Update for 'Fsubr_native_dyn_p' removal. --- lisp/help.el | 3 ++- src/data.c | 16 +++------------- 2 files changed, 5 insertions(+), 14 deletions(-) diff --git a/lisp/help.el b/lisp/help.el index 01817ab95db..897ab4a425d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1337,7 +1337,8 @@ 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)) - ((subr-native-dyn-p def) (subr-native-lambda-list def)) + ((and (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 diff --git a/src/data.c b/src/data.c index b7955932b85..0acae67b2a8 100644 --- a/src/data.c +++ b/src/data.c @@ -884,26 +884,17 @@ function, nil otherwise. */) #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-dyn-p", Fsubr_native_dyn_p, - Ssubr_native_dyn_p, 1, 1, 0, - doc: /* Return t if the subr is native compiled lisp/d -function, nil otherwise. */) - (Lisp_Object subr) -{ - return SUBR_NATIVE_COMPILED_DYNP (subr) ? Qt : Qnil; -} - DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, Ssubr_native_lambda_list, 1, 1, 0, - doc: /* Return the lambda list of native compiled lisp/d -function. */) + 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] - : Qnil; + : Qt; } DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -4051,7 +4042,6 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); #ifdef HAVE_NATIVE_COMP - defsubr (&Ssubr_native_dyn_p); defsubr (&Ssubr_native_lambda_list); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); From 3023eb569213a3dd5183640f6e322acd00ea536a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 1 Sep 2020 20:04:00 +0200 Subject: [PATCH 1026/1452] * Fix `load-filename' for installed instance (bug#43089) * src/lread.c (parent_directory): Remove function as now unnecessary. (compute_found_effective): New function. (Fload): Make use of 'compute_found_effective' and fix `load-filename' computation. --- src/lread.c | 62 +++++++++++++++++++---------------------------------- 1 file changed, 22 insertions(+), 40 deletions(-) diff --git a/src/lread.c b/src/lread.c index 80d36f571c2..3c226e0b50c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1099,12 +1099,22 @@ close_infile_unwind (void *arg) infile = prev_infile; } -static ATTRIBUTE_UNUSED Lisp_Object -parent_directory (Lisp_Object directory) +/* Compute the filename we want in `load-history' and `load-file-name'. */ + +static Lisp_Object +compute_found_effective (Lisp_Object found) { - return Ffile_name_directory (Fsubstring (directory, - make_fixnum (0), - Fsub1 (Flength (directory)))); + /* 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, @@ -1321,30 +1331,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_for_hist; - if (is_native_elisp) - { - /* 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. */ - found_for_hist = found; - else - { - if (suffix_p (src_name, "el.gz")) - src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); - found_for_hist = concat2 (src_name, build_string ("c")); - } - } - else - found_for_hist = found; + 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_for_hist)) - : found_for_hist); + Ffile_name_nondirectory (found_eff)) + : found_eff); version = -1; @@ -1489,20 +1484,7 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - if (is_native_elisp) - { - /* Many packages use `load-file-name' as a way to obtain the - package location (see bug#40099). .eln files are not in the - same folder of their respective sources therfore not to break - packages we fake `load-file-name' here. The non faked - version of it is `load-true-file-name'. */ - Lisp_Object el_name = Fgethash (Ffile_name_nondirectory (found), - Vcomp_eln_to_el_h, Qnil); - specbind (Qload_file_name, - NILP (el_name) ? Qnil : concat2 (el_name, build_string ("c"))); - } - else - 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); From 67c53691560616598f746491347bd223480e6172 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 4 Sep 2020 11:54:44 +0200 Subject: [PATCH 1027/1452] Rename and move eln system directory Rename eln sys directory into 'native-lisp' and move it from "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/" to "$(DESTDIR)${libdir}/emacs/". Add to the directory name used to disambiguate the eln compatibility the Emacs version to have it more user friendly. * Makefile.in (clean, install-eln): Rename eln-cache into native-lisp. (ELN_DESTDIR): Move from '$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/' to '$(DESTDIR)${libdir}/emacs/'. * lisp/loadup.el: Update for comp-native-path-postfix -> comp-native-version-dir rename. * src/comp.c (syms_of_comp): Rename eln-cache -> native-lisp. (syms_of_comp, Fcomp_el_to_eln_filename): Rename comp-native-path-postfix -> comp-native-version-dir. (hash_native_abi): Rework and add emacs-version to comp-native-version-dir. --- Makefile.in | 6 +++--- lisp/loadup.el | 2 +- src/comp.c | 34 ++++++++++++++++------------------ 3 files changed, 20 insertions(+), 22 deletions(-) diff --git a/Makefile.in b/Makefile.in index a15850d55ef..d42ad9dfa10 100644 --- a/Makefile.in +++ b/Makefile.in @@ -332,7 +332,7 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" -ELN_DESTDIR = "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/" +ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/" all: ${SUBDIR} info @@ -760,7 +760,7 @@ install-etc: ### Install native compiled Lisp files. install-eln: ifeq ($(HAVE_NATIVE_COMP),yes) - find eln-cache -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; + find native-lisp -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; endif ### Build Emacs and install it, stripping binaries while installing them. @@ -873,7 +873,7 @@ clean: $(clean_dirs:=_clean) [ ! -d test ] || $(MAKE) -C test $@ -rm -f ./*.tmp etc/*.tmp* -rm -rf info-dir.* - -rm -rf eln-cache + -rm -rf native-lisp ### 'bootclean' ### Delete all files that need to be remade for a clean bootstrap. diff --git a/lisp/loadup.el b/lisp/loadup.el index aaa5888bf92..5718477ea03 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -458,7 +458,7 @@ lost after dumping"))) (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 "eln-cache/" comp-native-path-postfix "/")) + (concat eln-dest-dir "native-lisp/" comp-native-version-dir "/")) (mapatoms (lambda (s) (let ((f (symbol-function s))) (when (subr-native-elisp-p f) diff --git a/src/comp.c b/src/comp.c index fa5ffadf311..3a56f5f22c6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -771,21 +771,19 @@ comp_hash_source_file (Lisp_Object filename) void hash_native_abi (void) { - Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), - Vcomp_subr_list, build_string (" ")); - Lisp_Object digest = comp_hash_string (string); - /* Check runs once. */ eassert (NILP (Vcomp_abi_hash)); - Vcomp_abi_hash = digest; - /* If 10 characters are usually sufficient for git I guess 16 are - fine for us here. */ - Vcomp_native_path_postfix = - concat2 (Vsystem_configuration, - concat2 (make_string ("-", 1), - Fsubstring_no_properties (Vcomp_abi_hash, - make_fixnum (0), - make_fixnum (16)))); + + Vcomp_abi_hash = + comp_hash_string (Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string (""))); + Lisp_Object separator = build_string ("-"); + Vcomp_native_version_dir = + concat3 (Vemacs_version, + separator, + concat3 (Vsystem_configuration, + separator, + Vcomp_abi_hash)); } static void @@ -4057,7 +4055,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); return Fexpand_file_name (filename, - concat2 (base_dir, Vcomp_native_path_postfix)); + concat2 (base_dir, Vcomp_native_version_dir)); } DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, @@ -5293,9 +5291,9 @@ native compiled one. */); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, doc: /* String signing the ABI exposed to .eln files. */); Vcomp_abi_hash = Qnil; - DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, - doc: /* Postifix to be added to the .eln compilation path. */); - Vcomp_native_path_postfix = Qnil; + DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir, + doc: /* Directory in use to disambiguate eln compatibility. */); + Vcomp_native_version_dir = Qnil; DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, doc: /* Hash table symbol-name -> function-value. For @@ -5316,7 +5314,7 @@ The last directory of this list is assumed to be the system one. */); /* Temporary value in use for boostrap. We can't do better as `invocation-directory' is still unset, will be fixed up during dump reload. */ - Vcomp_eln_load_path = Fcons (build_string ("../eln-cache/"), Qnil); + Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ From eb8742598874d9bd4c84ff54730527c52d29d7ff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Sep 2020 08:08:19 +0200 Subject: [PATCH 1028/1452] * Makefile.in (ELN_DESTDIR): Add ${version}/ to it. --- Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.in b/Makefile.in index d42ad9dfa10..2b47762b7bc 100644 --- a/Makefile.in +++ b/Makefile.in @@ -332,7 +332,7 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" -ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/" +ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/${version}/" all: ${SUBDIR} info From a71f54eff80cb7d7b36326849eea878073963594 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Sep 2020 18:17:00 +0200 Subject: [PATCH 1029/1452] Rework eln deletion strategy for new eln-cache folder structure When recompiling remove the corresponding stale elns found in the `comp-eln-load-path'. When removing a package remove the corresponding elns too. On Windows both of these are performed only when possible, when it's not the file is renamed as .eln.old and a last attempt to remove this is performed closing the Emacs session. When a file being deleted was loaded by multiple Emacs sessions the last one being closed should delete it. * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): New function. (comp-delete-or-replace-file): Rename from `comp--replace-output-file' and update so it can be used for replacing or deleting shared libs safetly. * lisp/emacs-lisp/package.el (package--delete-directory): When native compiled just call `comp-clean-up-stale-eln' for each eln file we want to clean-up. * src/alloc.c (cleanup_vector): Call directly the dynlib_close. * src/comp.c (syms_of_comp): Update for comp_u->cfile removal. Make 'all_loaded_comp_units_h' key-value weak as now the key will be the filename. (load_comp_unit): Register the compilation unit only when the load is fully completed. (register_native_comp_unit): Make the key of all_loaded_comp_units_h the load filename. (eln_load_path_final_clean_up): New function. (dispose_comp_unit) (finish_delayed_disposal_of_comp_units) (dispose_all_remaining_comp_units) (clean_package_user_dir_of_old_comp_units): Remove. (Fcomp__compile_ctxt_to_file): Update for `comp--replace-output-file' -> `comp-delete-or-replace-file' rename. * src/comp.h (dispose_comp_unit) (finish_delayed_disposal_of_comp_units) (dispose_all_remaining_comp_units) (clean_package_user_dir_of_old_comp_units): Remove. (eln_load_path_final_clean_up): Add. (struct Lisp_Native_Comp_Unit): Remove cfile field. * src/emacs.c (Fkill_emacs): Call 'eln_load_path_final_clean_up'. * src/pdumper.c (dump_do_dump_relocation): Do not set comp_u->cfile. --- lisp/emacs-lisp/comp.el | 53 ++++++--- lisp/emacs-lisp/package.el | 33 ++---- src/alloc.c | 3 +- src/comp.c | 236 ++++--------------------------------- src/comp.h | 34 +----- src/emacs.c | 6 +- src/pdumper.c | 3 - 7 files changed, 75 insertions(+), 293 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 84b5a8bc873..129a4dedaf9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2505,31 +2505,52 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. -(defun comp--replace-output-file (outfile tmpfile) - "Replace OUTFILE with TMPFILE. -Takes the necessary steps when dealing with shared libraries that -may be loaded into Emacs" +;;;###autoload +(defun comp-clean-up-stale-eln (file) + "Given FILE remove all the .eln files in `comp-eln-load-path' +sharing the original source filename (including FILE)." + (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) file) + (cl-loop + with filename-hash = (match-string 1 file) + with regexp = (rx-to-string + `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) + for dir in (butlast comp-eln-load-path) ; Skip last dir. + do (cl-loop + for f in (directory-files (concat dir comp-native-version-dir) t regexp + t) + do (comp-delete-or-replace-file f)))) + +(defun comp-delete-or-replace-file (oldfile &optional newfile) + "Replace OLDFILE with NEWFILE. +When NEWFILE is nil just delete OLDFILE. +Takes the necessary steps when dealing with OLDFILE being a +shared libraries that may be currently loaded by a running Emacs +session." (cond ((eq 'windows-nt system-type) - (ignore-errors (delete-file outfile)) - (let ((retry t)) - (while retry - (setf retry nil) + (ignore-errors (delete-file oldfile)) + (while (condition-case _ (progn - ;; outfile maybe recreated by another Emacs in + ;; oldfile maybe recreated by another Emacs in ;; between the following two rename-file calls - (if (file-exists-p outfile) - (rename-file outfile (make-temp-file-internal - (file-name-sans-extension outfile) + (if (file-exists-p oldfile) + (rename-file oldfile (make-temp-file-internal + (file-name-sans-extension oldfile) nil ".eln.old" nil) t)) - (rename-file tmpfile outfile nil)) - (file-already-exists (setf retry t)))))) + (when newfile + (rename-file newfile oldfile nil)) + ;; Keep on trying. + nil) + (file-already-exists + ;; Done + t)))) ;; Remove the old eln instead of copying the new one into it ;; to get a new inode and prevent crashes in case the old one ;; is currently loaded. - (t (delete-file outfile) - (rename-file tmpfile outfile)))) + (t (delete-file oldfile) + (when newfile + (rename-file newfile oldfile))))) (defvar comp-files-queue () "List of Elisp files to be compiled.") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c349b5d49f6..c20659a1ae6 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2206,32 +2206,13 @@ If some packages are not installed propose to install them." (defun package--delete-directory (dir) "Delete DIR recursively. -In Windows move .eln and .eln.old files that can not be deleted -to `package-user-dir'." - (cond ((eq 'windows-nt system-type) - (let ((retry t)) - (while retry - (setf retry nil) - (condition-case err - (delete-directory dir t) - (file-error - (cl-destructuring-bind (_ reason1 reason2 filename) err - (if (and (string= "Removing old name" reason1) - (string= "Permission denied" reason2) - (string-prefix-p (expand-file-name package-user-dir) - filename) - (or (string-suffix-p ".eln" filename) - (string-suffix-p ".eln.old" filename))) - (progn - (rename-file filename - (make-temp-file-internal - (concat package-user-dir - (file-name-base filename)) - nil ".eln.old" nil) - t) - (setf retry t)) - (signal (car err) (cdr err))))))))) - (t (delete-directory dir t)))) +Clean-up the corresponding .eln files if Emacs is native +compiled." + (when (boundp 'comp-ctxt) + (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. diff --git a/src/alloc.c b/src/alloc.c index 6701bf002b7..bde0a16ac15 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3153,7 +3153,8 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - dispose_comp_unit (cu, true); + eassert (cu->handle); + dynlib_close (cu->handle); } else if (NATIVE_COMP_FLAG && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) diff --git a/src/comp.c b/src/comp.c index 3a56f5f22c6..68a0ead69ae 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4361,7 +4361,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL2I (comp--replace-output-file, file_name, tmp_file); + CALL1I (comp-clean-up-stale-eln, file_name); + CALL2I (comp-delete-or-replace-file, file_name, tmp_file); if (!noninteractive) unbind_to (count, Qnil); @@ -4438,220 +4439,44 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) } -/*********************************/ -/* Disposal of compilation units */ -/*********************************/ - -/* - The problem: Windows does not let us delete an .eln file that has - been loaded by a process. This has two implications in Emacs: - - 1) It is not possible to recompile a lisp file if the corresponding - .eln file has been loaded. This is because we'd like to use the same - filename, but we can't delete the old .eln file. - - 2) It is not possible to delete a package using `package-delete' - if an .eln file has been loaded. - - * General idea - - The solution to these two problems is to move the foo.eln file - somewhere else and have the last Emacs instance using it delete it. - To make it easy to find what files need to be removed we use two approaches. - - In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same - folder. When Emacs is unloading "foo" (either GC'd the native - compilation unit or Emacs is closing (see below)) we delete all the - .eln.old files in the folder where the original foo.eln was stored. - - Ideally we'd figure out the new name of foo.eln and delete it if it - ends in .eln.old. There is no simple API to do this in Windows. - GetModuleFileName () returns the original filename, not the current - one. This forces us to put .eln.old files in an agreed upon path. - We cannot use %TEMP% because it may be in another drive and then the - rename operation would fail. - - In the 2) case we can't use the same folder where the .eln file - resided, as we are trying to completely remove the package. Since we - are removing packages we can safely move the .eln.old file to - `package-user-dir' as we are sure that that would not mean changing - drives. - - * Implementation details - - The concept of disposal of a native compilation unit refers to - unloading the shared library and deleting all the .eln.old files in - the directory. These are two separate steps. We'll call them - early-disposal and late-disposal. - - There are two data structures used: - - - The `all_loaded_comp_units_h` hashtable. - - This hashtable is used like an array of weak references to native - compilation units. This hash table is filled by load_comp_unit () - and dispose_all_remaining_comp_units () iterates over all values - that were not disposed by the GC and performs all disposal steps - when Emacs is closing. - - - The `delayed_comp_unit_disposal_list` list. - - This is were the dispose_comp_unit () function, when called by the - GC sweep stage, stores the original filenames of the disposed native - compilation units. This is an ad-hoc C structure instead of a Lisp - cons because we need to allocate instances of this structure during - the GC. - - The finish_delayed_disposal_of_comp_units () function will iterate - over this list and perform the late-disposal step when Emacs is - closing. - -*/ - -#ifdef WINDOWSNT -#define OLD_ELN_SUFFIX_REGEXP build_string ("\\.eln\\.old\\'") +/* `comp-eln-load-path' clean-up support code. */ static Lisp_Object all_loaded_comp_units_h; -/* We need to allocate instances of this struct during a GC sweep. - This is why it can't be transformed into a simple cons. */ -struct delayed_comp_unit_disposal -{ - struct delayed_comp_unit_disposal *next; - char *filename; -}; - -struct delayed_comp_unit_disposal *delayed_comp_unit_disposal_list; - -static Lisp_Object -return_nil (Lisp_Object arg) -{ - return Qnil; -} - -/* Tries to remove all *.eln.old files in DIRNAME. +/* Windows does not let us delete a .eln file that is currently loaded + by a process. The strategy is to rename .eln files into .old.eln + instead of removing them when this is not possible and clean-up + `comp-eln-load-path' when exiting. Any error is ignored because it may be due to the file being loaded in another Emacs instance. */ -static void -clean_comp_unit_directory (Lisp_Object dirpath) -{ - if (NILP (dirpath)) - return; - Lisp_Object files_in_dir; - files_in_dir = internal_condition_case_4 (Fdirectory_files, dirpath, Qt, - OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, - return_nil); - FOR_EACH_TAIL (files_in_dir) { DeleteFile (SSDATA (XCAR (files_in_dir))); } -} - -/* Tries to remove all *.eln.old files in `package-user-dir'. - - This is called when Emacs is closing to clean any *.eln left from a - deleted package. */ void -clean_package_user_dir_of_old_comp_units (void) +eln_load_path_final_clean_up (void) { - Lisp_Object package_user_dir - = find_symbol_value (intern ("package-user-dir")); - if (EQ (package_user_dir, Qunbound) || !STRINGP (package_user_dir)) - return; +#ifdef WINDOWSNT + Lisp_Object return_nil (Lisp_Object arg) { return Qnil; } - clean_comp_unit_directory (package_user_dir); -} - -/* This function disposes all compilation units that are still loaded. - - It is important that this function is called only right before - Emacs is closed, otherwise we risk running a subr that is - implemented in an unloaded dynamic library. */ -void -dispose_all_remaining_comp_units (void) -{ - struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units_h); - - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + Lisp_Object dir_tail = Vcomp_eln_load_path; + FOR_EACH_TAIL (dir_tail) { - Lisp_Object k = HASH_KEY (h, i); - if (!EQ (k, Qunbound)) - { - Lisp_Object val = HASH_VALUE (h, i); - struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (val); - dispose_comp_unit (cu, false); - } + Lisp_Object files_in_dir = + internal_condition_case_4 (Fdirectory_files, + concat2 (XCAR (dir_tail), + Vcomp_native_version_dir), + Qt, build_string ("\\.eln\\.old\\'"), Qnil, + Qt, return_nil); + FOR_EACH_TAIL (files_in_dir) + Fdelete_file (XCAR (files_in_dir), Qnil); } -} - -/* This function finishes the disposal of compilation units that were - passed to `dispose_comp_unit` with DELAY == true. - - This function is called when Emacs is idle and when it is about to - close. */ -void -finish_delayed_disposal_of_comp_units (void) -{ - for (struct delayed_comp_unit_disposal *item - = delayed_comp_unit_disposal_list; - delayed_comp_unit_disposal_list; item = delayed_comp_unit_disposal_list) - { - delayed_comp_unit_disposal_list = item->next; - Lisp_Object dirname = internal_condition_case_1 ( - Ffile_name_directory, build_string (item->filename), Qt, return_nil); - clean_comp_unit_directory (dirname); - xfree (item->filename); - xfree (item); - } -} #endif +} /* This function puts the compilation unit in the `all_loaded_comp_units_h` hashmap. */ static void register_native_comp_unit (Lisp_Object comp_u) { -#ifdef WINDOWSNT - /* We have to do this since we can't use `gensym'. This function is - called early when loading a dump file and subr.el may not have - been loaded yet. */ - static intmax_t count; - - Fputhash (make_int (count++), comp_u, all_loaded_comp_units_h); -#endif -} - -/* This function disposes compilation units. It is called during the GC sweep - stage and when Emacs is closing. - - On Windows the the DELAY parameter specifies whether the native - compilation file will be deleted right away (if necessary) or put - on a list. That list will be dealt with by - `finish_delayed_disposal_of_comp_units`. */ -void -dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) -{ - eassert (comp_handle->handle); - dynlib_close (comp_handle->handle); -#ifdef WINDOWSNT - if (!delay) - { - Lisp_Object dirname = internal_condition_case_1 ( - Ffile_name_directory, build_string (comp_handle->cfile), Qt, - return_nil); - if (!NILP (dirname)) - clean_comp_unit_directory (dirname); - xfree (comp_handle->cfile); - comp_handle->cfile = NULL; - } - else - { - struct delayed_comp_unit_disposal *head; - head = xmalloc (sizeof (struct delayed_comp_unit_disposal)); - head->next = delayed_comp_unit_disposal_list; - head->filename = comp_handle->cfile; - comp_handle->cfile = NULL; - delayed_comp_unit_disposal_list = head; - } -#endif + Fputhash (XNATIVE_COMP_UNIT (comp_u)->file, comp_u, all_loaded_comp_units_h); } @@ -4663,7 +4488,6 @@ dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) loaded the compiler and its dependencies. */ static Lisp_Object delayed_sources; - /* Queue an asyncronous compilation for the source file defining FUNCTION_NAME and perform a late load. @@ -4922,12 +4746,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); - - /* If we register them while dumping we will get some entries in - the hash table that will be duplicated when pdumper calls - load_comp_unit. */ - if (!will_dump_p ()) - register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4968,6 +4786,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* Clean-up the load ongoing flag in case. */ unbind_to (count, Qnil); + register_native_comp_unit (comp_u_lisp_obj); + return; } @@ -5110,9 +4930,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; -#ifdef WINDOWSNT - comp_u->cfile = xlispstrdup (file); -#endif comp_u->data_vec = Qnil; comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); @@ -5275,10 +5092,9 @@ native compiled one. */); staticpro (&loadsearch_re_list); loadsearch_re_list = Qnil; -#ifdef WINDOWSNT staticpro (&all_loaded_comp_units_h); - all_loaded_comp_units_h = CALLN (Fmake_hash_table, QCweakness, Qvalue); -#endif + all_loaded_comp_units_h = + CALLN (Fmake_hash_table, QCweakness, Qkey_and_value, QCtest, Qequal); DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); diff --git a/src/comp.h b/src/comp.h index 9270f8bf664..5c7bed6a304 100644 --- a/src/comp.h +++ b/src/comp.h @@ -54,13 +54,6 @@ struct Lisp_Native_Comp_Unit bool loaded_once; bool load_ongoing; dynlib_handle_ptr handle; -#ifdef WINDOWSNT - /* We need to store a copy of the original file name in memory that - is not subject to GC because the function to dispose native - compilation units is called by the GC. By that time the `file' - string may have been sweeped. */ - char *cfile; -#endif } GCALIGNED_STRUCT; #ifdef HAVE_NATIVE_COMP @@ -92,14 +85,7 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); -extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, - bool delay); - -extern void finish_delayed_disposal_of_comp_units (void); - -extern void dispose_all_remaining_comp_units (void); - -extern void clean_package_user_dir_of_old_comp_units (void); +extern void eln_load_path_final_clean_up (void); extern void fixup_eln_load_path (Lisp_Object directory); @@ -112,24 +98,6 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); -static inline void -dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle, bool delay) -{ - eassert (false); -} - -static inline void -dispose_all_remaining_comp_units (void) -{} - -static inline void -clean_package_user_dir_of_old_comp_units (void) -{} - -static inline void -finish_delayed_disposal_of_comp_units (void) -{} - #endif /* #ifdef HAVE_NATIVE_COMP */ #endif /* #ifndef COMP_H */ diff --git a/src/emacs.c b/src/emacs.c index 8e52da75926..07e40fdc8bd 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2407,10 +2407,8 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } -#if defined (HAVE_NATIVE_COMP) && defined (WINDOWSNT) - finish_delayed_disposal_of_comp_units (); - dispose_all_remaining_comp_units (); - clean_package_user_dir_of_old_comp_units (); +#ifdef HAVE_NATIVE_COMP + eln_load_path_final_clean_up (); #endif if (FIXNUMP (arg)) diff --git a/src/pdumper.c b/src/pdumper.c index 9c615a9a1a7..da5e7a17363 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5275,9 +5275,6 @@ dump_do_dump_relocation (const uintptr_t dump_base, concat2 (Vinvocation_directory, installation_state == INSTALLED ? XCAR (comp_u->file) : XCDR (comp_u->file)); -#ifdef WINDOWSNT - comp_u->cfile = xlispstrdup (comp_u->file); -#endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); From 3df471e1f4723cc0d860b31f5153ee8e47503e34 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Sep 2020 18:19:00 +0200 Subject: [PATCH 1030/1452] * src/comp.c (Fnative_elisp_load): Make recompilation always effective. When loading a file if in this session there was ever a file loaded with that name rename it before loading it to make sure we always get a new handle from the standard library. --- src/comp.c | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 68a0ead69ae..ddecacd74e7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4916,20 +4916,35 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, - doc: /* Load native elisp code FILE. + doc: /* Load native elisp code FILENAME. LATE_LOAD has to be non nil when loading for deferred compilation. */) - (Lisp_Object file, Lisp_Object late_load) + (Lisp_Object filename, Lisp_Object late_load) { - CHECK_STRING (file); - if (NILP (Ffile_exists_p (file))) + CHECK_STRING (filename); + if (NILP (Ffile_exists_p (filename))) xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), - file); + filename); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); - comp_u->handle = dynlib_open (SSDATA (file)); + if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil))) + { + /* If in this session there was ever a file loaded with this + name rename before loading it to make sure we always get a + new handle! */ + Lisp_Object tmp_filename = + Fmake_temp_file_internal (filename, make_fixnum (0), + build_string (".eln"), Qnil); + Frename_file (filename, tmp_filename, Qnil); + comp_u->handle = dynlib_open (SSDATA (tmp_filename)); + Frename_file (tmp_filename, filename, Qnil); + } + else + comp_u->handle = dynlib_open (SSDATA (filename)); + if (!comp_u->handle) - xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - comp_u->file = file; + xsignal2 (Qnative_lisp_load_failed, filename, + build_string (dynlib_error ())); + comp_u->file = filename; comp_u->data_vec = Qnil; comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); From 3a9139d197ea1a211b64ca70e1f7e1f0545a4424 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Sep 2020 18:20:00 +0200 Subject: [PATCH 1031/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Rename a variable. --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index ddecacd74e7..70bb560da63 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4353,10 +4353,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); + AUTO_STRING (dot_eln, NATIVE_ELISP_SUFFIX); Lisp_Object tmp_file = - Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); + Fmake_temp_file_internal (base_name, Qnil, dot_eln, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); From d344e79be9fb82a38a89c892e24d5ca71fbff810 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Sep 2020 18:21:00 +0200 Subject: [PATCH 1032/1452] * src/data.c (subr-native-lambda-list): Defined it unconditionally (bug#43255) --- src/data.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/data.c b/src/data.c index 0acae67b2a8..85c73b406c4 100644 --- a/src/data.c +++ b/src/data.c @@ -882,8 +882,6 @@ function, nil otherwise. */) return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } -#ifdef HAVE_NATIVE_COMP - 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 @@ -897,6 +895,8 @@ function or t otherwise. */) : Qt; } +#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. */) From dc4b50ce0b52d8fcade1e04aabd92409858fcfc2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 7 Sep 2020 23:13:28 +0200 Subject: [PATCH 1033/1452] * Do not crash compilation if user eln-cache wasn't already created. * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Guard against calling `directory-files' on non existent directories. --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 129a4dedaf9..cfc5ca55488 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2516,8 +2516,9 @@ sharing the original source filename (including FILE)." `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) for dir in (butlast comp-eln-load-path) ; Skip last dir. do (cl-loop - for f in (directory-files (concat dir comp-native-version-dir) t regexp - t) + with full-dir = (concat dir comp-native-version-dir) + for f in (when (file-exists-p full-dir) + (directory-files full-dir t regexp t)) do (comp-delete-or-replace-file f)))) (defun comp-delete-or-replace-file (oldfile &optional newfile) From ff89ec0d366f6fa8cf25702f8b3bc3d4cd0833b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 7 Sep 2020 23:57:52 +0200 Subject: [PATCH 1034/1452] * Name temp eln files as .eln.tmp so we can't clean-up them mistakenly. * src/comp.c (Fcomp__compile_ctxt_to_file): Postfix temporary eln files as .eln.tmp. --- src/comp.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 70bb560da63..5880224ac77 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4353,10 +4353,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - AUTO_STRING (dot_eln, NATIVE_ELISP_SUFFIX); - Lisp_Object tmp_file = - Fmake_temp_file_internal (base_name, Qnil, dot_eln, Qnil); + Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); From 15acd27d1c0de8b56bab61daa0a8fcd4fef0fdc4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 8 Sep 2020 10:58:59 +0200 Subject: [PATCH 1035/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Don't cleanup caches at bootstrap. --- src/comp.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 5880224ac77..71a36a60a08 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4359,7 +4359,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL1I (comp-clean-up-stale-eln, file_name); + /* FIXME: this if workaround a cc-bytecomp compilation issue + appearing on the Docker build that must be investigated. */ + if (NILP (Fsymbol_value(intern_c_string ("byte-native-for-bootstrap")))) + CALL1I (comp-clean-up-stale-eln, file_name); CALL2I (comp-delete-or-replace-file, file_name, tmp_file); if (!noninteractive) From c2724c3ebb7228ecd8607c3017334e0efb57e069 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 10 Sep 2020 07:37:33 +0200 Subject: [PATCH 1036/1452] Revert "* src/comp.c (Fcomp__compile_ctxt_to_file): Don't cleanup caches at bootstrap." This reverts commit 15acd27d1c0de8b56bab61daa0a8fcd4fef0fdc4. --- src/comp.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 71a36a60a08..5880224ac77 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4359,10 +4359,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* FIXME: this if workaround a cc-bytecomp compilation issue - appearing on the Docker build that must be investigated. */ - if (NILP (Fsymbol_value(intern_c_string ("byte-native-for-bootstrap")))) - CALL1I (comp-clean-up-stale-eln, file_name); + CALL1I (comp-clean-up-stale-eln, file_name); CALL2I (comp-delete-or-replace-file, file_name, tmp_file); if (!noninteractive) From 107514a6e21f2c434cdae0eca76fe0a60e287ac8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 10 Sep 2020 07:35:29 +0200 Subject: [PATCH 1037/1452] * Fix rename file error when reloading the same file from an sys eln dir. * src/comp.c (Fnative_elisp_load): Don't rename files we don't have the permission for. --- src/comp.c | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5880224ac77..4550833a6a2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4924,17 +4924,24 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), filename); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); - if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil))) + + if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil)) + && !NILP (Ffile_writable_p (filename))) { /* If in this session there was ever a file loaded with this name rename before loading it to make sure we always get a new handle! */ Lisp_Object tmp_filename = - Fmake_temp_file_internal (filename, make_fixnum (0), - build_string (".eln"), Qnil); - Frename_file (filename, tmp_filename, Qnil); - comp_u->handle = dynlib_open (SSDATA (tmp_filename)); - Frename_file (tmp_filename, filename, Qnil); + Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"), + Qnil); + if (NILP (Ffile_writable_p (tmp_filename))) + comp_u->handle = dynlib_open (SSDATA (filename)); + else + { + Frename_file (filename, tmp_filename, Qt); + comp_u->handle = dynlib_open (SSDATA (tmp_filename)); + Frename_file (tmp_filename, filename, Qnil); + } } else comp_u->handle = dynlib_open (SSDATA (filename)); From cb293cfb929dfbecb3057dde2115399b89350a9b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 10 Sep 2020 09:59:29 +0200 Subject: [PATCH 1038/1452] * Guard against trying to rename files into eln sys directory * src/comp.c (file_in_eln_sys_dir): New function. (Fnative_elisp_load): Make use of. --- src/comp.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/comp.c b/src/comp.c index 4550833a6a2..d7966d42221 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4912,6 +4912,18 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, return Qnil; } +static bool +file_in_eln_sys_dir (Lisp_Object filename) +{ + Lisp_Object eln_sys_dir = Qnil; + Lisp_Object tmp = Vcomp_eln_load_path; + FOR_EACH_TAIL (tmp) + eln_sys_dir = XCAR (tmp); + return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir, + Qnil)), + Fexpand_file_name (filename, Qnil), Qnil)); +} + /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. @@ -4926,6 +4938,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil)) + && !file_in_eln_sys_dir (filename) && !NILP (Ffile_writable_p (filename))) { /* If in this session there was ever a file loaded with this From 3c58403b0f9b732e045230ce34f1b5a8460630ac Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 11 Sep 2020 10:51:39 +0200 Subject: [PATCH 1039/1452] By default when building native compile only what's part of the dump image To Ahead of Time compile the whole Emacs distro define NATIVE_FULL_AOT when invoking make ex: 'make NATIVE_FULL_AOT=1'. * lisp/Makefile.in (NATIVE_SKIP_NONDUMP): New variable. (compile-main): Use it + rename NATIVE_DISABLE -> NATIVE_DISABLED. * lisp/emacs-lisp/comp.el (batch-byte-native-compile-for-bootstrap): Rename NATIVE_DISABLE -> NATIVE_DISABLED. --- lisp/Makefile.in | 5 ++++- lisp/emacs-lisp/comp.el | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 164e4a01f59..75563adeeed 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -38,6 +38,9 @@ AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) ifeq ($(HAVE_NATIVE_COMP),yes) am__v_ELC_0 = @echo " ELC+ELN " $@; +ifndef NATIVE_FULL_AOT +NATIVE_SKIP_NONDUMP = 1 +endif else am__v_ELC_0 = @echo " ELC " $@; endif @@ -353,7 +356,7 @@ compile-main: gen-lisp compile-clean done | xargs $(XARGS_LIMIT) echo) | \ while read chunk; do \ $(MAKE) compile-targets \ - NATIVE_DISABLE=$(NATIVE_FAST_BOOT) \ + NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \ TARGETS="$$chunk"; \ done diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cfc5ca55488..e1920dbc033 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2731,7 +2731,7 @@ Ultra cheap impersonation of `batch-byte-compile'." "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." (comp-ensure-native-compiler) - (if (equal (getenv "NATIVE_DISABLE") "1") + (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (= 1 (length command-line-args-left))) (let ((byte-native-for-bootstrap t) From 42b5a1101d2230bc1a6d7abf019f9a96c164da5c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 11 Sep 2020 11:12:32 +0200 Subject: [PATCH 1040/1452] * Update gitlab CI yml file * .gitlab-ci.yml (test-native-bootstrap-speed0) (test-native-bootstrap-speed1, test-native-bootstrap-speed2): Update for new make invokation. --- .gitlab-ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6627f5f8054..93929f211cd 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -107,7 +107,7 @@ test-native-bootstrap-speed0: - 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 0)"' -j2 + - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 timeout: 8 hours test-native-bootstrap-speed1: @@ -116,7 +116,7 @@ test-native-bootstrap-speed1: - 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_FAST_BOOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' timeout: 8 hours test-native-bootstrap-speed2: @@ -125,7 +125,7 @@ test-native-bootstrap-speed2: - 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_FAST_BOOT=1 + - make bootstrap timeout: 8 hours test-gnustep: From ff593d934aec6d8e7b211d7fe2ff7fc8f92ad42b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 31 May 2020 14:39:59 +0100 Subject: [PATCH 1041/1452] * Make use of new 'gcc_jit_global_set_initializer' entry point Use this brand new entry point to avoid the current workaround and its load-time memcpys. * src/comp.c (gcc_jit_global_set_initializer): Add to the dynamic load machinery. (static_obj_t): Remove const qualifier from the data field. (emit_static_object): Make use of 'gcc_jit_global_set_initializer' when available. (load_static_obj): Use the blob for loading if that was emitted. --- src/comp.c | 45 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 42 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index d7966d42221..1ef4f3054b1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -90,6 +90,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_function_get_param #undef gcc_jit_function_new_block #undef gcc_jit_function_new_local +#undef gcc_jit_global_set_initializer #undef gcc_jit_lvalue_access_field #undef gcc_jit_lvalue_as_rvalue #undef gcc_jit_lvalue_get_address @@ -144,6 +145,8 @@ DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global, DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local, (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type, const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_global_set_initializer, + (gcc_jit_lvalue *global, const void *blob, size_t num_bytes)); DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field, (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc, gcc_jit_field *field)); @@ -307,6 +310,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); + LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); LOAD_DLL_FN_OPT (library, gcc_jit_version_major); LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); @@ -357,6 +361,7 @@ init_gccjit_functions (void) #define gcc_jit_function_get_param fn_gcc_jit_function_get_param #define gcc_jit_function_new_block fn_gcc_jit_function_new_block #define gcc_jit_function_new_local fn_gcc_jit_function_new_local +#define gcc_jit_global_set_initializer fn_gcc_jit_global_set_initializer #define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field #define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue #define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address @@ -589,7 +594,7 @@ FILE *logfile = NULL; /* This is used for serialized objects by the reload mechanism. */ typedef struct { ptrdiff_t len; - const char data[]; + char data[]; } static_obj_t; typedef struct { @@ -2497,6 +2502,33 @@ emit_static_object (const char *name, Lisp_Object obj) ptrdiff_t len = SBYTES (str); const char *p = SSDATA (str); +#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) \ + || defined (WINDOWSNT) +#pragma GCC diagnostic ignored "-Waddress" + if (gcc_jit_global_set_initializer) +#pragma GCC diagnostic pop + { + ptrdiff_t str_size = len + 1; + ptrdiff_t size = sizeof (static_obj_t) + str_size; + static_obj_t *static_obj = xmalloc (size); + static_obj->len = str_size; + memcpy (static_obj->data, p, str_size); + gcc_jit_lvalue *blob = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, NULL, + comp.char_type, + size), + format_string ("%s_blob", name)); + gcc_jit_global_set_initializer (blob, static_obj, size); + xfree (static_obj); + + return; + } +#endif + gcc_jit_type *a_type = gcc_jit_context_new_array_type (comp.ctxt, NULL, @@ -4599,12 +4631,19 @@ typedef char *(*comp_lit_str_func) (void); static Lisp_Object load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) { + static_obj_t *blob = + dynlib_sym (comp_u->handle, format_string ("%s_blob", name)); + if (blob) + /* New blob format. */ + return Fread (make_string (blob->data, blob->len)); + static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name); if (!f) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - static_obj_t *res = f (); - return Fread (make_string (res->data, res->len)); + blob = f (); + return Fread (make_string (blob->data, blob->len)); + } /* Return false when something is wrong or true otherwise. */ From c55884d72a4ea806a97c9925d6f85adcca89a3bd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 11 Sep 2020 14:57:11 +0200 Subject: [PATCH 1042/1452] * src/comp.c (emit_static_object): Make use of ARRAYELTS. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 1ef4f3054b1..b3640b5e378 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2549,7 +2549,7 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_context_new_struct_type (comp.ctxt, NULL, format_string ("%s_struct", name), - 2, fields)); + ARRAYELTS (fields), fields)); gcc_jit_lvalue *data_struct = gcc_jit_context_new_global (comp.ctxt, From 21021e56ad609a459ec117bcfc60b2802176a9a7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Sep 2020 18:15:32 +0200 Subject: [PATCH 1043/1452] * Fix defsbust declare effectiveness introduced by 80d7f710 (Bug#43280). * lisp/emacs-lisp/byte-run.el (defsubst): Do not add a speed declaration as this breaks a pre existing ones if present but rather calls directly `byte-run--set-speed'. --- lisp/emacs-lisp/byte-run.el | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 8c16c172bed..df693ab1c83 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -363,13 +363,12 @@ You don't need this. (See bytecomp.el commentary for more details.) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) + ;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664). + (byte-run--set-speed name nil -1) `(prog1 - (defun ,name ,arglist - ;; Never native-compile defsubsts as we need the byte - ;; definition in `byte-compile-unfold-bcf' to perform the - ;; inlining (Bug#42664). - (declare (speed -1)) - ,@body) + (defun ,name ,arglist ,@body) (eval-and-compile (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) From c4cc13917cdf733b142ed2dee9b5aee9df9f8153 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 1 Sep 2020 21:28:22 +0200 Subject: [PATCH 1044/1452] * lisp/emacs-lisp/cl-macs.el (cl-the): Emit compiler hints when native. --- lisp/emacs-lisp/cl-macs.el | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c38019d4a73..7adb9100703 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2329,6 +2329,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 (cl--compiling-file)) (< cl--optimize-speed 3) (= cl--optimize-safety 3))) From 95312717c726e390de26bd85341a17b163b40fd7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 21:06:54 +0200 Subject: [PATCH 1045/1452] * Add 'cl-optimize' as function declaration * lisp/emacs-lisp/cl-macs.el: Register cl-optimize into `defun-declarations-alist' and `macro-declarations-alist'. (cl--optimize): New function to serve 'cl-optimize' declaration. --- lisp/emacs-lisp/cl-macs.el | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 7adb9100703..2730e8f24a3 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2347,6 +2347,26 @@ 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)" + (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 From c9a9b0766f43d1acf56e2ff19eb9505b454423a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 21:22:19 +0200 Subject: [PATCH 1046/1452] * lisp/emacs-lisp/cl-macs.el: Define fixnum and bignum. Define fixnum so `cl-typep' recognize it and the type check emitted by `cl-the' is effective. --- lisp/emacs-lisp/cl-macs.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 2730e8f24a3..e7c7374976a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3437,6 +3437,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'. From a3dc11e9ccd48beb84adfe79ff28143c1682f690 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 21:27:26 +0200 Subject: [PATCH 1047/1452] * Remove type check emission from type hints low level primitives These have to be emitted by higher level primitves as `cl-the'. * lisp/emacs-lisp/comp.el (comp-hint-fixnum, comp-hint-cons): Do not emit type checks. --- lisp/emacs-lisp/comp.el | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1920dbc033..831af3793ec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2487,20 +2487,18 @@ Prepare every function for final compilation and drive the C back-end." ;;; Compiler type hints. -;; These are public entry points be used in user code to give comp suggestion -;; about types. -;; These can be used to implement CL style 'the', 'declare' or something like. +;; Public entry points to be used by user code to give comp +;; suggestions about types. These are used to implement CL style +;; `cl-the' and hopefully parameter type declaration. ;; Note: types will propagates. ;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) - (unless (fixnump x) - (signal 'wrong-type-argument x))) + x) (defun comp-hint-cons (x) - (unless (consp x) - (signal 'wrong-type-argument x))) + x) ;; Some entry point support code. From 2da2ad29b83090950749f26a7375be4a67964438 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 22:02:18 +0200 Subject: [PATCH 1048/1452] * lisp/emacs-lisp/comp.el (comp-sp): Better style gv-setter declaration. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 831af3793ec..eceba777fa7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -810,9 +810,9 @@ Points to the next slot to be filled.") (defsubst comp-sp () "Current stack pointer." + (declare (gv-setter (lambda (val) + `(setf (comp-limplify-sp comp-pass) ,val)))) (comp-limplify-sp comp-pass)) -(gv-define-setter comp-sp (value) - `(setf (comp-limplify-sp comp-pass) ,value)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. From 82171a8f0de6e88566aa0d80388dab135dbc260f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 22:02:36 +0200 Subject: [PATCH 1049/1452] * Add gv-setters for compiler hints * lisp/emacs-lisp/comp.el (comp-hint-fixnum, comp-hint-cons): Add gv-setters so type hinted expressions can be used as places. Read we can now have like: '(cl-incf (cl-the fixnum x))'. --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eceba777fa7..f1689808eea 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2495,9 +2495,11 @@ Prepare every function for final compilation and drive the C back-end." ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) + (declare (gv-setter (lambda (val) `(setf ,x ,val)))) x) (defun comp-hint-cons (x) + (declare (gv-setter (lambda (val) `(setf ,x ,val)))) x) From e9728375763c61e3b890530b202b856d28c44646 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 22:50:21 +0200 Subject: [PATCH 1050/1452] * Fix free function compilation load process. * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Do not crash if the eln filename is not canonical (tmp file or manual load). --- lisp/emacs-lisp/comp.el | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f1689808eea..25e2de9d5d2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2509,17 +2509,18 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-clean-up-stale-eln (file) "Given FILE remove all the .eln files in `comp-eln-load-path' sharing the original source filename (including FILE)." - (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) file) - (cl-loop - with filename-hash = (match-string 1 file) - with regexp = (rx-to-string - `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast comp-eln-load-path) ; Skip last dir. - do (cl-loop - with full-dir = (concat dir comp-native-version-dir) - for f in (when (file-exists-p full-dir) - (directory-files full-dir t regexp t)) - do (comp-delete-or-replace-file f)))) + (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) + file) + (cl-loop + with filename-hash = (match-string 1 file) + with regexp = (rx-to-string + `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) + for dir in (butlast comp-eln-load-path) ; Skip last dir. + do (cl-loop + with full-dir = (concat dir comp-native-version-dir) + for f in (when (file-exists-p full-dir) + (directory-files full-dir t regexp t)) + do (comp-delete-or-replace-file f))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. From 5f37c18581ea1a36e9dcb5d4ac741aafb0398ebe Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 14 Sep 2020 22:59:41 +0200 Subject: [PATCH 1051/1452] * test/src/comp-tests.el (comp-tests-bootstrap): Print compilation time. --- test/src/comp-tests.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b147bd6789c..220bf1c7736 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -58,11 +58,15 @@ Check that the resulting binaries do not differ." (load (concat comp-src "c") nil nil t t)) (should-not (subr-native-elisp-p (symbol-function #'native-compile))) (message "Compiling stage1...") - (let ((comp1-eln (native-compile comp1-src))) + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) (load comp1-eln nil nil t t) (should (subr-native-elisp-p (symbol-function 'native-compile))) (message "Compiling stage2...") - (let ((comp2-eln (native-compile comp2-src))) + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) (message "Comparing %s %s" comp1-eln comp2-eln) (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) From 5b41545f1be367837d9ac717ea67fba19a4c24d4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 15 Sep 2020 09:05:14 +0200 Subject: [PATCH 1052/1452] * Better error handling after calling 'gcc_jit_context_compile_to_file' Tipically errors are catched in 'compile_function' but in case libgccjit throw an error only afterwards while compiling the whole compilation unit we have to report it correctly. * src/comp.c (Fcomp__compile_ctxt_to_file): Catch libgccjit errors after calling 'gcc_jit_context_compile_to_file'. --- src/comp.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/comp.c b/src/comp.c index b3640b5e378..15d85d30fcb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4391,6 +4391,13 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + xsignal3 (Qnative_ice, + build_string ("failed to compile"), + file_name, + build_string (err)); + CALL1I (comp-clean-up-stale-eln, file_name); CALL2I (comp-delete-or-replace-file, file_name, tmp_file); From 69c32e01875f33ba1cc4ad37d0940375cd0c6e27 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 10:27:41 +0200 Subject: [PATCH 1053/1452] * Sandbox syncronous libgccjit invocation on interactive sessions Avoid unnecessary memory fragmentation/leakeage * lisp/emacs-lisp/comp.el (comp-final1): New function. (comp-final): Invoke `comp-final1' in a child process if in an interactive session or directly otherwhise. --- lisp/emacs-lisp/comp.el | 42 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 40 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 25e2de9d5d2..4795d2fc07e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2475,8 +2475,7 @@ Prepare every function for final compilation and drive the C back-end." (unless comp-dry-run (comp--compile-ctxt-to-file name)))) -(defun comp-final (_) - "Final pass driving the C back-end for code emission." +(defun comp-final1 () (let (compile-result) (comp--init-ctxt) (unwind-protect @@ -2485,6 +2484,45 @@ Prepare every function for final compilation and drive the C back-end." (and (comp--release-ctxt) compile-result)))) +(defun comp-final (_) + "Final pass driving the C back-end for code emission." + (if noninteractive + (comp-final1) + ;; Call comp-final1 in a child process. + (let* ((output (comp-ctxt-output comp-ctxt)) + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t) + (expr `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + comp-ctxt ,comp-ctxt + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path) + ,comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) + (temp-file (make-temp-file + (concat "emacs-int-comp-" + (file-name-base output) "-") + nil ".el"))) + (with-temp-file temp-file + (insert (prin1-to-string expr))) + (with-temp-buffer + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + output + (signal 'native-compiler-error (buffer-string))))))) + ;;; Compiler type hints. ;; Public entry points to be used by user code to give comp From 89a2e79b7d9fa9dc640951bbb3cb0d78dbfbc310 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 22:42:16 +0200 Subject: [PATCH 1054/1452] * Make use of use of `subr-primitive-p' in `find-function-library' * lisp/emacs-lisp/find-func.el (find-function-library): Use `subr-primitive-p'. --- lisp/emacs-lisp/find-func.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index f5f8c822089..a4577a53164 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -432,7 +432,7 @@ message about the whole chain of aliases." (cons function (cond ((autoloadp def) (nth 1 def)) - ((and (subrp def) (not (subr-native-elisp-p def))) + ((subr-primitive-p def) (if lisp-only (error "%s is a built-in function" function)) (help-C-file-name def 'subr)) From 4a50f541447eddefcca3ebc6bedb110ac0041f90 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Sep 2020 21:07:04 +0200 Subject: [PATCH 1055/1452] * Fix MacOS Emacs.app installation (bug#43532) * src/comp.c (Fcomp_el_to_eln_filename): Adapt the filename hashing algorithm to allow for producing a MacOS self-contained Emacs.app. --- src/comp.c | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index 15d85d30fcb..63a58be264c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4054,18 +4054,30 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) if (NILP (loadsearch_re_list)) { - Lisp_Object loadsearch_list = - Fcons (build_string (PATH_DUMPLOADSEARCH), - Fcons (build_string (PATH_LOADSEARCH), Qnil)); - FOR_EACH_TAIL (loadsearch_list) - loadsearch_re_list = - Fcons (Fregexp_quote (XCAR (loadsearch_list)), loadsearch_re_list); + Lisp_Object sys_re; +#ifdef __APPLE__ + /* On MacOS we relax the match on PATH_LOADSEARCH making + everything before ".app/" a wildcard. This to obtain a + self-contained Emacs.app (bug#43532). */ + char *c; + if ((c = strstr (PATH_LOADSEARCH, ".app/"))) + sys_re = + concat2 (build_string ("\\`[[:ascii:]]+"), + Fregexp_quote (build_string (c))); + else + sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); +#else + sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); +#endif + loadsearch_re_list = + list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH))); } - Lisp_Object loadsearch_res = loadsearch_re_list; - FOR_EACH_TAIL (loadsearch_res) + + Lisp_Object lds_re_tail = loadsearch_re_list; + FOR_EACH_TAIL (lds_re_tail) { Lisp_Object match_idx = - Fstring_match (XCAR (loadsearch_res), filename, Qnil); + Fstring_match (XCAR (lds_re_tail), filename, Qnil); if (EQ (match_idx, make_fixnum (0))) { filename = From 63c65b4fe0e27b70a99463a8f7de4750811fd1e0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 12:31:03 +0200 Subject: [PATCH 1056/1452] * lisp/emacs-lisp/comp.el (native-compile): Add OUTPUT parameter. --- lisp/emacs-lisp/comp.el | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4795d2fc07e..d4f003f7717 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2709,13 +2709,14 @@ display a message." ;;; Compiler entry points. ;;;###autoload -(defun native-compile (function-or-file &optional with-late-load) +(defun native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. -When WITH-LATE-LOAD non Nil mark the compilation unit for late load +When WITH-LATE-LOAD non-nil mark the compilation unit for late load once finished compiling (internal use only). -Return the compilation unit file name." +When OUTPUT is non-nil use it as filename for the compiled object. +Return the compile object filename." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -2727,11 +2728,15 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output (if (symbolp function-or-file) - (make-temp-file (symbol-name function-or-file) nil ".eln") - (comp-el-to-eln-filename function-or-file - (when byte-native-for-bootstrap - (car (last comp-eln-load-path))))) + :output (or (when output + (expand-file-name output)) + (if (symbolp function-or-file) + (make-temp-file (symbol-name function-or-file) nil + ".eln") + (comp-el-to-eln-filename + function-or-file + (when byte-native-for-bootstrap + (car (last comp-eln-load-path)))))) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err From 9d4fd669cf9b97a89e8d1481b3ffedfe7a455152 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Sep 2020 20:48:23 +0200 Subject: [PATCH 1057/1452] * lisp/emacs-lisp/comp.el (comp-final): Log when interactively invoked. --- lisp/emacs-lisp/comp.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d4f003f7717..2bba298ac0a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2516,12 +2516,14 @@ Prepare every function for final compilation and drive the C back-end." (with-temp-file temp-file (insert (prin1-to-string expr))) (with-temp-buffer - (if (zerop - (call-process (expand-file-name invocation-name - invocation-directory) - nil t t "--batch" "-l" temp-file)) - output - (signal 'native-compiler-error (buffer-string))))))) + (unwind-protect + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + output + (signal 'native-compiler-error (buffer-string))) + (comp-log-to-buffer (buffer-string))))))) ;;; Compiler type hints. From 2ab0966b2fdf3a64d061727f005d32c5aad27594 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 16:13:56 +0200 Subject: [PATCH 1058/1452] Make CHECK_SUBR public * src/data.c (CHECK_SUBR): Move from here to... * src/lisp.h (CHECK_SUBR): ...to here. --- src/data.c | 6 ------ src/lisp.h | 6 ++++++ 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/data.c b/src/data.c index 3f035269de1..8c39c319110 100644 --- a/src/data.c +++ b/src/data.c @@ -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) { diff --git a/src/lisp.h b/src/lisp.h index cbc6a666471..452f48f3468 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2982,6 +2982,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 From 2f78ac32bbef78155e2f52e73d60f7b46fc8afea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 16:44:53 +0200 Subject: [PATCH 1059/1452] * Add `comp--install-trampoline' machinery * src/comp.c (Fcomp__install_trampoline): New function to install a subr trampoline into the function relocation table. Once this is done any call from native compiled Lisp to the related primitive will go through the `funcall' trampoline making advicing effective. --- src/comp.c | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/src/comp.c b/src/comp.c index 63a58be264c..db6aee9d7b1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4102,6 +4102,39 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) concat2 (base_dir, Vcomp_native_version_dir)); } +DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, + Scomp__install_trampoline, 2, 2, 0, + doc: /* Install a TRAMPOLINE for primitive SUBR-NAME. */) + (Lisp_Object subr_name, Lisp_Object trampoline) +{ + CHECK_SYMBOL (subr_name); + CHECK_SUBR (trampoline); + Lisp_Object orig_subr = Fsymbol_function (subr_name); + CHECK_SUBR (orig_subr); + + /* FIXME: add a post dump load trampoline machinery to remove this + check. */ + if (will_dump_p ()) + signal_error ("Trying to advice unexpected primitive before dumping", + subr_name); + + Lisp_Object subr_l = Vcomp_subr_list; + ptrdiff_t i = ARRAYELTS (helper_link_table); + FOR_EACH_TAIL (subr_l) + { + Lisp_Object subr = XCAR (subr_l); + if (EQ (subr, orig_subr)) + { + freloc.link_table[i] = XSUBR (trampoline)->function.a0; + return Qt; + } + i++; + } + signal_error ("Trying to install trampoline for non existent subr", + subr_name); + return Qnil; +} + DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) @@ -5162,6 +5195,7 @@ native compiled one. */); defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp_native_driver_options_effective_p); + defsubr (&Scomp__install_trampoline); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); From 3ec1b932c9c57d200c3a3f2fb9a0c59c4acc8011 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 14:52:50 +0200 Subject: [PATCH 1060/1452] * Add `comp--subr-safe-advice' entry point Add a Lisp side entry-point to be called to make primitive adivicing effective. * lisp/emacs-lisp/comp.el (comp-trampoline-sym) (comp-trampoline-filename): New substs. (comp-make-lambda-list-from-subr, comp-search-trampoline) (comp-tampoline-compile): New functions --- lisp/emacs-lisp/comp.el | 75 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2bba298ac0a..f6c6748b748 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2542,6 +2542,81 @@ Prepare every function for final compilation and drive the C back-end." (declare (gv-setter (lambda (val) `(setf ,x ,val)))) x) + +;; Primitive funciton advice machinery + +(defsubst comp-trampoline-sym (subr-name) + "Given SUBR-NAME return the trampoline function name." + (intern (concat "--subr-trampoline-" (symbol-name subr-name)))) + +(defsubst comp-trampoline-filename (subr-name) + "Given SUBR-NAME return the filename containing the trampoline." + (concat (comp-c-func-name subr-name "subr-trampoline-" t) ".eln")) + +(defun comp-make-lambda-list-from-subr (subr) + "Given SUBR return the equivalent lambda-list." + (pcase-let ((`(,min . ,max) (subr-arity subr)) + (lambda-list '())) + (cl-loop repeat min + do (push (gensym "arg") lambda-list)) + (if (numberp max) + (cl-loop + initially (push '&optional lambda-list) + repeat (- max min) + do (push (gensym "arg") lambda-list)) + (push '&rest lambda-list) + (push (gensym "arg") lambda-list)) + (reverse lambda-list))) + +(defun comp-search-trampoline (subr-name) + "Search a trampoline file for SUBR-NAME. +Return the its filename if found or nil otherwise." + (cl-loop + with rel-filename = (comp-trampoline-filename subr-name) + for dir in comp-eln-load-path + for filename = (expand-file-name rel-filename + (concat dir comp-native-version-dir)) + when (file-exists-p filename) + do (cl-return filename))) + +(defun comp-tampoline-compile (subr-name) + "Synthesize and compile a trampoline for SUBR-NAME and return its filename." + (let ((trampoline-sym (comp-trampoline-sym subr-name)) + (lambda-list (comp-make-lambda-list-from-subr + (symbol-function subr-name))) + ;; Use speed 0 to maximize compilation speed and not to + ;; optimize away funcall calls! + (byte-optimize nil) + (comp-speed 0)) + ;; The synthesized trampoline must expose the exact same ABI of + ;; the primitive we are replacing in the function reloc table. + (defalias trampoline-sym + `(closure nil ,lambda-list + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) 'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + (native-compile trampoline-sym nil + (expand-file-name (comp-trampoline-filename subr-name) + (concat (car comp-eln-load-path) + comp-native-version-dir))))) + +;;;###autoload +(defun comp--subr-safe-advice (subr-name) + "Make SUBR-NAME effectively advice-able when called from native code." + (unless (memq subr-name comp-never-optimize-functions) + (let ((trampoline-sym (comp-trampoline-sym subr-name))) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (load (or (comp-search-trampoline subr-name) + (comp-tampoline-compile subr-name)) + nil t) + (cl-assert + (subr-native-elisp-p (symbol-function trampoline-sym))) + (comp--install-trampoline subr-name (symbol-function trampoline-sym))))) + ;; Some entry point support code. From db354ffd578a46d898cac161ea1de1b42f96d2a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 22:33:34 +0200 Subject: [PATCH 1061/1452] Call `comp--subr-safe-advice' from the advice machinery * lisp/emacs-lisp/nadvice.el (advice--add-function): Call `comp--subr-safe-advice' when necessary. * lisp/emacs-lisp/advice.el (ad-add-advice): Likewhise. --- lisp/emacs-lisp/advice.el | 2 ++ lisp/emacs-lisp/nadvice.el | 16 ++++++++++++++++ 2 files changed, 18 insertions(+) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 0ebd2741d2e..4c19197024d 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2075,6 +2075,8 @@ 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 (subr-primitive-p (symbol-function function)) + (comp--subr-safe-advice function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index b779aa27888..32b5df8f261 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -318,6 +318,22 @@ is also interactive. There are 3 cases: ;;;###autoload (defun advice--add-function (where ref function props) + (when (and (boundp 'comp-ctxt) + (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-safe-advice subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a From 0cc1804d42e25e0213f8b3872cc6133c6480a5b0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Sep 2020 09:36:49 +0200 Subject: [PATCH 1062/1452] Add a test for primitive advicing effectiveness * test/src/comp-test-funcs.el (comp-test-primitive-advice-f): New function. * test/src/comp-tests.el (comp-test-primitive-advice): New test. --- test/src/comp-test-funcs.el | 4 ++++ test/src/comp-tests.el | 13 +++++++++++++ 2 files changed, 17 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index fe9943a1b91..19acec2716e 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -337,6 +337,10 @@ (concat head-padding (substring str from-idx idx) tail-padding ellipsis))))) +(defun comp-test-primitive-advice-f (x y) + (declare (speed 2)) + (+ x y)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 220bf1c7736..356bd876ffb 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -375,6 +375,19 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) "Nel mezzo del yyy"))) +(defvar comp-test-primitive-advice) +(ert-deftest comp-test-primitive-advice () + "Test effectiveness of primitve advicing." + (let (comp-test-primitive-advice + (f (lambda (&rest args) + (setq comp-test-primitive-advice args)))) + (advice-add #'+ :before f) + (unwind-protect + (progn + (should (= (comp-test-primitive-advice-f 3 4) 7)) + (should (equal comp-test-primitive-advice '(3 4)))) + (advice-remove #'+ f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From b94a0a931ee7963515c009e7e683e907897567bb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Sep 2020 09:50:01 +0200 Subject: [PATCH 1063/1452] * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Clean-up. --- lisp/emacs-lisp/comp.el | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f6c6748b748..e33d58cb406 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -94,17 +94,11 @@ Skip if any is matching." :group 'comp) (defcustom comp-never-optimize-functions - '(;; Mandatory for Emacs to be working correctly - macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer - make-indirect-buffer delete-file top-level abort-recursive-edit - ;; For user convenience - yes-or-no-p - ;; Make the Evil happy :/ - read-key-sequence select-window set-window-buffer split-window-internal - use-global-map use-local-map) - "Primitive functions for which we do not perform trampoline optimization. -This is especially useful for primitives known to be advised or -redefined when compilation is performed at `comp-speed' > 0." + '(;; The following two are mandatory for Emacs to be working + ;; correctly (see comment in `advice--add-function'). DO NOT + ;; REMOVE. + macroexpand rename-buffer) + "Primitive functions for which we do not perform trampoline optimization." :type 'list :group 'comp) From 94736c413ff728833f260acf125ff3a572e270d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Sep 2020 21:56:52 +0200 Subject: [PATCH 1064/1452] Do not install a subr trampoline twice * src/comp.c (syms_of_comp): Define and initialize 'Vcomp_installed_trampolines_h'. (Fcomp__install_trampoline): Fill 'Vcomp_installed_trampolines_h' * lisp/emacs-lisp/comp.el (comp--subr-safe-advice): Make use of `comp-installed-trampolines-h' to guard against installing a trampoline twice. --- lisp/emacs-lisp/comp.el | 3 ++- src/comp.c | 5 +++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e33d58cb406..8b8b111640a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2601,7 +2601,8 @@ Return the its filename if found or nil otherwise." ;;;###autoload (defun comp--subr-safe-advice (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." - (unless (memq subr-name comp-never-optimize-functions) + (unless (or (memq subr-name comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) (let ((trampoline-sym (comp-trampoline-sym subr-name))) (cl-assert (subr-primitive-p (symbol-function subr-name))) (load (or (comp-search-trampoline subr-name) diff --git a/src/comp.c b/src/comp.c index db6aee9d7b1..15782ccb162 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4126,6 +4126,7 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, if (EQ (subr, orig_subr)) { freloc.link_table[i] = XSUBR (trampoline)->function.a0; + Fputhash (subr_name, Qt, Vcomp_installed_trampolines_h); return Qt; } i++; @@ -5257,6 +5258,10 @@ The last directory of this list is assumed to be the system one. */); dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); + DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, + doc: /* Hash table subr-name -> bool. */); + Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + #endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); From 6d83902ffd0c50a3157c4c61cd636433b212f709 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Sep 2020 21:50:20 +0200 Subject: [PATCH 1065/1452] * lisp/emacs-lisp/comp.el (comp-body-eff): Improve style. --- lisp/emacs-lisp/comp.el | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8b8b111640a..07b0ccee3cb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1127,13 +1127,9 @@ When BODY is auto guess function name form the LAP byte-code name. Otherwise expect lname fnname." (pcase (car body) ('auto - (list `(comp-emit-set-call-subr - ',(comp-op-to-fun op-name) - ,sp-delta))) + `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta))) ((pred symbolp) - (list `(comp-emit-set-call-subr - ',(car body) - ,sp-delta))) + `((comp-emit-set-call-subr ',(car body) ,sp-delta))) (_ body)))) (defmacro comp-op-case (&rest cases) From e5b052d60d905209c6cefcf18c620167ed946301 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Sep 2020 22:01:45 +0200 Subject: [PATCH 1066/1452] Rename comp--subr-safe-advice -> comp-subr-safe-advice * lisp/emacs-lisp/comp.el (comp-subr-safe-advice): Rename comp--subr-safe-advice -> comp-subr-safe-advice. * lisp/emacs-lisp/nadvice.el (advice--add-function): Likewise. * lisp/emacs-lisp/advice.el (ad-add-advice): Likewise. --- lisp/emacs-lisp/advice.el | 2 +- lisp/emacs-lisp/comp.el | 2 +- lisp/emacs-lisp/nadvice.el | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 4c19197024d..4df8743de50 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2076,7 +2076,7 @@ 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 (subr-primitive-p (symbol-function function)) - (comp--subr-safe-advice function)) + (comp-subr-safe-advice function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 07b0ccee3cb..cac63a59785 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2595,7 +2595,7 @@ Return the its filename if found or nil otherwise." comp-native-version-dir))))) ;;;###autoload -(defun comp--subr-safe-advice (subr-name) +(defun comp-subr-safe-advice (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." (unless (or (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 32b5df8f261..5b3aa708508 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -333,7 +333,7 @@ is also interactive. There are 3 cases: ;; Must require explicitly as during bootstrap we have no ;; autoloads. (require 'comp) - (comp--subr-safe-advice subr-name)))) + (comp-subr-safe-advice subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a From 29a8d9303bd3098eed88f3eb7394b66ae28cc887 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Sep 2020 14:28:36 +0200 Subject: [PATCH 1067/1452] * lisp/emacs-lisp/cl-macs.el (cl--optimize): Add a FIXME. --- lisp/emacs-lisp/cl-macs.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e7c7374976a..9c41374fc70 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2359,6 +2359,8 @@ 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 From dc0cf16c7a60f36aafcf9b56513a855cefa7e1ad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Sep 2020 15:12:30 +0200 Subject: [PATCH 1068/1452] Always set 'Vexec_path' before 'Vinvocation_directory' (bug#43137) Do this as depending on the OS if argv0 is not populated 'Vexec_path' is used to infer 'Vinvocation_directory'. * src/pdumper.c (pdumper_load): Invoke 'init_vars_for_load' instead of 'set_invocation_vars'. * src/lisp.h: Extern 'init_vars_for_load' instead of 'set_invocation_vars' . * src/emacs.c (set_invocation_vars): Make it static and remove double invocation guard. (init_vars_for_load): Wrap 'init_callproc_1' and 'set_invocation_vars' calls + add double invocation guard. (init_cmdargs): Move out 'set_invocation_vars' invocation. (main): Call 'init_vars_for_load' instead of 'init_callproc_1'. --- src/emacs.c | 32 +++++++++++++++++++++----------- src/lisp.h | 2 +- src/pdumper.c | 3 ++- 3 files changed, 24 insertions(+), 13 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index 07e40fdc8bd..1f7f5eabc56 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -413,16 +413,9 @@ terminate_due_to_signal (int sig, int backtrace_limit) /* Set `invocation-name' `invocation-directory'. */ -void +static void set_invocation_vars (char *argv0, char const *original_pwd) { - /* This function can be called from within pdumper or later during - boot. No need to run it twice. */ - static bool double_run_guard; - if (double_run_guard) - return; - double_run_guard = true; - Lisp_Object raw_name, handler; AUTO_STRING (slash_colon, "/:"); @@ -480,6 +473,25 @@ set_invocation_vars (char *argv0, char const *original_pwd) } } +/* Initialize a number of variables (ultimately + 'Vinvocation_directory') needed by pdumper to complete native code + load. */ + +void +init_vars_for_load (char *argv0, char const *original_pwd) +{ + /* This function is called from within pdumper while loading (as + soon as we are able to allocate) or later during boot if pdumper + is not used. No need to run it twice. */ + static bool double_run_guard; + if (double_run_guard) + return; + double_run_guard = true; + + init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */ + set_invocation_vars (argv0, original_pwd); +} + /* Code for dealing with Lisp access to the Unix command line. */ static void @@ -492,8 +504,6 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) initial_argv = argv; initial_argc = argc; - set_invocation_vars (argv[0], original_pwd); - Vinstallation_directory = Qnil; if (!NILP (Vinvocation_directory)) @@ -1788,7 +1798,7 @@ 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. */ + init_vars_for_load (argv[0], original_pwd); /* Must precede init_lread. */ init_cmdargs (argc, argv, skip_args, original_pwd); diff --git a/src/lisp.h b/src/lisp.h index 452f48f3468..e33577b5633 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4430,7 +4430,7 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); -extern void set_invocation_vars (char *argv0, char const *original_pwd); +extern void init_vars_for_load (char *, char const *); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif diff --git a/src/pdumper.c b/src/pdumper.c index 0a7e0388f1d..03391c49505 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5587,7 +5587,8 @@ pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) /* Once we can allocate and before loading .eln files we must set Vinvocation_directory (.eln paths are relative to it). */ - set_invocation_vars (argv0, original_pwd); + init_vars_for_load (argv0, original_pwd); + 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); initialized = true; From a06fe08e8e8177ae3ccd6e2677b40237cd86ae9d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Sep 2020 17:20:55 +0200 Subject: [PATCH 1069/1452] Clean-up some now unnecessary diff against master * lisp/emacs-lisp/autoload.el (update-directory-autoloads): .eln files have been moved so remove the '.eln' match. * lisp/emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded): Likewise. * lisp/emacs-lisp/find-func.el (find-library-suffixes): Clean-up as '.eln' is no more in `load-suffixes'. * lisp/help-fns.el (find-lisp-object-file-name): Clean-up as `symbol-file' will return the '.elc' file. * src/lread.c (Fget_load_suffixes): Remove logic as '.eln' is not anymore in load-suffixes. (openp): Two spaces. --- lisp/emacs-lisp/autoload.el | 2 +- lisp/emacs-lisp/bytecomp.el | 3 +-- lisp/emacs-lisp/find-func.el | 3 +-- lisp/help-fns.el | 11 +++-------- src/lread.c | 23 +++-------------------- 5 files changed, 9 insertions(+), 33 deletions(-) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 4bdbc95081f..5ee0a14273f 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1047,7 +1047,7 @@ write its autoloads into the specified file instead." ;; we don't want to depend on whether Emacs was ;; built with or without modules support, nor ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|eln\\|so\\|dll\\)" suf) + (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) (push suf tmp))) (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4a2a8c62cbc..b0e3158df32 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5180,8 +5180,7 @@ Use with caution." (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) - (when (string-match "el[cn]\\'" f) - (setq f (substring f 0 -1))) + (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) (when (and (file-readable-p f) (file-newer-than-file-p f emacs-file) ;; Don't reload the source version of the files below diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index a4577a53164..9e4d8cf1aa8 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -167,8 +167,7 @@ See the functions `find-function' and `find-variable'." (defun find-library-suffixes () (let ((suffixes nil)) (dolist (suffix (get-load-suffixes) (nreverse suffixes)) - (unless (string-match "el[cn]" suffix) - (push suffix suffixes))))) + (unless (string-match "elc" suffix) (push suffix suffixes))))) (defun find-library--load-name (library) (let ((name library)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 88984ec453e..9fee156f18f 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -323,17 +323,12 @@ found via `load-path'. The return value can also be `C-source', which means that OBJECT is a function or variable defined in C. If no suitable file is found, return nil." (let* ((autoloaded (autoloadp type)) - (true-name (or (and autoloaded (nth 1 type)) + (file-name (or (and autoloaded (nth 1 type)) (symbol-file ;; FIXME: Why do we have this weird "If TYPE is the ;; value returned by `symbol-function' for a function ;; symbol" exception? - object (or (if (symbolp type) type) 'defun)))) - (file-name (if (and true-name - (string-match "[.]eln\\'" true-name)) - (gethash (file-name-nondirectory true-name) - comp-eln-to-el-h) - true-name))) + object (or (if (symbolp type) type) 'defun))))) (cond (autoloaded ;; An autoloaded function: Locate the file since `symbol-function' @@ -392,7 +387,7 @@ suitable file is found, return nil." ((let ((lib-name (if (string-match "[.]elc\\'" file-name) (substring-no-properties file-name 0 -1) - file-name))) + file-name))) (or (and (file-readable-p lib-name) lib-name) ;; The library might be compressed. (and (file-readable-p (concat lib-name ".gz")) lib-name)))) diff --git a/src/lread.c b/src/lread.c index d32f5755e98..ea31131b755 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1056,25 +1056,8 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) { Lisp_Object exts = Vload_file_rep_suffixes; Lisp_Object suffix = XCAR (suffixes); - bool native_code_suffix = - NATIVE_COMP_FLAG - && strcmp (NATIVE_ELISP_SUFFIX, SSDATA (suffix)) == 0; - -#ifdef HAVE_MODULES - native_code_suffix = - native_code_suffix || strcmp (MODULES_SUFFIX, SSDATA (suffix)) == 0; -#ifdef MODULES_SECONDARY_SUFFIX - native_code_suffix = - native_code_suffix - || strcmp (MODULES_SECONDARY_SUFFIX, SSDATA (suffix)) == 0; -#endif -#endif - - if (native_code_suffix) - lst = Fcons (suffix, lst); - else - FOR_EACH_TAIL (exts) - lst = Fcons (concat2 (suffix, XCAR (exts)), lst); + FOR_EACH_TAIL (exts) + lst = Fcons (concat2 (suffix, XCAR (exts)), lst); } return Fnreverse (lst); } @@ -1698,6 +1681,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; + /* The last-modified time of the newest matching file found. Initialize it to something less than all valid timestamps. */ struct timespec save_mtime = make_timespec (TYPE_MINIMUM (time_t), -1); @@ -1898,7 +1882,6 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; - SAFE_FREE (); return fd; } From bb2a334a2061222ac1e701b557e5ce6dc0dad941 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Sep 2020 21:09:00 +0200 Subject: [PATCH 1070/1452] * src/lisp.h: Remove a newline diff left over master. --- src/lisp.h | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lisp.h b/src/lisp.h index e33577b5633..a1bdfe89d3a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4735,6 +4735,7 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); + #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ extern char *emacs_root_dir (void); From 3129b3ffcb85be4acd1284616675025104d3c661 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Sep 2020 21:09:00 +0200 Subject: [PATCH 1071/1452] Rename in docstrings "non nil" into "non-nil" * lisp/emacs-lisp/comp.el: Rename non nil -> non-nil in doc. * src/comp.c: Likewise. --- lisp/emacs-lisp/comp.el | 18 +++++++++--------- src/comp.c | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cac63a59785..e1438fbb2fa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -139,7 +139,7 @@ and above." :group 'comp) (defvar comp-dry-run nil - "When non nil run everything but the C back-end.") + "When non-nil run everything but the C back-end.") (defconst comp-valid-source-re (rx ".el" (? ".gz") eos) "Regexp to match filename of valid input source files.") @@ -271,7 +271,7 @@ This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean - :documentation "When non nil support late load.")) + :documentation "When non-nil support late load.")) (cl-defstruct comp-args-base (min nil :type number @@ -321,7 +321,7 @@ Is in use to help the SSA rename pass.")) "A basic block created from lap." ;; These two slots are used during limplification. (sp nil :type number - :documentation "When non nil indicates the sp value while entering + :documentation "When non-nil indicates the sp value while entering into it.") (addr nil :type number :documentation "Start block LAP address.")) @@ -407,10 +407,10 @@ structure.") (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil - :documentation "When const-vld non nil this is used for holding + :documentation "When const-vld non-nil this is used for holding a value known at compile time.") (type nil :type symbol - :documentation "When non nil indicates the type when known at compile + :documentation "When non-nil indicates the type when known at compile time.")) ;; Special vars used by some passes @@ -881,7 +881,7 @@ STACK-OFF is the index of the first slot frame involved." (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. -If SSA non nil populate it of m-var in ssa form." +If SSA non-nil populate it of m-var in ssa form." (cl-loop with v = (make-vector size nil) for i below size for mvar = (if ssa @@ -1490,7 +1490,7 @@ These are stored in the reloc data array." (defun comp-limplify-top-level (for-late-load) "Create a limple function to modify the global environment at load. -When FOR-LATE-LOAD is non nil the emitted function modifies only +When FOR-LATE-LOAD is non-nil the emitted function modifies only function definition. Synthesize a function called 'top_level_run' that gets one single @@ -1876,7 +1876,7 @@ into the C code forwarding the compilation unit." (defun comp-dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. -PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." +PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda (funcall pre-lambda bb)) (when-let ((out-edges (comp-block-out-edges bb))) @@ -2043,7 +2043,7 @@ Forward propagate immediate involed in assignments." (comp-mvar-type lval) (comp-mvar-type rval))) (defsubst comp-function-optimizable-p (f args) - "Given function F called with ARGS return non nil when optimizable." + "Given function F called with ARGS return non-nil when optimizable." (and (cl-every #'comp-mvar-const-vld args) (comp-function-pure-p f))) diff --git a/src/comp.c b/src/comp.c index 15782ccb162..0b42582ab29 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5019,7 +5019,7 @@ file_in_eln_sys_dir (Lisp_Object filename) /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. - LATE_LOAD has to be non nil when loading for deferred + LATE_LOAD has to be non-nil when loading for deferred compilation. */) (Lisp_Object filename, Lisp_Object late_load) { From 89f064104c25f8b4362ef54d28fd4bce18f6af3b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Sep 2020 21:09:00 +0200 Subject: [PATCH 1072/1452] * Some clean-up in comp.el * lisp/emacs-lisp/comp.el (comp-emit-cond-jump, comp-emit-switch) (comp-limplify-block, comp-compute-edges) (comp-ssa-rename, comp-fwprop*, comp-effective-async-max-jobs) (comp-run-async-workers): Respect max 80 columns. (batch-byte-native-compile-for-bootstrap): Improve doc + remove some now unnecessary error handling. --- lisp/emacs-lisp/comp.el | 73 +++++++++++++++++++++++------------------ 1 file changed, 41 insertions(+), 32 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1438fbb2fa..dec5c8ec41d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -973,8 +973,9 @@ block. If NEGATED non null negate the tested condition. Return value is the fall through block name." (cl-destructuring-bind (label-num . label-sp) lap-label - (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)))) ; Fall through block. + (let* ((bb (comp-block-name (comp-bb-maybe-add + (1+ (comp-limplify-pc comp-pass)) + (comp-sp)))) ; Fall through block. (target-sp (+ target-offset (comp-sp))) (target-addr (comp-label-to-addr label-num)) (target (comp-bb-maybe-add target-addr target-sp)) @@ -1065,8 +1066,9 @@ Return value is the fall through block name." for n from 1 for last = (= n len) for m-test = (make-comp-mvar :constant test) - for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) - (comp-sp))) + for target-name = (comp-block-name (comp-bb-maybe-add + (comp-label-to-addr target-label) + (comp-sp))) for ff-bb = (if last (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)) @@ -1562,7 +1564,9 @@ into the C code forwarding the compilation unit." (let* ((stack-depth (if label-sp (1- label-sp) (comp-sp))) - (next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) + (next-bb (comp-block-name (comp-bb-maybe-add + (comp-limplify-pc comp-pass) + stack-depth)))) (unless (comp-block-closed bb) (comp-emit `(jump ,next-bb)))) (cl-return))) @@ -1733,14 +1737,17 @@ into the C code forwarding the compilation unit." (list "block does not end with a branch" bb (comp-func-name comp-func))))) - finally (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - ;; Update edge refs into blocks. - (cl-loop for edge in (comp-func-edges comp-func) - do (push edge - (comp-block-out-edges (comp-edge-src edge))) - (push edge - (comp-block-in-edges (comp-edge-dst edge)))) + finally + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop + for edge in (comp-func-edges comp-func) + do + (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) (comp-log-edges comp-func)))) (defun comp-collect-rev-post-order (basic-block) @@ -1932,10 +1939,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (setf (comp-block-final-frame bb) (copy-sequence in-frame)) (when-let ((out-edges (comp-block-out-edges bb))) - (cl-loop for ed in out-edges - for child = (comp-edge-dst ed) - ;; Provide a copy of the same frame to all childs. - do (ssa-rename-rec child (copy-sequence in-frame))))))) + (cl-loop + for ed in out-edges + for child = (comp-edge-dst ed) + ;; Provide a copy of the same frame to all children. + do (ssa-rename-rec child (copy-sequence in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) (comp-new-frame frame-size t))))) @@ -2118,7 +2126,8 @@ Return t if something was changed." (cl-loop with modified = nil for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) - for orig-insn = (unless modified ; Save consing after 1th change. + for orig-insn = (unless modified + ;; Save consing after 1th change. (comp-copy-insn insn)) do (comp-fwprop-insn insn) when (and (null modified) (not (equal insn orig-insn))) @@ -2689,9 +2698,11 @@ processes from `comp-async-compilations'" ;; the number of processors, see get_native_system_info in w32.c. ;; The result needs to be exported to Lisp. (max 1 (/ (cond ((eq 'windows-nt system-type) - (string-to-number (getenv "NUMBER_OF_PROCESSORS"))) + (string-to-number (getenv + "NUMBER_OF_PROCESSORS"))) ((executable-find "nproc") - (string-to-number (shell-command-to-string "nproc"))) + (string-to-number + (shell-command-to-string "nproc"))) (t 1)) 2)))) comp-async-jobs-number)) @@ -2712,8 +2723,8 @@ display a message." when (or comp-always-compile load ; Always compile when the compilation is ; commanded for late load. - (file-newer-than-file-p source-file - (comp-el-to-eln-filename source-file))) + (file-newer-than-file-p + source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn (require 'comp) (setf comp-speed ,comp-speed @@ -2841,21 +2852,18 @@ Ultra cheap impersonation of `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. -Always generate elc files too and handle native compiler expected errors." +Generate .elc files in addition to the .eln one. If the +environment variable 'NATIVE_DISABLED' is set byte compile only." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (= 1 (length command-line-args-left))) (let ((byte-native-for-bootstrap t) (byte-to-native-output-file nil)) - (unwind-protect - (condition-case _ - (batch-native-compile) - (native-compiler-error-dyn-func) - (native-compiler-error-empty-byte)) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t))))))) + (batch-native-compile) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t)))))) ;;;###autoload (defun native-compile-async (paths &optional recursively load) @@ -2874,7 +2882,8 @@ LOAD can be nil t or 'late." (dolist (path paths) (cond ((file-directory-p path) (dolist (file (if recursively - (directory-files-recursively path comp-valid-source-re) + (directory-files-recursively + path comp-valid-source-re) (directory-files path t comp-valid-source-re))) (push file files))) ((file-exists-p path) (push path files)) From 86e37ea8c5c758b6d22308104755a396816d8768 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 30 Sep 2020 15:19:18 +0200 Subject: [PATCH 1073/1452] * .gitlab-ci.yml: Uncomment some testing to align with master. --- .gitlab-ci.yml | 93 ++++++++++++++++++++++++-------------------------- 1 file changed, 45 insertions(+), 48 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 93929f211cd..e5ebd6a92a1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -37,58 +37,55 @@ before_script: stages: - test -# FIXME: Commented for this branch till is known to be broken. -# test-all: -# # This tests also file monitor libraries inotify and inotifywatch. -# stage: test -# only: -# changes: -# - "Makefile.in" -# - .gitlab-ci.yml -# - aclocal.m4 -# - autogen.sh -# - configure.ac -# - lib/*.{h,c} -# - lisp/*.el -# - lisp/**/*.el -# - src/*.{h,c} -# - test/lisp/*.el -# - test/lisp/**/*.el -# - test/src/*.el -# except: -# changes: -# # gfilemonitor, kqueue -# - src/gfilenotify.c -# - src/kqueue.c -# # MS Windows -# - lisp/w32*.el -# - lisp/term/w32*.el -# - src/w32*.{h,c} -# # GNUstep -# - lisp/term/ns-win.el -# - src/ns*.{h,m} -# - src/macfont.{h,m} -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools -# - ./autogen.sh autoconf -# - ./configure --without-makeinfo -# - make bootstrap -# - make check-expensive +test-all: + # This tests also file monitor libraries inotify and inotifywatch. + stage: test + only: + changes: + - "Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/*.el + - lisp/**/*.el + - src/*.{h,c} + - test/lisp/*.el + - test/lisp/**/*.el + - test/src/*.el + except: + changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - lisp/w32*.el + - lisp/term/w32*.el + - src/w32*.{h,c} + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools + - ./autogen.sh autoconf + - ./configure --without-makeinfo + - make bootstrap + - make check-expensive test-filenotify-gio: stage: test # This tests file monitor libraries gfilemonitor and gio. - - ## Commented to keep stock bootstrap tested. - # only: - # changes: - # - .gitlab-ci.yml - # - lisp/autorevert.el - # - lisp/filenotify.el - # - lisp/net/tramp-sh.el - # - src/gfilenotify.c - # - test/lisp/autorevert-tests.el - # - test/lisp/filenotify-tests.el + only: + changes: + - .gitlab-ci.yml + - lisp/autorevert.el + - lisp/filenotify.el + - lisp/net/tramp-sh.el + - src/gfilenotify.c + - test/lisp/autorevert-tests.el + - test/lisp/filenotify-tests.el script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 - ./autogen.sh autoconf From ec23b719e5350f70f731060bca04d5b23887f08c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 30 Sep 2020 16:53:32 +0200 Subject: [PATCH 1074/1452] * Improve some docstring in src/comp.c * src/comp.c (Fcomp_el_to_eln_filename) (Fcomp__compile_ctxt_to_file): Improve docstring. (Fcomp__compile_ctxt_to_file): Rename 'file_name' -> 'filename'. (Fnative_comp_available_p): Improve docstring. --- src/comp.c | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0b42582ab29..058ce7e96ac 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4015,7 +4015,7 @@ static Lisp_Object loadsearch_re_list; DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Given a source file return the corresponding .eln true filename. + doc: /* Given a source FILENAME return the corresponding .eln filename. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { @@ -4363,13 +4363,13 @@ restore_sigmask (void) DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, - doc: /* Compile as native code the current context to file. */) - (Lisp_Object file_name) + doc: /* Compile as native code the current context to file FILENAME. */) + (Lisp_Object filename) { load_gccjit_if_necessary (true); - CHECK_STRING (file_name); - Lisp_Object base_name = Fsubstring (file_name, Qnil, make_fixnum (-4)); + CHECK_STRING (filename); + Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -4441,16 +4441,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (err) xsignal3 (Qnative_ice, build_string ("failed to compile"), - file_name, + filename, build_string (err)); - CALL1I (comp-clean-up-stale-eln, file_name); - CALL2I (comp-delete-or-replace-file, file_name, tmp_file); + CALL1I (comp-clean-up-stale-eln, filename); + CALL2I (comp-delete-or-replace-file, filename, tmp_file); if (!noninteractive) unbind_to (count, Qnil); - return file_name; + return filename; } DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, @@ -5068,7 +5068,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, DEFUN ("native-comp-available-p", Fnative_comp_available_p, Snative_comp_available_p, 0, 0, 0, doc: /* Returns t if native compilation of Lisp files is available in -this instance of Emacs. */) +this instance of Emacs, nil otherwise. */) (void) { #ifdef HAVE_NATIVE_COMP From 2cc82563d288f5fa1bf1f763eae7934320d40014 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 1 Oct 2020 07:55:00 +0200 Subject: [PATCH 1075/1452] * lisp/emacs-lisp/comp.el (comp-c-func-name): Add autoload cookie. --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dec5c8ec41d..02b08119f9c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -598,6 +598,8 @@ instruction." (or (comp-spill-decl-spec function-name 'speed) comp-speed)) +;; Autoloaded as might by used by `disassemble-internal'. +;;;###autoload (defun comp-c-func-name (name prefix &optional first) "Given NAME return a name suitable for the native code. Add PREFIX in front of it. If FIRST is not nil pick the first From ddf1b1931c7072d83d7b114a191fad92bb1000b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 1 Oct 2020 18:04:00 +0200 Subject: [PATCH 1076/1452] * test/src/comp-tests.el (comp-tests-bootstrap): Tag it as expensive. --- test/src/comp-tests.el | 1 + 1 file changed, 1 insertion(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 356bd876ffb..f76afdbf1ce 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -46,6 +46,7 @@ (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." + :tags '(:expensive-test) (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) From f345622152786388f4689f81f91acabe6eab9500 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 09:52:40 +0200 Subject: [PATCH 1077/1452] Clean-up testsuite for vanilla builds Tag all native compiler tests and skip them in vanilla builds * test/Makefile.in (SELECTOR_DEFAULT, SELECTOR_EXPENSIVE) (SELECTOR_ALL): Define selectors for vanilla or nativecomp builds. * test/src/comp-tests.el: Do not native compile test files on vanilla. (comp-deftest): New macro to define tests tagging as :nativecomp. --- test/Makefile.in | 7 ++ test/src/comp-tests.el | 159 ++++++++++++++++++++++------------------- 2 files changed, 91 insertions(+), 75 deletions(-) diff --git a/test/Makefile.in b/test/Makefile.in index 9974eb54b03..4a5cbee8c86 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -70,6 +70,7 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ # We never change directory before running Emacs, so a relative file # name is fine, and makes life easier. If we need to change @@ -138,9 +139,15 @@ test_module_dir := data/emacs-module 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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f76afdbf1ce..f954ae6a9dd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -37,16 +37,25 @@ (defconst comp-test-dyn-src (concat comp-test-directory "comp-test-funcs-dyn.el")) -(message "Compiling tests...") -(load (native-compile comp-test-src)) -(load (native-compile comp-test-dyn-src)) +(when (boundp 'comp-ctxt) + (message "Compiling tests...") + (load (native-compile comp-test-src)) + (load (native-compile comp-test-dyn-src))) + +(defmacro comp-deftest (name args &rest docstring-and-body) + "Define a test for the native compiler tagging it as :nativecomp." + (declare (indent defun) + (doc-string 3)) + `(ert-deftest ,(intern (concat "compt-tests-" (symbol-name name))) ,args + :tags '(:nativecomp) + ,@docstring-and-body)) (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." - :tags '(:expensive-test) + :tags '(:expensive-test :nativecomp) (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) @@ -71,15 +80,15 @@ Check that the resulting binaries do not differ." (message "Comparing %s %s" comp1-eln comp2-eln) (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) -(ert-deftest comp-tests-provide () +(comp-deftest provide () "Testing top level provide." (should (featurep 'comp-test-funcs))) -(ert-deftest comp-tests-varref () +(comp-deftest varref () "Testing varref." (should (= (comp-tests-varref-f) 3))) -(ert-deftest comp-tests-list () +(comp-deftest list () "Testing cons car cdr." (should (equal (comp-tests-list-f) '(1 2 3))) (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) @@ -96,12 +105,12 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-safe-f 'a)))) -(ert-deftest comp-tests-cons-car-cdr () +(comp-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-cdr-f 3) 3))) -(ert-deftest comp-tests-varset () +(comp-deftest varset () "Testing varset." (comp-tests-varset0-f) (should (= comp-tests-var1 55)) @@ -109,23 +118,23 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-varset1-f) 4)) (should (= comp-tests-var1 66))) -(ert-deftest comp-tests-length () +(comp-deftest length () "Testing length." (should (= (comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref-aset () +(comp-deftest aref-aset () "Testing aref and aset." (should (= (comp-tests-aref-aset-f) 100))) -(ert-deftest comp-tests-symbol-value () +(comp-deftest symbol-value () "Testing aref and aset." (should (= (comp-tests-symbol-value-f) 3))) -(ert-deftest comp-tests-concat () +(comp-deftest concat () "Testing concatX opcodes." (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) -(ert-deftest comp-tests-ffuncall () +(comp-deftest ffuncall () "Test calling conventions." ;; (defun comp-tests-ffuncall-caller-f () @@ -171,7 +180,7 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-ffuncall-lambda-f 1) 2))) -(ert-deftest comp-tests-jump-table () +(comp-deftest jump-table () "Testing jump tables" (should (eq (comp-tests-jump-table-1-f 'x) 'a)) (should (eq (comp-tests-jump-table-1-f 'y) 'b)) @@ -181,14 +190,14 @@ Check that the resulting binaries do not differ." (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) -(ert-deftest comp-tests-conditionals () +(comp-deftest conditionals () "Testing conditionals." (should (= (comp-tests-conditionals-1-f t) 1)) (should (= (comp-tests-conditionals-1-f nil) 2)) (should (= (comp-tests-conditionals-2-f t) 1340)) (should (eq (comp-tests-conditionals-2-f nil) nil))) -(ert-deftest comp-tests-fixnum () +(comp-deftest fixnum () "Testing some fixnum inline operation." (should (= (comp-tests-fixnum-1-minus-f 10) 9)) (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) @@ -206,13 +215,13 @@ Check that the resulting binaries do not differ." (should-error (comp-tests-fixnum-minus-f 'a) :type 'wrong-type-argument)) -(ert-deftest comp-tests-type-hints () +(comp-deftest type-hints () "Just test compiler hints are transparent in this case." ;; FIXME we should really check they are also effective. (should (= (comp-tests-hint-fixnum-f 3) 4)) (should (= (comp-tests-hint-cons-f (cons 1 2)) 1))) -(ert-deftest comp-tests-arith-comp () +(comp-deftest arith-comp () "Testing arithmetic comparisons." (should (eq (comp-tests-eqlsign-f 4 3) nil)) (should (eq (comp-tests-eqlsign-f 3 3) t)) @@ -230,7 +239,7 @@ Check that the resulting binaries do not differ." (should (eq (comp-tests-geq-f 3 3) t)) (should (eq (comp-tests-geq-f 2 3) nil))) -(ert-deftest comp-tests-setcarcdr () +(comp-deftest setcarcdr () "Testing setcar setcdr." (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) @@ -239,14 +248,14 @@ Check that the resulting binaries do not differ." (should-error (comp-tests-setcdr-f 3 10) :type 'wrong-type-argument)) -(ert-deftest comp-tests-bubble-sort () +(comp-deftest bubble-sort () "Run bubble sort." (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) -(ert-deftest comp-test-apply () +(comp-deftest apply () "Test some inlined list functions." (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil)) @@ -254,7 +263,7 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-setcar2-f x) 3)) (should (equal x '(3 . 2))))) -(ert-deftest comp-tests-num-inline () +(comp-deftest num-inline () "Test some inlined number functions." (should (eq (comp-tests-integerp-f 1) t)) (should (eq (comp-tests-integerp-f '(1)) nil)) @@ -265,7 +274,7 @@ Check that the resulting binaries do not differ." (should (eq (comp-tests-numberp-f 'a) nil)) (should (eq (comp-tests-numberp-f 3.5) t))) -(ert-deftest comp-tests-stack () +(comp-deftest stack () "Test some stack operation." (should (= (comp-tests-discardn-f 10) 2)) (should (string= (with-temp-buffer @@ -273,7 +282,7 @@ Check that the resulting binaries do not differ." (buffer-string)) "abcd"))) -(ert-deftest comp-tests-non-locals () +(comp-deftest non-locals () "Test non locals." (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) @@ -285,53 +294,53 @@ Check that the resulting binaries do not differ." (should (= (catch 'foo (comp-tests-throw-f 3))))) -(ert-deftest comp-tests-gc () +(comp-deftest gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) (comp-tests-cons-cdr-f 3)) (should (= (comp-tests-cons-cdr-f 3) 3))) -(ert-deftest comp-tests-buffer () +(comp-deftest buffer () (should (string= (comp-tests-buff0-f) "foo"))) -(ert-deftest comp-tests-lambda-return () +(comp-deftest lambda-return () (let ((f (comp-tests-lambda-return-f))) (should (subr-native-elisp-p f)) (should (= (funcall f 3) 4)))) -(ert-deftest comp-tests-recursive () +(comp-deftest recursive () (should (= (comp-tests-fib-f 10) 55))) -(ert-deftest comp-tests-macro () +(comp-deftest macro () "Just check we can define macros" (should (macrop (symbol-function 'comp-tests-macro-m)))) -(ert-deftest comp-tests-string-trim () +(comp-deftest string-trim () (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) -(ert-deftest comp-tests-trampoline-removal () +(comp-deftest trampoline-removal () ;; This tests that we can can call primitives with no dedicated bytecode. ;; At speed >= 2 the trampoline will not be used. (should (hash-table-p (comp-tests-trampoline-removal-f)))) -(ert-deftest comp-tests-signal () +(comp-deftest signal () (should (equal (condition-case err (comp-tests-signal-f) (t err)) '(foo . t)))) -(ert-deftest comp-tests-func-call-removal () +(comp-deftest func-call-removal () ;; See `comp-propagate-insn' `comp-function-call-remove'. (should (= (comp-tests-func-call-removal-f) 1))) -(ert-deftest comp-tests-doc () +(comp-deftest doc () (should (string= (documentation #'comp-tests-doc-f) "A nice docstring")) ;; Check a preloaded function, we can't use `comp-tests-doc-f' now ;; as this is loaded manually with no .elc. (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) -(ert-deftest comp-test-interactive-form () +(comp-deftest interactive-form () (should (equal (interactive-form #'comp-test-interactive-form0-f) '(interactive "D"))) (should (equal (interactive-form #'comp-test-interactive-form1-f) @@ -343,7 +352,7 @@ Check that the resulting binaries do not differ." comp-test-interactive-form2-f))) (should-not (commandp #'comp-tests-doc-f))) -(ert-deftest comp-tests-free-fun () +(comp-deftest free-fun () "Check we are able to compile a single function." (eval '(defun comp-tests-free-fun-f () "Some doc." @@ -360,24 +369,24 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) -(ert-deftest comp-test-40187 () +(comp-deftest bug-40187 () "Check function name shadowing. https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-40187-1-f) 'foo)) (should (eq (comp-test-40187-2-f) 'bar))) -(ert-deftest comp-test-speed--1 () +(comp-deftest speed--1 () "Check that at speed -1 we do not native compile." (should (= (comp-test-speed--1-f) 3)) (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) -(ert-deftest comp-test-42360 () +(comp-deftest bug-42360 () "." (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) "Nel mezzo del yyy"))) (defvar comp-test-primitive-advice) -(ert-deftest comp-test-primitive-advice () +(comp-deftest primitive-advice () "Test effectiveness of primitve advicing." (let (comp-test-primitive-advice (f (lambda (&rest args) @@ -394,65 +403,65 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ;; Tromey's tests. ;; ;;;;;;;;;;;;;;;;;;;;; -(ert-deftest comp-consp () +(comp-deftest consp () (should-not (comp-test-consp 23)) (should-not (comp-test-consp nil)) (should (comp-test-consp '(1 . 2)))) -(ert-deftest comp-listp () +(comp-deftest listp () (should-not (comp-test-listp 23)) (should (comp-test-listp nil)) (should (comp-test-listp '(1 . 2)))) -(ert-deftest comp-stringp () +(comp-deftest stringp () (should-not (comp-test-stringp 23)) (should-not (comp-test-stringp nil)) (should (comp-test-stringp "hi"))) -(ert-deftest comp-symbolp () +(comp-deftest symbolp () (should-not (comp-test-symbolp 23)) (should-not (comp-test-symbolp "hi")) (should (comp-test-symbolp 'whatever))) -(ert-deftest comp-integerp () +(comp-deftest integerp () (should (comp-test-integerp 23)) (should-not (comp-test-integerp 57.5)) (should-not (comp-test-integerp "hi")) (should-not (comp-test-integerp 'whatever))) -(ert-deftest comp-numberp () +(comp-deftest numberp () (should (comp-test-numberp 23)) (should (comp-test-numberp 57.5)) (should-not (comp-test-numberp "hi")) (should-not (comp-test-numberp 'whatever))) -(ert-deftest comp-add1 () +(comp-deftest add1 () (should (eq (comp-test-add1 23) 24)) (should (eq (comp-test-add1 -17) -16)) (should (eql (comp-test-add1 1.0) 2.0)) (should-error (comp-test-add1 nil) :type 'wrong-type-argument)) -(ert-deftest comp-sub1 () +(comp-deftest sub1 () (should (eq (comp-test-sub1 23) 22)) (should (eq (comp-test-sub1 -17) -18)) (should (eql (comp-test-sub1 1.0) 0.0)) (should-error (comp-test-sub1 nil) :type 'wrong-type-argument)) -(ert-deftest comp-negate () +(comp-deftest negate () (should (eq (comp-test-negate 23) -23)) (should (eq (comp-test-negate -17) 17)) (should (eql (comp-test-negate 1.0) -1.0)) (should-error (comp-test-negate nil) :type 'wrong-type-argument)) -(ert-deftest comp-not () +(comp-deftest not () (should (eq (comp-test-not 23) nil)) (should (eq (comp-test-not nil) t)) (should (eq (comp-test-not t) nil))) -(ert-deftest comp-bobp-and-eobp () +(comp-deftest bobp-and-eobp () (with-temp-buffer (should (comp-test-bobp)) (should (comp-test-eobp)) @@ -468,7 +477,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should-not (comp-test-bobp)) (should (comp-test-eobp)))) -(ert-deftest comp-car-cdr () +(comp-deftest car-cdr () (let ((pair '(1 . b))) (should (eq (comp-test-car pair) 1)) (should (eq (comp-test-car nil) nil)) @@ -479,7 +488,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should-error (comp-test-cdr 23) :type 'wrong-type-argument))) -(ert-deftest comp-car-cdr-safe () +(comp-deftest car-cdr-safe () (let ((pair '(1 . b))) (should (eq (comp-test-car-safe pair) 1)) (should (eq (comp-test-car-safe nil) nil)) @@ -488,59 +497,59 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-cdr-safe nil) nil)) (should (eq (comp-test-cdr-safe 23) nil)))) -(ert-deftest comp-eq () +(comp-deftest eq () (should (comp-test-eq 'a 'a)) (should (comp-test-eq 5 5)) (should-not (comp-test-eq 'a 'b))) -(ert-deftest comp-if () +(comp-deftest if () (should (eq (comp-test-if 'a 'b) 'a)) (should (eq (comp-test-if 0 23) 0)) (should (eq (comp-test-if nil 'b) 'b))) -(ert-deftest comp-and () +(comp-deftest and () (should (eq (comp-test-and 'a 'b) 'b)) (should (eq (comp-test-and 0 23) 23)) (should (eq (comp-test-and nil 'b) nil))) -(ert-deftest comp-or () +(comp-deftest or () (should (eq (comp-test-or 'a 'b) 'a)) (should (eq (comp-test-or 0 23) 0)) (should (eq (comp-test-or nil 'b) 'b))) -(ert-deftest comp-save-excursion () +(comp-deftest save-excursion () (with-temp-buffer (comp-test-save-excursion) (should (eq (point) (point-min))) (should (eq (comp-test-current-buffer) (current-buffer))))) -(ert-deftest comp-> () +(comp-deftest > () (should (eq (comp-test-> 0 23) nil)) (should (eq (comp-test-> 23 0) t))) -(ert-deftest comp-catch () +(comp-deftest catch () (should (eq (comp-test-catch 0 1 2 3 4) nil)) (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) -(ert-deftest comp-memq () +(comp-deftest memq () (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) -(ert-deftest comp-listN () +(comp-deftest listN () (should (equal (comp-test-listN 57) '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) -(ert-deftest comp-concatN () +(comp-deftest concatN () (should (equal (comp-test-concatN "x") "xxxxxx"))) -(ert-deftest comp-opt-rest () +(comp-deftest opt-rest () (should (equal (comp-test-opt-rest 1) '(1 nil nil))) (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) (should (equal (comp-test-opt-rest 1 2 56 57 58) '(1 2 (56 57 58))))) -(ert-deftest comp-opt () +(comp-deftest opt () (should (equal (comp-test-opt 23) '(23))) (should (equal (comp-test-opt 23 24) '(23 . 24))) (should-error (comp-test-opt) @@ -548,7 +557,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should-error (comp-test-opt nil 24 97) :type 'wrong-number-of-arguments)) -(ert-deftest comp-unwind-protect () +(comp-deftest unwind-protect () (comp-test-unwind-protect 'ignore) (should (eq comp-test-up-val 999)) (condition-case nil @@ -562,7 +571,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ;; Tests for dynamic scope. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(ert-deftest comp-tests-dynamic-ffuncall () +(comp-deftest dynamic-ffuncall () "Test calling convention for dynamic binding." (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2) @@ -589,7 +598,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) '(1 2 3 (4))))) -(ert-deftest comp-tests-dynamic-arity () +(comp-deftest dynamic-arity () "Test func-arity on dynamic scope functions." (should (equal '(2 . 2) (func-arity #'comp-tests-ffuncall-callee-dyn-f))) @@ -600,18 +609,18 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) -(ert-deftest comp-tests-dynamic-help-arglist () +(comp-deftest dynamic-help-arglist () "Test `help-function-arglist' works on lisp/d (bug#42572)." (should (equal (help-function-arglist (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) t) '(a b &optional c &rest d)))) -(ert-deftest comp-tests-cl-macro-exp () +(comp-deftest cl-macro-exp () "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) -(ert-deftest comp-tests-cl-uninterned-arg-parse-f () +(comp-deftest cl-uninterned-arg-parse-f () "Verify the parsing of a lambda list with uninterned symbols (bug#42120)." (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) '(1 2)))) @@ -659,7 +668,7 @@ CHECKER should always return nil to have a pass." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) insn))))) -(ert-deftest comp-tests-tco () +(comp-deftest tco () "Check for tail recursion elimination." (let ((comp-speed 3) ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets @@ -684,7 +693,7 @@ CHECKER should always return nil to have a pass." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))) -(ert-deftest comp-tests-fw-prop () +(comp-deftest fw-prop () "Some tests for forward propagation." (let ((comp-speed 2) (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) @@ -717,7 +726,7 @@ CHECKER should always return nil to have a pass." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) insn))))) -(ert-deftest comp-tests-pure () +(comp-deftest pure () "Some tests for pure functions optimization." (let ((comp-speed 3) (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 From 6a0994bc976534e56aa4990584f363536bc35271 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 13:47:29 +0200 Subject: [PATCH 1078/1452] * src/pdumper.c (dump_do_dump_relocation): Better error for incoherent eln. --- src/pdumper.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/pdumper.c b/src/pdumper.c index 03391c49505..0528219139c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5250,7 +5250,8 @@ dump_do_dump_relocation (const uintptr_t dump_base, dump_ptr (dump_base, reloc_offset); comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); if (!CONSP (comp_u->file)) - error ("Trying to load incoherent dumped .eln"); + error ("Trying to load incoherent dumped eln file %s", + SSDATA (comp_u->file)); /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) From 8dacc9e8c52ce873f2b0a54e7ca67cffd2c7f4f7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 13:49:20 +0200 Subject: [PATCH 1079/1452] * Fix 'incoherent dumped eln file' error when DUMP-METHOD=pbootstrap * src/Makefile.in ($(bootstrap_pdmp)): Add missing --bin-dest --eln-dest flags. --- src/Makefile.in | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Makefile.in b/src/Makefile.in index 31a5a7e7709..001f0c40722 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -820,7 +820,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 From 36e0c3fb07db9805e97fbd2650aa28ac2c169dba Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 14:42:43 +0200 Subject: [PATCH 1080/1452] * When advising search in `comp-eln-load-path' the first writable dir * lisp/emacs-lisp/comp.el (comp-tampoline-compile): Do not crash if we can't write in the first entry in `comp-eln-load-path' but search for another one. --- lisp/emacs-lisp/comp.el | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 02b08119f9c..ef13c0ce63e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2593,17 +2593,25 @@ Return the its filename if found or nil otherwise." ;; the primitive we are replacing in the function reloc table. (defalias trampoline-sym `(closure nil ,lambda-list - (let ((f #',subr-name)) - (,(if (memq '&rest lambda-list) 'apply 'funcall) - f - ,@(cl-loop - for arg in lambda-list - unless (memq arg '(&optional &rest)) - collect arg))))) - (native-compile trampoline-sym nil - (expand-file-name (comp-trampoline-filename subr-name) - (concat (car comp-eln-load-path) - comp-native-version-dir))))) + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) 'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + (native-compile + trampoline-sym nil + (cl-loop + for dir in comp-eln-load-path + for f = (expand-file-name + (comp-trampoline-filename subr-name) + (concat dir + comp-native-version-dir)) + when (file-writable-p f) + do (cl-return f) + finally (error "Can't find a writable directory in \ +`comp-eln-load-path'"))))) ;;;###autoload (defun comp-subr-safe-advice (subr-name) From d07d7ab1a0e321ced62ebe5dd9db27eb7e93430e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 18:13:28 +0200 Subject: [PATCH 1081/1452] Add `advice-flet' macro The testsuite does large use of primitive redefinition, to avoid that we define `advice-flet' to use instead as an easy `cl-letf' replacement. * lisp/emacs-lisp/nadvice.el (advice-flet): New macro. --- lisp/emacs-lisp/nadvice.el | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5b3aa708508..21da038dc1c 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -356,6 +356,32 @@ of the piece of advice." (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) +;;;###autoload +(defmacro advice-flet (bindings &rest body) + ;; FIXME add doc. + (declare (indent 1)) + (let ((let-binds ()) + (ad-add ()) + (ad-del ())) + (dolist (bind bindings) + (let* ((fun-name (car bind)) + (fun (cadr bind)) + (tmp-sym (gensym (symbol-name fun-name)))) + (push `(,tmp-sym ,fun) let-binds) + (push `(advice-add #',fun-name + ,(if (= (length bind) 3) + (nth 2 bind) + :override) + ,tmp-sym) + ad-add) + (push `(advice-remove #',fun-name ,tmp-sym) ad-del))) + `(let ,(reverse let-binds) + (unwind-protect + (progn + ,@(reverse ad-add) + ,@body) + ,@(reverse ad-del))))) + (defun advice-function-mapc (f function-def) "Apply F to every advice function in FUNCTION-DEF. F is called with two arguments: the function that was added, and the From 825e85b393a3d78ba43176ecc5bc1a9595d0fbea Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 18:38:02 +0200 Subject: [PATCH 1082/1452] Use `advice-flet' in place of `cl-letf' to avoid primitive redefinition * test/lisp/time-stamp-tests.el (with-time-stamp-system-name): Use `advice-flet' to advice primitive avoiding redefinition. * test/lisp/tempo-tests.el (tempo-p-element-test) (tempo-P-element-test, tempo-r-element-test) (tempo-s-element-test, tempo-r>-element-test): Likewise. * test/lisp/subr-tests.el (subr-tests-bug22027): Likewise. * test/lisp/shadowfile-tests.el (shadow-test00-clusters) (shadow-test01-sites, shadow-test06-literal-groups) (shadow-test07-regexp-groups): Likewise. * test/lisp/replace-tests.el (replace-tests-with-undo): Likewise. * test/lisp/play/dissociate-tests.el (dissociate-tests-dissociated-press): Likewise. * test/lisp/net/tramp-tests.el (tramp-test10-write-region) (tramp-test21-file-links): Likewise. * test/lisp/kmacro-tests.el (kmacro-tests-call-macro-hint-and-repeat) (kmacro-tests-repeat-on-last-key) (kmacro-tests-repeat-view-and-run) (kmacro-tests-bind-to-key-with-key-sequence-in-use): Likewise. * test/lisp/files-tests.el (files-tests-read-file-in-~): Likewise. * test/lisp/emacs-lisp/rmc-tests.el (test-read-multiple-choice): Likewise. * test/lisp/bookmark-tests.el (bookmark-test-bmenu-locate): Likewise. * test/lisp/abbrev-tests.el (inverse-add-abbrev-skips-trailing-nonword) (inverse-add-abbrev-skips-trailing-nonword/positive-arg) (inverse-add-abbrev-skips-trailing-nonword/negative-arg): Likewise. --- test/lisp/abbrev-tests.el | 6 ++-- test/lisp/bookmark-tests.el | 6 ++-- test/lisp/emacs-lisp/rmc-tests.el | 10 +++--- test/lisp/files-tests.el | 37 ++++++++++---------- test/lisp/kmacro-tests.el | 56 ++++++++++++++++-------------- test/lisp/net/tramp-tests.el | 20 +++++------ test/lisp/play/dissociate-tests.el | 4 +-- test/lisp/replace-tests.el | 45 ++++++++++++------------ test/lisp/shadowfile-tests.el | 32 ++++++++--------- test/lisp/subr-tests.el | 4 +-- test/lisp/tempo-tests.el | 10 +++--- test/lisp/time-stamp-tests.el | 4 +-- 12 files changed, 119 insertions(+), 115 deletions(-) diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index aaf1d4a5b5c..9b998add23f 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -279,7 +279,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) + (advice-flet ((read-string (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 1))) (should (string= (abbrev-expansion "foo" table) "bar")))) @@ -288,7 +288,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) + (advice-flet ((read-string (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 2))) (should (string= (abbrev-expansion "text" table) "bar")))) @@ -298,7 +298,7 @@ (with-temp-buffer (insert "some text foo") (goto-char (point-min)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) + (advice-flet ((read-string (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" -1))) (should (string= (abbrev-expansion "text" table) "bar")))) diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index c5959e46d80..26d75ce0c4e 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -633,9 +633,9 @@ testing `bookmark-bmenu-list'." (ert-deftest bookmark-test-bmenu-locate () (let (msg) - (cl-letf (((symbol-function 'message) - (lambda (&rest args) - (setq msg (apply #'format args))))) + (advice-flet ((message + (lambda (&rest args) + (setq msg (apply #'format args))))) (with-bookmark-bmenu-test (bookmark-bmenu-locate) (should (equal msg "/some/file")))))) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 5add24c479a..de6db13347b 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -33,10 +33,12 @@ (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) - (cl-letf* (((symbol-function #'read-event) (lambda () char)) - (str (if (eq char ?y) "yes" "no"))) - (should (equal (list char str) - (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) + (let ((str (if (eq char ?y) "yes" "no"))) + (advice-flet ((read-event + (lambda () char))) + (should (equal (list char str) + (read-multiple-choice "Do it? " + '((?y "yes") (?n "no"))))))))) (provide 'rmc-tests) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 54801adda63..2e9c6adc947 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -242,24 +242,25 @@ form.") "Test file prompting in directory named `~'. If we are in a directory named `~', the default value should not be $HOME." - (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init))) - (dir (make-temp-file "read-file-name-test" t))) - (unwind-protect - (let ((subdir (expand-file-name "./~/" dir))) - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive)))) + (let* ((dir (make-temp-file "read-file-name-test" t)) + (subdir (expand-file-name "./~/" dir))) + (advice-flet ((completing-read + (lambda (_prompt _coll &optional _pred _req init _hist def _) + (or def init)))) + (unwind-protect + (progn + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir))))) + (delete-directory dir 'recursive))))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index bb18c828140..cc0f48eee8f 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -341,8 +341,8 @@ This is a regression test for: Bug#3412, Bug#11817." (message "") ; Clear the echo area. (Bug#3412) (kmacro-tests-should-match-message "Type e to repeat macro" (kmacro-tests-should-insert "mmmmmm" - (cl-letf (((symbol-function #'this-single-command-keys) (lambda () - [?\C-x ?e]))) + (advice-flet ((this-single-command-keys (lambda () + [?\C-x ?e]))) (kmacro-call-macro 3)) ;; Check that it set up for repeat, and run the repeat. (funcall (lookup-key overriding-terminal-local-map "e")))))) @@ -455,8 +455,8 @@ This is a regression test for: Bug#3412, Bug#11817." ;; commands so it should end the sequence. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-set-counter)) (kmacro-tests-events (append events (list end-key)))) - (cl-letf (((symbol-function #'this-single-command-keys) - (lambda () first-event))) + (advice-flet ((this-single-command-keys + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "ccbacb" ;; End #3 and launch loop to read events. @@ -466,9 +466,9 @@ This is a regression test for: Bug#3412, Bug#11817." ;; so run it again with that at the end. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-edit-macro-repeat)) (kmacro-tests-events (append events (list end-key)))) - (cl-letf (((symbol-function #'edit-kbd-macro) #'ignore) - ((symbol-function #'this-single-command-keys) - (lambda () first-event))) + (advice-flet ((edit-kbd-macro #'ignore) + (this-single-command-keys + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "bbbbbaaba" (kmacro-end-or-call-macro-repeat 3))))))) @@ -494,20 +494,22 @@ This is a regression test for: Bug#3412, Bug#11817." '("d" "c" "b" "a" "d" "c"))))) (cl-letf ((kmacro-repeat-no-prefix t) (kmacro-call-repeat-key t) - (kmacro-call-repeat-with-arg nil) - ((symbol-function #'this-single-command-keys) (lambda () - first-event))) - ;; "Record" some macros. - (dotimes (n 4) - (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) + (kmacro-call-repeat-with-arg nil)) + (advice-flet ((this-single-command-keys (lambda () + first-event))) + ;; "Record" some macros. + (dotimes (n 4) + (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) - (use-local-map kmacro-tests-keymap) - ;; 6 views (the direct call plus the 5 in events) should - ;; cycle through the ring and get to the second-to-last - ;; macro defined. - (kmacro-tests-should-insert "c" - (kmacro-tests-should-match-message macros-regexp - (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil))))))) + (use-local-map kmacro-tests-keymap) + ;; 6 views (the direct call plus the 5 in events) should + ;; cycle through the ring and get to the second-to-last + ;; macro defined. + (kmacro-tests-should-insert + "c" + (kmacro-tests-should-match-message + macros-regexp + (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil)))))))) (kmacro-tests-deftest kmacro-tests-bind-to-key-when-recording () "Bind to key doesn't bind a key during macro recording." @@ -542,18 +544,18 @@ This is a regression test for: Bug#3412, Bug#11817." (define-key map "\C-hi" 'info) (use-local-map map) ;; Try the command with yes-or-no-p set up to say no. - (cl-letf (((symbol-function #'yes-or-no-p) - (lambda (prompt) - (should (string-match-p "info" prompt)) - (should (string-match-p "C-h i" prompt)) - nil))) + (advice-flet ((yes-or-no-p + (lambda (prompt) + (should (string-match-p "info" prompt)) + (should (string-match-p "C-h i" prompt)) + nil))) (kmacro-bind-to-key nil)) (should (equal (where-is-internal 'info nil t) (vconcat "\C-hi"))) ;; Try it again with yes. - (cl-letf (((symbol-function #' yes-or-no-p) - (lambda (_prompt) t))) + (advice-flet ((yes-or-no-p + (lambda (_prompt) t))) (kmacro-bind-to-key nil)) (should-not (equal (where-is-internal 'info global-map t) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3914f9ae44e..0e4fcb5951f 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2420,16 +2420,16 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) - ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (advice-flet ((y-or-n-p (lambda (_prompt) t)) + ;; Ange-FTP. + (yes-or-no-p (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (cl-letf (((symbol-function #'y-or-n-p) #'ignore) - ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) 'ignore)) + (advice-flet ((y-or-n-p #'ignore) + ;; Ange-FTP. + (yes-or-no-p 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) :type 'file-already-exists) (should-error @@ -3522,11 +3522,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (advice-flet ((yes-or-no-p #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (advice-flet ((yes-or-no-p (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3598,11 +3598,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (advice-flet ((yes-or-no-p #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (advice-flet ((yes-or-no-p (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) diff --git a/test/lisp/play/dissociate-tests.el b/test/lisp/play/dissociate-tests.el index e8d903109fc..1583a51acd5 100644 --- a/test/lisp/play/dissociate-tests.el +++ b/test/lisp/play/dissociate-tests.el @@ -25,8 +25,8 @@ (require 'dissociate) (ert-deftest dissociate-tests-dissociated-press () - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) nil)) - ((symbol-function 'random) (lambda (_) 10))) + (advice-flet ((y-or-n-p (lambda (_) nil)) + (random (lambda (_) 10))) (save-window-excursion (with-temp-buffer (insert "Lorem ipsum dolor sit amet") diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index aed14c33572..0f8084704d9 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -443,29 +443,28 @@ Return the last evalled form in BODY." ;; Bind `read-event' to simulate user input. ;; If `replace-tests-bind-read-string' is non-nil, then ;; bind `read-string' as well. - (cl-letf (((symbol-function 'read-event) - (lambda (&rest _args) - (cl-incf ,count) - (pcase ,count ; Build the clauses from CHAR-NUMS - ,@(append - (delq nil - (mapcar - (lambda (chr) - (when-let (it (alist-get chr char-nums)) - (if (cdr it) - `(,(cons 'or it) ,chr) - `(,(car it) ,chr)))) - '(?, ?\s ?u ?U ?E ?q))) - `((_ ,def-chr)))))) - ((symbol-function 'read-string) - (if replace-tests-bind-read-string - (lambda (&rest _args) replace-tests-bind-read-string) - (symbol-function 'read-string))) - ;; Emulate replace-highlight clobbering match-data via - ;; isearch-lazy-highlight-new-loop and sit-for (bug#36328) - ((symbol-function 'replace-highlight) - (lambda (&rest _args) - (string-match "[A-Z ]" "ForestGreen")))) + (advice-flet ((read-event + (lambda (&rest _args) + (cl-incf ,count) + (pcase ,count ; Build the clauses from CHAR-NUMS + ,@(append + (delq nil + (mapcar + (lambda (chr) + (when-let (it (alist-get chr char-nums)) + (if (cdr it) + `(,(cons 'or it) ,chr) + `(,(car it) ,chr)))) + '(?, ?\s ?u ?U ?E ?q))) + `((_ ,def-chr)))))) + (read-string + (if replace-tests-bind-read-string + (lambda (&rest _args) replace-tests-bind-read-string) + (lambda (&rest args) + (apply #'read-string args)))) + (replace-highlight + (lambda (&rest _args) + (string-match "[A-Z ]" "ForestGreen")))) (perform-replace ,from ,to t replace-tests-perform-replace-regexp-flag nil)) ,@body)))) diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index f40f6a1cdb0..6a9664638fa 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -138,10 +138,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -255,10 +255,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -608,10 +608,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -669,10 +669,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 035c064d75c..b131b509355 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -337,8 +337,8 @@ cf. Bug#25477." (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." (let ((default "foo") res) - (cl-letf (((symbol-function 'read-string) - (lambda (_prompt _init _hist def) def))) + (advice-flet ((read-string + (lambda (_prompt _init _hist def) def))) (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) (should (string= default res))))) diff --git a/test/lisp/tempo-tests.el b/test/lisp/tempo-tests.el index bfe475910da..333abffc84f 100644 --- a/test/lisp/tempo-tests.el +++ b/test/lisp/tempo-tests.el @@ -55,7 +55,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">"))) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) + (advice-flet ((read-string (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world"))))) @@ -64,7 +64,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (P ">"))) ;; By default, `tempo-interactive' is nil, `P' should ignore this. - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) + (advice-flet ((read-string (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world")))) @@ -73,7 +73,7 @@ (with-temp-buffer (tempo-define-template "test" '("abcde" (r ">") "ghijk")) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "F"))) + (advice-flet ((read-string (lambda (&rest _) "F"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "abcdeFghijk"))))) @@ -82,7 +82,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">" P1) " " (s P1))) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world!"))) + (advice-flet ((read-string (lambda (&rest _) "world!"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world! world!"))))) @@ -164,7 +164,7 @@ ;; Test interactive use (emacs-lisp-mode) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " (list 1 2 3)"))) + (advice-flet ((read-string (lambda (&rest _) " (list 1 2 3)"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "(progn\n (list 1 2 3))"))))) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index e75e84b0221..ab662ffd959 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -57,8 +57,8 @@ (defmacro with-time-stamp-system-name (name &rest body) "Force (system-name) to return NAME while evaluating BODY." (declare (indent defun)) - `(cl-letf (((symbol-function 'system-name) - (lambda () ,name))) + `(advice-flet ((system-name + (lambda () ,name))) ,@body)) (defmacro time-stamp-should-warn (form) From 0373bb838a032f97ae9317546e3b0117b97055a8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Oct 2020 20:57:57 +0200 Subject: [PATCH 1083/1452] * Fix two tests in help-fns-tests.el for native code * test/lisp/help-fns-tests.el (help-fns-test-lisp-defun) (help-fns-test-lisp-defsubst): Fix description string for native compiled functions. --- test/lisp/help-fns-tests.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 811b3677910..2f6abfb56dd 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -61,12 +61,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)))) From 72682958683174b5133b09fd9ac256727e4d88a7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Oct 2020 21:54:27 +0200 Subject: [PATCH 1084/1452] * Fix function description message for native compiled lisp functions * lisp/help-fns.el (help-fns-function-description-header): Fix message. --- lisp/help-fns.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 9fee156f18f..8287fab3152 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -737,7 +737,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (aliased (format-message "an alias for `%s'" real-def)) ((subr-native-elisp-p def) - "native compiled Lisp function") + (concat beg "native compiled Lisp function")) ((subrp def) (concat beg (if (eq 'unevalled (cdr (subr-arity def))) "special form" From 187a0333bf0d1c5dd08ec76c9265e5a6077f8e74 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Oct 2020 09:12:49 +0200 Subject: [PATCH 1085/1452] * configure.ac: Better HAVE_NATIVE_COMP description --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 990933afc93..3d24751c934 100644 --- a/configure.ac +++ b/configure.ac @@ -3809,7 +3809,7 @@ if test "${with_nativecomp}" != "no"; then LIBGCCJIT_LIB="-lgccjit -ldl" fi NEED_DYNLIB=yes - AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + 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]) From afb765ab3cab7b6582d0def543b23603cd076445 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Oct 2020 09:16:24 +0200 Subject: [PATCH 1086/1452] Make filename hashing compatible with self contained builds (bug#43532) * Makefile.in (lispdirrel): Add replace template. (epaths-force): Form correctly 'PATH_REL_LOADSEARCH' into epath.h * configure.ac (lispdirrel): Define variable (relative path of the lisp files from the installation directory). * src/comp.c (Fcomp_el_to_eln_filename): Update algorithm not to rely on 'PATH_DUMPLOADSEARCH' but on 'PATH_REL_LOADSEARCH'. * src/epaths.in (PATH_REL_LOADSEARCH): Add macro template. --- Makefile.in | 5 +++++ configure.ac | 7 +++++-- src/comp.c | 22 +++++----------------- src/epaths.in | 4 ++++ 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/Makefile.in b/Makefile.in index 2b47762b7bc..027dca0bd70 100644 --- a/Makefile.in +++ b/Makefile.in @@ -223,6 +223,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. @@ -368,6 +372,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' \ diff --git a/configure.ac b/configure.ac index 3d24751c934..ead27d3dea9 100644 --- a/configure.ac +++ b/configure.ac @@ -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' @@ -1908,7 +1909,8 @@ if test "${with_ns}" != no; then NS_IMPL_COCOA=yes ns_appdir=`pwd`/nextstep/Emacs.app ns_appbindir=${ns_appdir}/Contents/MacOS - ns_appresdir=${ns_appdir}/Contents/Resources + lispdirrel=Contents/Resources + ns_appresdir=${ns_appdir}/{lispdirrel} ns_appsrc=Cocoa/Emacs.base ns_fontfile=macfont.o elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then @@ -5325,6 +5327,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) diff --git a/src/comp.c b/src/comp.c index 058ce7e96ac..5663c9e5624 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4050,27 +4050,15 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive to that. For this we replace if match PATH_DUMPLOADSEARCH or - PATH_LOADSEARCH with '//' before generating the hash. */ + *PATH_REL_LOADSEARCH with '//' before computing the hash. */ if (NILP (loadsearch_re_list)) { - Lisp_Object sys_re; -#ifdef __APPLE__ - /* On MacOS we relax the match on PATH_LOADSEARCH making - everything before ".app/" a wildcard. This to obtain a - self-contained Emacs.app (bug#43532). */ - char *c; - if ((c = strstr (PATH_LOADSEARCH, ".app/"))) - sys_re = - concat2 (build_string ("\\`[[:ascii:]]+"), - Fregexp_quote (build_string (c))); - else - sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); -#else - sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); -#endif + Lisp_Object sys_re = + concat2 (build_string ("\\`[[:ascii:]]+"), + Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/"))); loadsearch_re_list = - list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH))); + list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH "/"))); } Lisp_Object lds_re_tail = loadsearch_re_list; diff --git a/src/epaths.in b/src/epaths.in index 3cadd160ecf..5b6c650b0da 100644 --- a/src/epaths.in +++ b/src/epaths.in @@ -27,6 +27,10 @@ along with GNU Emacs. If not, see . */ */ #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 From 915214ac9a97025c01ec0bf1375d3630b3f6adf0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Oct 2020 22:48:37 +0200 Subject: [PATCH 1087/1452] * configure.ac : Fix typo for MacOS nativecomp introduced by afb765ab3c --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 5aceac6d951..be53578239b 100644 --- a/configure.ac +++ b/configure.ac @@ -1910,7 +1910,7 @@ if test "${with_ns}" != no; then ns_appdir=`pwd`/nextstep/Emacs.app ns_appbindir=${ns_appdir}/Contents/MacOS lispdirrel=Contents/Resources - ns_appresdir=${ns_appdir}/{lispdirrel} + ns_appresdir=${ns_appdir}/${lispdirrel} ns_appsrc=Cocoa/Emacs.base ns_fontfile=macfont.o elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then From 323200044f0c3f716f8f78a6f5e39349fe039117 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 5 Oct 2020 08:42:12 +0200 Subject: [PATCH 1088/1452] * configure.ac (lispdirrel): Fix value for MacOS build. --- configure.ac | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index be53578239b..b7b0c268c84 100644 --- a/configure.ac +++ b/configure.ac @@ -1906,11 +1906,11 @@ 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 - lispdirrel=Contents/Resources - ns_appresdir=${ns_appdir}/${lispdirrel} + ns_appresdir=${ns_appdir}/Contents/Resources ns_appsrc=Cocoa/Emacs.base ns_fontfile=macfont.o elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then From ad5a2bbde071138cacadd19b95f2638741fd5d8d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 22:17:09 +0200 Subject: [PATCH 1089/1452] Revert "Add `advice-flet' macro" This reverts commit d07d7ab1a0e321ced62ebe5dd9db27eb7e93430e. --- lisp/emacs-lisp/nadvice.el | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 21da038dc1c..5b3aa708508 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -356,32 +356,6 @@ of the piece of advice." (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) -;;;###autoload -(defmacro advice-flet (bindings &rest body) - ;; FIXME add doc. - (declare (indent 1)) - (let ((let-binds ()) - (ad-add ()) - (ad-del ())) - (dolist (bind bindings) - (let* ((fun-name (car bind)) - (fun (cadr bind)) - (tmp-sym (gensym (symbol-name fun-name)))) - (push `(,tmp-sym ,fun) let-binds) - (push `(advice-add #',fun-name - ,(if (= (length bind) 3) - (nth 2 bind) - :override) - ,tmp-sym) - ad-add) - (push `(advice-remove #',fun-name ,tmp-sym) ad-del))) - `(let ,(reverse let-binds) - (unwind-protect - (progn - ,@(reverse ad-add) - ,@body) - ,@(reverse ad-del))))) - (defun advice-function-mapc (f function-def) "Apply F to every advice function in FUNCTION-DEF. F is called with two arguments: the function that was added, and the From b3ade4de179d4c13cd09e2b8066e09c66355d322 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Oct 2020 20:09:04 +0200 Subject: [PATCH 1090/1452] Revert "Use `advice-flet' in place of `cl-letf' to avoid primitive... This reverts commit 825e85b393a3d78ba43176ecc5bc1a9595d0fbea. --- test/lisp/abbrev-tests.el | 6 ++-- test/lisp/bookmark-tests.el | 6 ++-- test/lisp/emacs-lisp/rmc-tests.el | 10 +++--- test/lisp/files-tests.el | 37 ++++++++++---------- test/lisp/kmacro-tests.el | 56 ++++++++++++++---------------- test/lisp/net/tramp-tests.el | 20 +++++------ test/lisp/play/dissociate-tests.el | 4 +-- test/lisp/replace-tests.el | 45 ++++++++++++------------ test/lisp/shadowfile-tests.el | 32 ++++++++--------- test/lisp/subr-tests.el | 4 +-- test/lisp/tempo-tests.el | 10 +++--- test/lisp/time-stamp-tests.el | 4 +-- 12 files changed, 115 insertions(+), 119 deletions(-) diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 9b998add23f..aaf1d4a5b5c 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -279,7 +279,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (advice-flet ((read-string (lambda (&rest _) "bar"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 1))) (should (string= (abbrev-expansion "foo" table) "bar")))) @@ -288,7 +288,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (advice-flet ((read-string (lambda (&rest _) "bar"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 2))) (should (string= (abbrev-expansion "text" table) "bar")))) @@ -298,7 +298,7 @@ (with-temp-buffer (insert "some text foo") (goto-char (point-min)) - (advice-flet ((read-string (lambda (&rest _) "bar"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" -1))) (should (string= (abbrev-expansion "text" table) "bar")))) diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 26d75ce0c4e..c5959e46d80 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -633,9 +633,9 @@ testing `bookmark-bmenu-list'." (ert-deftest bookmark-test-bmenu-locate () (let (msg) - (advice-flet ((message - (lambda (&rest args) - (setq msg (apply #'format args))))) + (cl-letf (((symbol-function 'message) + (lambda (&rest args) + (setq msg (apply #'format args))))) (with-bookmark-bmenu-test (bookmark-bmenu-locate) (should (equal msg "/some/file")))))) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index de6db13347b..5add24c479a 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -33,12 +33,10 @@ (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) - (let ((str (if (eq char ?y) "yes" "no"))) - (advice-flet ((read-event - (lambda () char))) - (should (equal (list char str) - (read-multiple-choice "Do it? " - '((?y "yes") (?n "no"))))))))) + (cl-letf* (((symbol-function #'read-event) (lambda () char)) + (str (if (eq char ?y) "yes" "no"))) + (should (equal (list char str) + (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) (provide 'rmc-tests) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 3829f505010..1b964af6887 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -242,25 +242,24 @@ form.") "Test file prompting in directory named `~'. If we are in a directory named `~', the default value should not be $HOME." - (let* ((dir (make-temp-file "read-file-name-test" t)) - (subdir (expand-file-name "./~/" dir))) - (advice-flet ((completing-read - (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init)))) - (unwind-protect - (progn - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive))))) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll &optional _pred _req init _hist def _) + (or def init))) + (dir (make-temp-file "read-file-name-test" t))) + (unwind-protect + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir))))) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index cc0f48eee8f..bb18c828140 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -341,8 +341,8 @@ This is a regression test for: Bug#3412, Bug#11817." (message "") ; Clear the echo area. (Bug#3412) (kmacro-tests-should-match-message "Type e to repeat macro" (kmacro-tests-should-insert "mmmmmm" - (advice-flet ((this-single-command-keys (lambda () - [?\C-x ?e]))) + (cl-letf (((symbol-function #'this-single-command-keys) (lambda () + [?\C-x ?e]))) (kmacro-call-macro 3)) ;; Check that it set up for repeat, and run the repeat. (funcall (lookup-key overriding-terminal-local-map "e")))))) @@ -455,8 +455,8 @@ This is a regression test for: Bug#3412, Bug#11817." ;; commands so it should end the sequence. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-set-counter)) (kmacro-tests-events (append events (list end-key)))) - (advice-flet ((this-single-command-keys - (lambda () first-event))) + (cl-letf (((symbol-function #'this-single-command-keys) + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "ccbacb" ;; End #3 and launch loop to read events. @@ -466,9 +466,9 @@ This is a regression test for: Bug#3412, Bug#11817." ;; so run it again with that at the end. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-edit-macro-repeat)) (kmacro-tests-events (append events (list end-key)))) - (advice-flet ((edit-kbd-macro #'ignore) - (this-single-command-keys - (lambda () first-event))) + (cl-letf (((symbol-function #'edit-kbd-macro) #'ignore) + ((symbol-function #'this-single-command-keys) + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "bbbbbaaba" (kmacro-end-or-call-macro-repeat 3))))))) @@ -494,22 +494,20 @@ This is a regression test for: Bug#3412, Bug#11817." '("d" "c" "b" "a" "d" "c"))))) (cl-letf ((kmacro-repeat-no-prefix t) (kmacro-call-repeat-key t) - (kmacro-call-repeat-with-arg nil)) - (advice-flet ((this-single-command-keys (lambda () - first-event))) - ;; "Record" some macros. - (dotimes (n 4) - (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) + (kmacro-call-repeat-with-arg nil) + ((symbol-function #'this-single-command-keys) (lambda () + first-event))) + ;; "Record" some macros. + (dotimes (n 4) + (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) - (use-local-map kmacro-tests-keymap) - ;; 6 views (the direct call plus the 5 in events) should - ;; cycle through the ring and get to the second-to-last - ;; macro defined. - (kmacro-tests-should-insert - "c" - (kmacro-tests-should-match-message - macros-regexp - (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil)))))))) + (use-local-map kmacro-tests-keymap) + ;; 6 views (the direct call plus the 5 in events) should + ;; cycle through the ring and get to the second-to-last + ;; macro defined. + (kmacro-tests-should-insert "c" + (kmacro-tests-should-match-message macros-regexp + (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil))))))) (kmacro-tests-deftest kmacro-tests-bind-to-key-when-recording () "Bind to key doesn't bind a key during macro recording." @@ -544,18 +542,18 @@ This is a regression test for: Bug#3412, Bug#11817." (define-key map "\C-hi" 'info) (use-local-map map) ;; Try the command with yes-or-no-p set up to say no. - (advice-flet ((yes-or-no-p - (lambda (prompt) - (should (string-match-p "info" prompt)) - (should (string-match-p "C-h i" prompt)) - nil))) + (cl-letf (((symbol-function #'yes-or-no-p) + (lambda (prompt) + (should (string-match-p "info" prompt)) + (should (string-match-p "C-h i" prompt)) + nil))) (kmacro-bind-to-key nil)) (should (equal (where-is-internal 'info nil t) (vconcat "\C-hi"))) ;; Try it again with yes. - (advice-flet ((yes-or-no-p - (lambda (_prompt) t))) + (cl-letf (((symbol-function #' yes-or-no-p) + (lambda (_prompt) t))) (kmacro-bind-to-key nil)) (should-not (equal (where-is-internal 'info global-map t) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 0e4fcb5951f..3914f9ae44e 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2420,16 +2420,16 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (advice-flet ((y-or-n-p (lambda (_prompt) t)) - ;; Ange-FTP. - (yes-or-no-p (lambda (_prompt) t))) + (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) + ;; Ange-FTP. + ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (advice-flet ((y-or-n-p #'ignore) - ;; Ange-FTP. - (yes-or-no-p 'ignore)) + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) + ;; Ange-FTP. + ((symbol-function 'yes-or-no-p) 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) :type 'file-already-exists) (should-error @@ -3522,11 +3522,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (advice-flet ((yes-or-no-p #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (advice-flet ((yes-or-no-p (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3598,11 +3598,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (advice-flet ((yes-or-no-p #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (advice-flet ((yes-or-no-p (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) diff --git a/test/lisp/play/dissociate-tests.el b/test/lisp/play/dissociate-tests.el index 1583a51acd5..e8d903109fc 100644 --- a/test/lisp/play/dissociate-tests.el +++ b/test/lisp/play/dissociate-tests.el @@ -25,8 +25,8 @@ (require 'dissociate) (ert-deftest dissociate-tests-dissociated-press () - (advice-flet ((y-or-n-p (lambda (_) nil)) - (random (lambda (_) 10))) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) nil)) + ((symbol-function 'random) (lambda (_) 10))) (save-window-excursion (with-temp-buffer (insert "Lorem ipsum dolor sit amet") diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 0f8084704d9..aed14c33572 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -443,28 +443,29 @@ Return the last evalled form in BODY." ;; Bind `read-event' to simulate user input. ;; If `replace-tests-bind-read-string' is non-nil, then ;; bind `read-string' as well. - (advice-flet ((read-event - (lambda (&rest _args) - (cl-incf ,count) - (pcase ,count ; Build the clauses from CHAR-NUMS - ,@(append - (delq nil - (mapcar - (lambda (chr) - (when-let (it (alist-get chr char-nums)) - (if (cdr it) - `(,(cons 'or it) ,chr) - `(,(car it) ,chr)))) - '(?, ?\s ?u ?U ?E ?q))) - `((_ ,def-chr)))))) - (read-string - (if replace-tests-bind-read-string - (lambda (&rest _args) replace-tests-bind-read-string) - (lambda (&rest args) - (apply #'read-string args)))) - (replace-highlight - (lambda (&rest _args) - (string-match "[A-Z ]" "ForestGreen")))) + (cl-letf (((symbol-function 'read-event) + (lambda (&rest _args) + (cl-incf ,count) + (pcase ,count ; Build the clauses from CHAR-NUMS + ,@(append + (delq nil + (mapcar + (lambda (chr) + (when-let (it (alist-get chr char-nums)) + (if (cdr it) + `(,(cons 'or it) ,chr) + `(,(car it) ,chr)))) + '(?, ?\s ?u ?U ?E ?q))) + `((_ ,def-chr)))))) + ((symbol-function 'read-string) + (if replace-tests-bind-read-string + (lambda (&rest _args) replace-tests-bind-read-string) + (symbol-function 'read-string))) + ;; Emulate replace-highlight clobbering match-data via + ;; isearch-lazy-highlight-new-loop and sit-for (bug#36328) + ((symbol-function 'replace-highlight) + (lambda (&rest _args) + (string-match "[A-Z ]" "ForestGreen")))) (perform-replace ,from ,to t replace-tests-perform-replace-regexp-flag nil)) ,@body)))) diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 6a9664638fa..f40f6a1cdb0 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -138,10 +138,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -255,10 +255,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -608,10 +608,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -669,10 +669,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index b131b509355..035c064d75c 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -337,8 +337,8 @@ cf. Bug#25477." (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." (let ((default "foo") res) - (advice-flet ((read-string - (lambda (_prompt _init _hist def) def))) + (cl-letf (((symbol-function 'read-string) + (lambda (_prompt _init _hist def) def))) (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) (should (string= default res))))) diff --git a/test/lisp/tempo-tests.el b/test/lisp/tempo-tests.el index 333abffc84f..bfe475910da 100644 --- a/test/lisp/tempo-tests.el +++ b/test/lisp/tempo-tests.el @@ -55,7 +55,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">"))) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) "world"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world"))))) @@ -64,7 +64,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (P ">"))) ;; By default, `tempo-interactive' is nil, `P' should ignore this. - (advice-flet ((read-string (lambda (&rest _) "world"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world")))) @@ -73,7 +73,7 @@ (with-temp-buffer (tempo-define-template "test" '("abcde" (r ">") "ghijk")) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) "F"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "F"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "abcdeFghijk"))))) @@ -82,7 +82,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">" P1) " " (s P1))) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) "world!"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world!"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world! world!"))))) @@ -164,7 +164,7 @@ ;; Test interactive use (emacs-lisp-mode) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) " (list 1 2 3)"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " (list 1 2 3)"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "(progn\n (list 1 2 3))"))))) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index ab662ffd959..e75e84b0221 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -57,8 +57,8 @@ (defmacro with-time-stamp-system-name (name &rest body) "Force (system-name) to return NAME while evaluating BODY." (declare (indent defun)) - `(advice-flet ((system-name - (lambda () ,name))) + `(cl-letf (((symbol-function 'system-name) + (lambda () ,name))) ,@body)) (defmacro time-stamp-should-warn (form) From 0b58be4941c92d337eccadabaaba5ef8620c5b52 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 22:18:57 +0200 Subject: [PATCH 1091/1452] Rename comp-subr-safe-advice -> comp-subr-trampoline-install --- lisp/emacs-lisp/advice.el | 2 +- lisp/emacs-lisp/comp.el | 2 +- lisp/emacs-lisp/nadvice.el | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 4df8743de50..fb67de3a029 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2076,7 +2076,7 @@ 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 (subr-primitive-p (symbol-function function)) - (comp-subr-safe-advice function)) + (comp-subr-trampoline-install function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ef13c0ce63e..7074ff759e0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2614,7 +2614,7 @@ Return the its filename if found or nil otherwise." `comp-eln-load-path'"))))) ;;;###autoload -(defun comp-subr-safe-advice (subr-name) +(defun comp-subr-trampoline-install (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." (unless (or (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5b3aa708508..03961325856 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -333,7 +333,7 @@ is also interactive. There are 3 cases: ;; Must require explicitly as during bootstrap we have no ;; autoloads. (require 'comp) - (comp-subr-safe-advice subr-name)))) + (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 From 87c6aa13b30281398688ec8693a0205bb84bc648 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 22:36:05 +0200 Subject: [PATCH 1092/1452] Make primitive redefinition effective through trampoline synthesis * lisp/loadup.el (dump-mode): Set `comp-enable-subr-trampolines' when finished bootstrap. * src/data.c (Ffset): Call `comp-enable-subr-trampolines' when redefining a subr. * src/comp.c (syms_of_comp): Define `comp-subr-trampoline-install' symbol. (syms_of_comp): Define `comp-enable-subr-trampolines' variable. --- lisp/loadup.el | 5 +++++ src/comp.c | 6 ++++++ src/data.c | 7 +++++++ 3 files changed, 18 insertions(+) diff --git a/lisp/loadup.el b/lisp/loadup.el index f218ec1ff98..91126703d18 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -510,6 +510,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 (boundp 'comp-ctxt) + (equal dump-mode "pdump")) + ;; Don't enable this before bootstrap is completed the as the + ;; compiler infrastructure may not be usable. + (setq comp-enable-subr-trampolines t)) (message "Dumping under the name %s" output) (condition-case () (delete-file output) diff --git a/src/comp.c b/src/comp.c index 5663c9e5624..076236ef80c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5141,6 +5141,7 @@ native compiled one. */); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); DEFSYM (Qgccjit, "gccjit"); + DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install") /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); @@ -5246,6 +5247,11 @@ The last directory of this list is assumed to be the system one. */); dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); + DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, + doc: /* When non-nil enable trampoline synthesis + triggerd by `fset' making primitives + redefinable effectivelly. */); + DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> bool. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); diff --git a/src/data.c b/src/data.c index 8c39c319110..c6629dd5f29 100644 --- a/src/data.c +++ b/src/data.c @@ -775,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; From f43dbe65ce14921aee2f45d21eb5f294ec8b92c1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Oct 2020 16:12:19 +0200 Subject: [PATCH 1093/1452] Add a test for primitive redefinition * test/src/comp-tests.el (primitive-redefine): New test. * test/src/comp-test-funcs.el (comp-test-primitive-redefine-f): New function. --- test/src/comp-test-funcs.el | 4 ++++ test/src/comp-tests.el | 11 +++++++++++ 2 files changed, 15 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 19acec2716e..9285ed62c2a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -341,6 +341,10 @@ (declare (speed 2)) (+ x y)) +(defun comp-test-primitive-redefine-f (x y) + (declare (speed 2)) + (- x y)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f954ae6a9dd..317a6113af2 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -398,6 +398,17 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal comp-test-primitive-advice '(3 4)))) (advice-remove #'+ f)))) +(defvar comp-test-primitive-redefine-args) +(comp-deftest primitive-redefine () + "Test effectiveness of primitve redefinition." + (cl-letf ((comp-test-primitive-redefine-args nil) + ((symbol-function #'-) + (lambda (&rest args) + (setq comp-test-primitive-redefine-args args) + 'xxx))) + (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx)) + (should (equal comp-test-primitive-redefine-args '(10 2))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 29f7024b6cfc01d6cae10603733b35784b4e4aef Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Oct 2020 21:33:08 +0200 Subject: [PATCH 1094/1452] * Fix a test in test/lisp/subr-tests.el * test/lisp/subr-tests.el (subr-tests-bug22027): Redefine `read-string' with a lambda with the same number of arguments. --- test/lisp/subr-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 035c064d75c..c3dfd27a850 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -338,7 +338,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))))) From 4a1bb4626053d5be5d3e869d6b7049dc3269d812 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Oct 2020 17:44:13 +0200 Subject: [PATCH 1095/1452] * Native compiling do not target a directory with no write permission * src/comp.c (Fcomp_el_to_eln_filename): Check for write permission while choosing the output directory in `comp-eln-load-path'. --- src/comp.c | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 076236ef80c..ba4089e5aeb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4080,8 +4080,22 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) separator); Lisp_Object hash = concat3 (path_hash, separator, content_hash); filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); + + /* If base_dir was not specified search inside Vcomp_eln_load_path + for the first directory where we have write access. */ if (NILP (base_dir)) - base_dir = XCAR (Vcomp_eln_load_path); + { + Lisp_Object eln_load_paths = Vcomp_eln_load_path; + FOR_EACH_TAIL (eln_load_paths) + if (!NILP (Ffile_writable_p (XCAR (eln_load_paths)))) + { + base_dir = XCAR (eln_load_paths); + break; + } + /* If we can't find it return Nil. */ + if (NILP (base_dir)) + return Qnil; + } if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); From bd2725796578c67075711adc4c1be7c2bf684214 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Oct 2020 08:40:00 +0200 Subject: [PATCH 1096/1452] * Better libgccjit related error messaging during configure * configure.ac: Distinguish the case when libgccjit is missing, its headers are missing, or libgccjit is broken. Message the user based on that. --- configure.ac | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index b7b0c268c84..100fbba06c9 100644 --- a/configure.ac +++ b/configure.ac @@ -3779,15 +3779,25 @@ AC_DEFUN([libgccjit_smoke_test], [ 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-nativecomp 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: . -Please report the issue to your distribution. +Please report the issue to your distribution if libgccjit was installed through +that. Here instructions on how to compile and install libgccjit from source: .])]) @@ -3800,10 +3810,13 @@ if test "${with_nativecomp}" != "no"; then if test "${HAVE_ZLIB}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires zlib]) 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" - AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], - [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) + # Check if libgccjit really works. + AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken]) LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes # mingw32 loads the library dynamically. From 58d85f4dbb878eca08c770b9de8f734ca78840db Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Oct 2020 07:41:00 +0200 Subject: [PATCH 1097/1452] * Do use echo area for async compilation started/finished messages * lisp/emacs-lisp/comp.el (comp-run-async-workers) (native-compile-async): Do not write into the echo area. --- lisp/emacs-lisp/comp.el | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7074ff759e0..01ffd4d40ec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2783,16 +2783,14 @@ display a message." when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) ;; No files left to compile and all processes finished. - (let ((msg "Compilation finished.")) - (run-hooks 'comp-async-all-done-hook) - (with-current-buffer (get-buffer-create comp-async-buffer-name) - (save-excursion - (goto-char (point-max)) - (insert msg "\n"))) - ;; `comp-deferred-pending-h' should be empty at this stage. - ;; Reset it anyway. - (clrhash comp-deferred-pending-h) - (message msg)))) + (run-hooks 'comp-async-all-done-hook) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (save-excursion + (goto-char (point-max)) + (insert "Compilation finished.\n"))) + ;; `comp-deferred-pending-h' should be empty at this stage. + ;; Reset it anyway. + (clrhash comp-deferred-pending-h))) ;;; Compiler entry points. @@ -2928,8 +2926,7 @@ queued with LOAD %" (format "No write access for %s skipping." out-filename))))))) (when (zerop (comp-async-runnings)) - (comp-run-async-workers) - (message "Compilation started.")))) + (comp-run-async-workers)))) (provide 'comp) From 7041c32ec2cd985f1c324c75ecea8038f998a792 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Oct 2020 20:43:00 +0200 Subject: [PATCH 1098/1452] * Fix some nits in comp.el * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Use `cl-defmethod' where correct in place of `cl-defgeneric'. (comp-tampoline-compile): Add missing #. --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 01ffd4d40ec..763d44a23e1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -661,7 +661,7 @@ clashes." (cl-defgeneric comp-spill-lap-function (input) "Byte compile INPUT and spill lap for further stages.") -(cl-defgeneric comp-spill-lap-function ((function-name symbol)) +(cl-defmethod comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) @@ -736,7 +736,7 @@ clashes." (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1)))) -(cl-defgeneric comp-spill-lap-function ((filename string)) +(cl-defmethod comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms @@ -2594,7 +2594,7 @@ Return the its filename if found or nil otherwise." (defalias trampoline-sym `(closure nil ,lambda-list (let ((f #',subr-name)) - (,(if (memq '&rest lambda-list) 'apply 'funcall) + (,(if (memq '&rest lambda-list) #'apply 'funcall) f ,@(cl-loop for arg in lambda-list From c3bc348f5edefa4231d38b6d3967f0c8f0bb5e6d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Oct 2020 23:38:00 +0200 Subject: [PATCH 1099/1452] * Fix failure when eln-cache is removed (introduced by 4a1bb46260) * src/comp.c (make_directory_wrapper, make_directory_wrapper_1): New functions. (Fcomp_el_to_eln_filename): If base_dir is not specified and we are searching across `comp-load-path' try to create a directory if does not exists. --- src/comp.c | 44 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 37 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index ba4089e5aeb..1b96bffeb87 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4013,6 +4013,19 @@ compile_function (Lisp_Object func) /* In use by Fcomp_el_to_eln_filename. */ static Lisp_Object loadsearch_re_list; +static Lisp_Object +make_directory_wrapper (Lisp_Object directory) +{ + CALL2I (make-directory, directory, Qt); + return Qnil; +} + +static Lisp_Object +make_directory_wrapper_1 (Lisp_Object ignore) +{ + return Qt; +} + DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, doc: /* Given a source FILENAME return the corresponding .eln filename. @@ -4087,14 +4100,31 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { Lisp_Object eln_load_paths = Vcomp_eln_load_path; FOR_EACH_TAIL (eln_load_paths) - if (!NILP (Ffile_writable_p (XCAR (eln_load_paths)))) - { - base_dir = XCAR (eln_load_paths); - break; - } - /* If we can't find it return Nil. */ + { + Lisp_Object dir = XCAR (eln_load_paths); + if (!NILP (Ffile_exists_p (dir))) + { + if (!NILP (Ffile_writable_p (dir))) + { + base_dir = dir; + break; + } + } + else + { + /* Try to create the directory and if succeeds use it. */ + if (NILP (internal_condition_case_1 (make_directory_wrapper, + dir, Qt, + make_directory_wrapper_1))) + { + base_dir = dir; + break; + } + } + } if (NILP (base_dir)) - return Qnil; + error ("Cannot find suitable directory for output in " + "`comp-native-laod-path'."); } if (!file_name_absolute_p (SSDATA (base_dir))) From 85450f03be6cbb3e09964ce62e1f63875f0848a3 Mon Sep 17 00:00:00 2001 From: Andrew Whatson Date: Sat, 10 Oct 2020 10:13:26 +0200 Subject: [PATCH 1100/1452] * Fix typo name plus make error homogeneous in `comp-trampoline-compile' * lisp/emacs-lisp/comp.el (comp-trampoline-compile): Fix typo renaming `comp-tampoline-compile' -> `comp-trampoline-compile'. Change error to be consistent. (comp-subr-trampoline-install): Use `comp-trampoline-compile'. --- lisp/emacs-lisp/comp.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 763d44a23e1..0445fc085e1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2580,7 +2580,7 @@ Return the its filename if found or nil otherwise." when (file-exists-p filename) do (cl-return filename))) -(defun comp-tampoline-compile (subr-name) +(defun comp-trampoline-compile (subr-name) "Synthesize and compile a trampoline for SUBR-NAME and return its filename." (let ((trampoline-sym (comp-trampoline-sym subr-name)) (lambda-list (comp-make-lambda-list-from-subr @@ -2610,7 +2610,7 @@ Return the its filename if found or nil otherwise." comp-native-version-dir)) when (file-writable-p f) do (cl-return f) - finally (error "Can't find a writable directory in \ + finally (error "Cannot find suitable directory for output in \ `comp-eln-load-path'"))))) ;;;###autoload @@ -2621,7 +2621,7 @@ Return the its filename if found or nil otherwise." (let ((trampoline-sym (comp-trampoline-sym subr-name))) (cl-assert (subr-primitive-p (symbol-function subr-name))) (load (or (comp-search-trampoline subr-name) - (comp-tampoline-compile subr-name)) + (comp-trampoline-compile subr-name)) nil t) (cl-assert (subr-native-elisp-p (symbol-function trampoline-sym))) From 138990bbda7ab228e3fde44710426c474b2c1086 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 10:15:21 +0200 Subject: [PATCH 1101/1452] * Fix failure when compiling a trampoline with no eln-cache dir (bug#43875) * lisp/emacs-lisp/comp.el (comp-trampoline-compile): Try to create the eln-cache dir if this is not existing, if fails to do that move on to the next one. --- lisp/emacs-lisp/comp.el | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0445fc085e1..dbd4cef1fc7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2603,11 +2603,15 @@ Return the its filename if found or nil otherwise." (native-compile trampoline-sym nil (cl-loop - for dir in comp-eln-load-path + for load-dir in comp-eln-load-path + for dir = (concat load-dir comp-native-version-dir) for f = (expand-file-name (comp-trampoline-filename subr-name) - (concat dir - comp-native-version-dir)) + dir) + unless (file-exists-p dir) + do (ignore-errors + (make-directory dir t) + (cl-return f)) when (file-writable-p f) do (cl-return f) finally (error "Cannot find suitable directory for output in \ From 51f5e487b2840be8c4aa19c4b06973ee7eef5085 Mon Sep 17 00:00:00 2001 From: Brian Leung Date: Sat, 10 Oct 2020 09:06:56 +0000 Subject: [PATCH 1102/1452] Various typo fixes in native compiler related files * lisp/emacs-lisp/comp.el (native-compiler-error-dyn-func) (comp-func, comp-func-l) (comp-func-d, comp-ensure-native-compiler, comp-type-hint-p) (comp-func-unique-in-cu-p, comp-alloc-class-to-container) (comp-limple-mode, comp-loop-insn-in-block) (comp-lex-byte-func-p, comp-c-func-name, comp-decrypt-arg-list) (comp-spill-lap-function, comp-intern-func-in-ctxt) (comp-spill-lap-function, comp-spill-lap, comp-emit-handler) (comp-prepare-args-for-top-level): Various typo fixes. * src/comp.c (Fcomp_el_to_eln_filename): Fix typo in error message. --- lisp/emacs-lisp/comp.el | 50 ++++++++++++++++++++--------------------- src/comp.c | 2 +- 2 files changed, 26 insertions(+), 26 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dbd4cef1fc7..1c5a4975f24 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -222,7 +222,7 @@ Useful to hook into pass checkers.") "Limple operators use to call subrs.") (define-error 'native-compiler-error-dyn-func - "can't native compile a non lexical scoped function" + "can't native compile a non-lexically-scoped function" 'native-compiler-error) (define-error 'native-compiler-error-empty-byte "empty byte compiler output" @@ -355,7 +355,7 @@ into it.") (c-name nil :type string :documentation "The function name in the native world.") (byte-func nil - :documentation "Byte compiled version.") + :documentation "Byte-compiled version.") (doc nil :type string :documentation "Doc string.") (int-spec nil :type list @@ -388,12 +388,12 @@ structure.") :documentation "t if pure nil otherwise.")) (cl-defstruct (comp-func-l (:include comp-func)) - "Lexical scoped function." + "Lexically-scoped function." (args nil :type comp-args-base :documentation "Argument specification of the function")) (cl-defstruct (comp-func-d (:include comp-func)) - "Dynamic scoped function." + "Dynamically-scoped function." (lambda-list nil :type list :documentation "Original lambda-list.")) @@ -419,8 +419,8 @@ structure.") (defun comp-ensure-native-compiler () - "Make sure Emacs has native compiler support and libgccjit is laodable. -Raise and error otherwise. + "Make sure Emacs has native compiler support and libgccjit is loadable. +Raise an error otherwise. To be used by all entry points." (cond ((null (boundp 'comp-ctxt)) @@ -445,11 +445,11 @@ To be used by all entry points." (comp-call-op-p (car-safe insn))) (defsubst comp-type-hint-p (func) - "Type hint predicate for function name FUNC." + "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) (defun comp-func-unique-in-cu-p (func) - "Return t if FUNC is know to be unique in the current compilation unit." + "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) (cl-loop with h = (make-hash-table :test #'eq) for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) @@ -473,8 +473,8 @@ To be used by all entry points." (comp-func-pure func)))) (defsubst comp-alloc-class-to-container (alloc-class) - "Given ALLOC-CLASS return the data container for the current context. -Assume allocaiton class 'd-default as default." + "Given ALLOC-CLASS, return the data container for the current context. +Assume allocation class 'd-default as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defsubst comp-add-const-to-relocs (obj) @@ -500,7 +500,7 @@ Assume allocaiton class 'd-default as default." "Highlights used by comp-limple-mode.") (define-derived-mode comp-limple-mode fundamental-mode "LIMPLE" - "Syntax highlight LIMPLE IR." + "Syntax-highlight LIMPLE IR." (setf font-lock-defaults '(comp-limple-lock-keywords))) (cl-defun comp-log (data &optional (level 1)) @@ -571,7 +571,7 @@ VERBOSITY is a number between 0 and 3." (defmacro comp-loop-insn-in-block (basic-block &rest body) - "Loop over all insns in BASIC-BLOCK executning BODY. + "Loop over all insns in BASIC-BLOCK executing BODY. Inside BODY `insn' can be used to read or set the current instruction." (declare (debug (form body)) @@ -584,7 +584,7 @@ instruction." ;;; spill-lap pass specific code. (defsubst comp-lex-byte-func-p (f) - "Return t if F is a lexical scoped byte compiled function." + "Return t if F is a lexically-scoped byte compiled function." (and (byte-code-function-p f) (fixnump (aref f 0)))) @@ -598,11 +598,11 @@ instruction." (or (comp-spill-decl-spec function-name 'speed) comp-speed)) -;; Autoloaded as might by used by `disassemble-internal'. +;; Autoloaded as might be used by `disassemble-internal'. ;;;###autoload (defun comp-c-func-name (name prefix &optional first) - "Given NAME return a name suitable for the native code. -Add PREFIX in front of it. If FIRST is not nil pick the first + "Given NAME, return a name suitable for the native code. +Add PREFIX in front of it. If FIRST is not nil, pick the first available name ignoring compilation context and potential name clashes." ;; Unfortunatelly not all symbol names are valid as C function names... @@ -633,7 +633,7 @@ clashes." (concat prefix crypted "_" human-readable "_0")))) (defun comp-decrypt-arg-list (x function-name) - "Decript argument list X for FUNCTION-NAME." + "Decrypt argument list X for FUNCTION-NAME." (unless (fixnump x) (signal 'native-compiler-error-dyn-func function-name)) (let ((rest (not (= (logand x 128) 0))) @@ -659,10 +659,10 @@ clashes." (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) (cl-defgeneric comp-spill-lap-function (input) - "Byte compile INPUT and spill lap for further stages.") + "Byte-compile INPUT and spill lap for further stages.") (cl-defmethod comp-spill-lap-function ((function-name symbol)) - "Byte compile FUNCTION-NAME spilling data from the byte compiler." + "Byte-compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name @@ -697,7 +697,7 @@ clashes." (comp-add-func-to-ctxt func)))) (defun comp-intern-func-in-ctxt (_ obj) - "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." + "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop @@ -737,7 +737,7 @@ clashes." (comp-log lap 1)))) (cl-defmethod comp-spill-lap-function ((filename string)) - "Byte compile FILENAME spilling data from the byte compiler." + "Byte-compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) @@ -760,7 +760,7 @@ clashes." (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) (defun comp-spill-lap (input) - "Byte compile and spill the LAP representation for INPUT. + "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) @@ -993,7 +993,7 @@ Return value is the fall through block name." bb))) (defun comp-emit-handler (lap-label handler-type) - "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." + "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label (cl-assert (= (- label-sp 2) (comp-sp))) (setf (comp-func-has-non-local comp-func) t) @@ -1405,10 +1405,10 @@ the annotation emission." func) (cl-defgeneric comp-prepare-args-for-top-level (function) - "Given FUNCTION return the two args arguments for comp--register-...") + "Given FUNCTION, return the two args arguments for comp--register-...") (cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) - "Lexical scoped FUNCTION." + "Lexically-scoped FUNCTION." (let ((args (comp-func-l-args function))) (cons (make-comp-mvar :constant (comp-args-base-min args)) (make-comp-mvar :constant (if (comp-args-p args) diff --git a/src/comp.c b/src/comp.c index 1b96bffeb87..13343de3d88 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4124,7 +4124,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) } if (NILP (base_dir)) error ("Cannot find suitable directory for output in " - "`comp-native-laod-path'."); + "`comp-native-load-path'."); } if (!file_name_absolute_p (SSDATA (base_dir))) From b8772e8b08fd269681f449fbe81172e2a2dad19f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 14:31:03 +0200 Subject: [PATCH 1103/1452] * Fix LIMPLE latch block name coloring in "*Native-compile-Log*" * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords): Fix latch block name coloring. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1c5a4975f24..a7da7d42e9c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -493,7 +493,7 @@ Assume allocation class 'd-default as default." (1 font-lock-variable-name-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num))))) + (1+ num) (? "_latch"))))) (1 font-lock-constant-face)) (,(rx "(" (group-n 1 (1+ (or word "-")))) (1 font-lock-keyword-face))) From 77fa6befb478f49a47ef1cee88e2c791e0037617 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 17:54:27 +0200 Subject: [PATCH 1104/1452] * lisp/emacs-lisp/comp.el (comp-func): Fix doc for blocks slot. --- lisp/emacs-lisp/comp.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a7da7d42e9c..d860fa31f0b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -368,8 +368,7 @@ Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") (frame-size nil :type number) (blocks (make-hash-table) :type hash-table - :documentation "Key is the basic block symbol value is a comp-block -structure.") + :documentation "Basic block name -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "LAP lable -> LIMPLE basic block name.") (edges () :type list From 8b135af5bbdfb6cf561f92a02ef92e855acc04dd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 18:18:09 +0200 Subject: [PATCH 1105/1452] Provide feature nativecomp and make use of it * lisp/emacs-lisp/comp.el (comp-ensure-native-compiler): Use `featurep' to identify if the native compiler is available. * lisp/emacs-lisp/nadvice.el (advice--add-function): Likewise. * lisp/emacs-lisp/package.el (package--delete-directory): Likewise. * lisp/loadup.el: Likewise. * src/comp.c (syms_of_comp): Provide feature nativecomp. --- lisp/emacs-lisp/comp.el | 2 +- lisp/emacs-lisp/nadvice.el | 2 +- lisp/emacs-lisp/package.el | 2 +- lisp/loadup.el | 4 ++-- src/comp.c | 1 + 5 files changed, 6 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d860fa31f0b..a4f2b6c36c7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -422,7 +422,7 @@ CFG is mutated by a pass.") Raise an error otherwise. To be used by all entry points." (cond - ((null (boundp 'comp-ctxt)) + ((null (featurep 'nativecomp)) (error "Emacs not compiled with native compiler support (--with-nativecomp)")) ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 03961325856..8b60c08440b 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -318,7 +318,7 @@ is also interactive. There are 3 cases: ;;;###autoload (defun advice--add-function (where ref function props) - (when (and (boundp 'comp-ctxt) + (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 diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ac1396f88df..c0125e64727 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2207,7 +2207,7 @@ If some packages are not installed propose to install them." "Delete DIR recursively. Clean-up the corresponding .eln files if Emacs is native compiled." - (when (boundp 'comp-ctxt) + (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)))) diff --git a/lisp/loadup.el b/lisp/loadup.el index 91126703d18..827087f763c 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,7 +449,7 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (boundp 'comp-ctxt) +(when (featurep 'nativecomp) ;; Fix the compilation unit filename to have it working when ;; when installed or if the source directory got moved. This is set to be ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). @@ -510,7 +510,7 @@ 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 (boundp 'comp-ctxt) + (when (and (featurep 'nativecomp) (equal dump-mode "pdump")) ;; Don't enable this before bootstrap is completed the as the ;; compiler infrastructure may not be usable. diff --git a/src/comp.c b/src/comp.c index 13343de3d88..0b5a49fd1f1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5300,6 +5300,7 @@ The last directory of this list is assumed to be the system one. */); doc: /* Hash table subr-name -> bool. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + Fprovide (intern_c_string ("nativecomp"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); From 96f59a9faf375409a0301a54fcb46fc2325a9cc2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Sep 2020 23:24:24 +0200 Subject: [PATCH 1106/1452] * Add into phi l-value args basic block names * lisp/emacs-lisp/comp.el (comp-ssa-rename-insn): Clean-up a leftover space. (comp-finalize-phis): Cons the blasic block name providing the mvar together with the mvar itself while forming the phi. (comp-fwprop-insn): Destructure correctly the phi. --- lisp/emacs-lisp/comp.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a4f2b6c36c7..be29f84cd32 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1920,7 +1920,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (`(fetch-handler . ,_) ;; Clobber all no matter what! (setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) - (`(phi ,n) + (`(phi ,n) (when (equal n slot-n) (new-lvalue))) (_ @@ -1958,7 +1958,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (aref in-frame slot-n))))) + collect (cons (aref in-frame slot-n) + (comp-block-name b)))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for (op . args) in (comp-block-insns b) @@ -2105,7 +2106,7 @@ Forward propagate immediate involed in assignments." (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v (comp-mvar-type lval) (comp-strict-type-of v))) - (`(phi ,lval . ,rest) + (`(phi (,lval . _) . ,rest) ;; Forward const prop here. (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) (consts (mapcar #'comp-mvar-constant rest)) From 4b924ef87d69d56ef78604fbcb50399578f83f5a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Sep 2020 23:43:35 +0200 Subject: [PATCH 1107/1452] * As edges are indexed store them in an hash table * lisp/emacs-lisp/comp.el (comp-edge): Update doc for 'number' slot. (comp-func): Rename 'edges' slot into 'edges-h'. (comp-log-edges): Update logic for edges in an hash table. (comp-clean-ssa, comp-compute-edges): Likewise. --- lisp/emacs-lisp/comp.el | 42 ++++++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index be29f84cd32..b4a86fc83ec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -336,7 +336,7 @@ into it.") (dst nil :type comp-block) (number nil :type number :documentation "The index number corresponding to this edge in the - edge vector.")) + edge hash.")) (defun comp-block-preds (basic-block) "Given BASIC-BLOCK return the list of its predecessors." @@ -371,8 +371,8 @@ CFG is mutated by a pass.") :documentation "Basic block name -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "LAP lable -> LIMPLE basic block name.") - (edges () :type list - :documentation "List of edges connecting basic blocks.") + (edges-h (make-hash-table) :type hash-table + :documentation "Hash edge-num -> edge connecting basic two blocks.") (block-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates block numbers.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function @@ -555,16 +555,16 @@ VERBOSITY is a number between 0 and 3." (defun comp-log-edges (func) "Log edges in FUNC." - (let ((edges (comp-func-edges func))) + (let ((edges (comp-func-edges-h func))) (comp-log (format "\nEdges in function: %s\n" (comp-func-name func)) 2) - (mapc (lambda (e) - (comp-log (format "n: %d src: %s dst: %s\n" - (comp-edge-number e) - (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e))) - 2)) + (maphash (lambda (_ e) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))) + 2)) edges))) @@ -1693,7 +1693,7 @@ into the C code forwarding the compilation unit." (defun comp-clean-ssa (f) "Clean-up SSA for funtion F." - (setf (comp-func-edges f) ()) + (setf (comp-func-edges-h f) (make-hash-table)) (cl-loop for b being each hash-value of (comp-func-blocks f) do (setf (comp-block-in-edges b) () @@ -1709,12 +1709,12 @@ into the C code forwarding the compilation unit." (defun comp-compute-edges () "Compute the basic block edges for the current function." - (cl-flet ((edge-add (&rest args) - (push - (apply #'make--comp-edge - :number (funcall (comp-func-edge-cnt-gen comp-func)) - args) - (comp-func-edges comp-func)))) + (cl-flet ((edge-add (&rest args &aux (n (funcall + (comp-func-edge-cnt-gen comp-func)))) + (puthash + n + (apply #'make--comp-edge :number n args) + (comp-func-edges-h comp-func)))) (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks @@ -1738,18 +1738,16 @@ into the C code forwarding the compilation unit." (list "block does not end with a branch" bb (comp-func-name comp-func))))) - finally - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) ;; Update edge refs into blocks. + finally (cl-loop - for edge in (comp-func-edges comp-func) + for edge being the hash-value in (comp-func-edges-h comp-func) do (push edge (comp-block-out-edges (comp-edge-src edge))) (push edge (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func)))) + (comp-log-edges comp-func)))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." From feed53f8b5da0e58cce412cd41a52883dba6c1be Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 21:30:04 +0200 Subject: [PATCH 1108/1452] * lisp/help.el (help-function-arglist): Fix non nativecomp builds (bug#43914) --- lisp/help.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/help.el b/lisp/help.el index 4d0c4d5d985..c166b63a56f 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1335,7 +1335,9 @@ 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 (subrp def) (listp (subr-native-lambda-list 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)) From 6606ec8e313bf48a1ac7b63c52bfeb64c4257107 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 12 Oct 2020 18:55:38 +0000 Subject: [PATCH 1109/1452] Fix some compilation warnings in non nativecomp build (bug#43892) * lisp/emacs-lisp/advice.el (comp-subr-trampoline-install): Declare function. * lisp/emacs-lisp/find-func.el (comp-eln-to-el-h): Declare variable. * lisp/emacs-lisp/nadvice.el (comp-subr-trampoline-install): Declare function. * lisp/files.el (comp-eln-to-el-h): Declare variable. * lisp/help.el (subr-native-lambda-list): Declare function. --- lisp/emacs-lisp/advice.el | 2 ++ lisp/emacs-lisp/find-func.el | 2 ++ lisp/emacs-lisp/nadvice.el | 2 ++ lisp/files.el | 2 ++ lisp/help.el | 2 ++ 5 files changed, 10 insertions(+) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index fb67de3a029..509e2551914 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2052,6 +2052,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. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 9e4d8cf1aa8..4417082971f 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,6 +178,8 @@ 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)." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 8b60c08440b..e68c1356081 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,6 +316,8 @@ 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) diff --git a/lisp/files.el b/lisp/files.el index 833a188b03b..1d330ce87bf 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -900,6 +900,8 @@ recursion." (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 diff --git a/lisp/help.el b/lisp/help.el index c166b63a56f..1a3fd35e44e 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1320,6 +1320,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 From a3304feb9be1489036574fdac2a4a3e4e7a0c38a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 12 Oct 2020 21:25:00 +0200 Subject: [PATCH 1110/1452] Revert "Fix some compilation warnings in non nativecomp build (bug#43892)" This reverts commit 6606ec8e313bf48a1ac7b63c52bfeb64c4257107. --- lisp/emacs-lisp/advice.el | 2 -- lisp/emacs-lisp/find-func.el | 2 -- lisp/emacs-lisp/nadvice.el | 2 -- lisp/files.el | 2 -- lisp/help.el | 2 -- 5 files changed, 10 deletions(-) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 509e2551914..fb67de3a029 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2052,8 +2052,6 @@ 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. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 4417082971f..9e4d8cf1aa8 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,8 +178,6 @@ 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)." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index e68c1356081..8b60c08440b 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,8 +316,6 @@ 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) diff --git a/lisp/files.el b/lisp/files.el index 1d330ce87bf..833a188b03b 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -900,8 +900,6 @@ recursion." (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 diff --git a/lisp/help.el b/lisp/help.el index 1a3fd35e44e..c166b63a56f 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1320,8 +1320,6 @@ 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 From 237fd33aef7e0f4b187ee0c1f367f27a90d603dc Mon Sep 17 00:00:00 2001 From: Brian Leung Date: Mon, 12 Oct 2020 18:55:38 +0000 Subject: [PATCH 1111/1452] Fix some compilation warnings in non nativecomp build (bug#43892) * lisp/emacs-lisp/advice.el (comp-subr-trampoline-install): Declare function. * lisp/emacs-lisp/find-func.el (comp-eln-to-el-h): Declare variable. * lisp/emacs-lisp/nadvice.el (comp-subr-trampoline-install): Declare function. * lisp/files.el (comp-eln-to-el-h): Declare variable. * lisp/help.el (subr-native-lambda-list): Declare function. --- lisp/emacs-lisp/advice.el | 2 ++ lisp/emacs-lisp/find-func.el | 2 ++ lisp/emacs-lisp/nadvice.el | 2 ++ lisp/files.el | 2 ++ lisp/help.el | 2 ++ 5 files changed, 10 insertions(+) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index fb67de3a029..509e2551914 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2052,6 +2052,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. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 9e4d8cf1aa8..4417082971f 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,6 +178,8 @@ 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)." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 8b60c08440b..e68c1356081 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,6 +316,8 @@ 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) diff --git a/lisp/files.el b/lisp/files.el index 833a188b03b..1d330ce87bf 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -900,6 +900,8 @@ recursion." (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 diff --git a/lisp/help.el b/lisp/help.el index c166b63a56f..1a3fd35e44e 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1320,6 +1320,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 From fda798808f8b518313cff3363a6ba72baed2d758 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 21:16:40 +0200 Subject: [PATCH 1112/1452] * Move context output computation in `comp-spill-lap-function' * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Move output filename computation here. (native-compile): From here. --- lisp/emacs-lisp/comp.el | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b4a86fc83ec..26654a300a2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -662,6 +662,9 @@ clashes." (cl-defmethod comp-spill-lap-function ((function-name symbol)) "Byte-compile FUNCTION-NAME spilling data from the byte compiler." + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) + (make-temp-file (symbol-name function-name) nil ".eln"))) (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name @@ -740,6 +743,11 @@ clashes." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename + filename + (when byte-native-for-bootstrap + (car (last comp-eln-load-path)))))) (setf (comp-ctxt-top-level-forms comp-ctxt) (cl-loop for form in (reverse byte-to-native-top-level-forms) @@ -2815,18 +2823,8 @@ Return the compile object filename." (comp-native-compiling t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) - (comp-ctxt - (make-comp-ctxt - :output (or (when output - (expand-file-name output)) - (if (symbolp function-or-file) - (make-temp-file (symbol-name function-or-file) nil - ".eln") - (comp-el-to-eln-filename - function-or-file - (when byte-native-for-bootstrap - (car (last comp-eln-load-path)))))) - :with-late-load with-late-load))) + (comp-ctxt (make-comp-ctxt :output output + :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) From 4bea0c0b1d907d676cc9abc8d7048103c10b8d79 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 10 Oct 2020 22:07:59 +0200 Subject: [PATCH 1113/1452] * Allow for lambda forms as native compilation input * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Add new specialized method for compiling a lambda form. --- lisp/emacs-lisp/comp.el | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 26654a300a2..89b4230dc2c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -698,6 +698,45 @@ clashes." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) +(cl-defmethod comp-spill-lap-function ((form list)) + "Byte-compile FORM spilling data from the byte compiler." + (unless (eq (car-safe form) 'lambda) + (signal 'native-compiler-error + "Cannot native compile, form is not a lambda")) + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) + (make-temp-file "comp-lambda-" nil ".eln"))) + (let* ((byte-code (byte-compile form)) + (c-name (comp-c-func-name "anonymous-lambda" "F")) + (func (if (comp-lex-byte-func-p byte-code) + (make-comp-func-l :c-name c-name + :doc (documentation form t) + :int-spec (interactive-form form) + :speed comp-speed) + (make-comp-func-d :c-name c-name + :doc (documentation form t) + :int-spec (interactive-form form) + :speed comp-speed)))) + (let ((lap (byte-to-native-lambda-lap + (gethash (aref byte-code 1) + byte-to-native-lambdas-h)))) + (cl-assert lap) + (comp-log lap 2) + (if (comp-func-l-p func) + (setf (comp-func-l-args func) + (comp-decrypt-arg-list (aref byte-code 0) byte-code)) + (setf (comp-func-d-lambda-list func) (cadr form))) + (setf (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size + byte-code)) + (setf (comp-func-byte-func func) byte-code + (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-func-def :name '--anonymous-lambda + :c-name c-name))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func)))) + (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) From 8861ee8b087b4e5d9ac9186a2c2d8e44b07fc186 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 12 Oct 2020 22:11:06 +0200 Subject: [PATCH 1114/1452] Have `native-elisp-load' return the last registerd function * lisp/emacs-lisp/comp.el (comp-emit-for-top-level): Synthesize 'top_level_run' so it returns the last value returned by `comp--register-subr'. * src/comp.c (load_comp_unit): Return what 'top_level_run' returns. (Fnative_elisp_load): Return what 'load_comp_unit' returns. * src/comp.h (load_comp_unit): Update signature. --- lisp/emacs-lisp/comp.el | 47 +++++++++++++++++++++++------------------ src/comp.c | 11 +++++----- src/comp.h | 4 ++-- 3 files changed, 34 insertions(+), 28 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 89b4230dc2c..98f552599e9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1480,24 +1480,26 @@ the annotation emission." (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-prepare-args-for-top-level f))) (cl-assert (and name f)) - (comp-emit (comp-call (if for-late-load - 'comp--late-register-subr - 'comp--register-subr) - (make-comp-mvar :constant name) - (car args) - (cdr args) - (make-comp-mvar :constant c-name) - (make-comp-mvar - :constant - (let* ((h (comp-ctxt-function-docs comp-ctxt)) - (i (hash-table-count h))) - (puthash i (comp-func-doc f) h) - i)) - (make-comp-mvar :constant - (comp-func-int-spec f)) - ;; This is the compilation unit it-self passed as - ;; parameter. - (make-comp-mvar :slot 0))))) + (comp-emit + `(set ,(make-comp-mvar :slot 1) + ,(comp-call (if for-late-load + 'comp--late-register-subr + 'comp--register-subr) + (make-comp-mvar :constant name) + (car args) + (cdr args) + (make-comp-mvar :constant c-name) + (make-comp-mvar + :constant + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i)) + (make-comp-mvar :constant + (comp-func-int-spec f)) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0)))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) for-late-load) @@ -1558,7 +1560,12 @@ into the C code forwarding the compilation unit." "late_top_level_run" "top_level_run") :args (make-comp-args :min 1 :max 1) - :frame-size 1 + ;; Frame is 2 wide: Slot 0 is the + ;; compilation unit being loaded + ;; (incoming parameter). Slot 1 is + ;; the last function being + ;; registered. + :frame-size 2 :speed comp-speed)) (comp-func func) (comp-pass (make-comp-limplify @@ -1575,7 +1582,7 @@ into the C code forwarding the compilation unit." (comp-ctxt-byte-func-to-func-h comp-ctxt)) (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) - (comp-emit `(return ,(make-comp-mvar :constant t))) + (comp-emit `(return ,(make-comp-mvar :slot 1))) (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) diff --git a/src/comp.c b/src/comp.c index 0b5a49fd1f1..f80172e89bf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4768,10 +4768,11 @@ unset_cu_load_ongoing (Lisp_Object comp_u) XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false; } -void +Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load) { + Lisp_Object res = Qnil; dynlib_handle_ptr handle = comp_u->handle; Lisp_Object comp_u_lisp_obj; XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); @@ -4897,7 +4898,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, } /* Executing this will perform all the expected environment modifications. */ - top_level_run (comp_u_lisp_obj); + res = top_level_run (comp_u_lisp_obj); /* Make sure data_ephemeral_vec still exists after top_level_run has run. Guard against sibling call optimization (or any other). */ data_ephemeral_vec = data_ephemeral_vec; @@ -4910,7 +4911,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, register_native_comp_unit (comp_u_lisp_obj); - return; + return res; } Lisp_Object @@ -5090,9 +5091,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, comp_u->data_vec = Qnil; comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); - load_comp_unit (comp_u, false, !NILP (late_load)); - - return Qt; + return load_comp_unit (comp_u, false, !NILP (late_load)); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/comp.h b/src/comp.h index 5c7bed6a304..077250ea869 100644 --- a/src/comp.h +++ b/src/comp.h @@ -75,8 +75,8 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void hash_native_abi (void); -extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, - bool loading_dump, bool late_load); +extern Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump, bool late_load); extern Lisp_Object native_function_doc (Lisp_Object function); From 4f0e87903095da1225830e27ef27e61ba9ff08af Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 12 Oct 2020 22:34:57 +0200 Subject: [PATCH 1115/1452] Rework `native-compile' interface so it can return compiled functions * lisp/emacs-lisp/comp.el (native-compile): Return the compiled function when the input is a symbol or a form. * test/src/comp-tests.el (free-fun, tco, fw-prop): Update tests for new `native-compile' interface. --- lisp/emacs-lisp/comp.el | 21 ++++++++++++++------- test/src/comp-tests.el | 6 +++--- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98f552599e9..cd13c44fa91 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2854,12 +2854,16 @@ display a message." ;;;###autoload (defun native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. -This is the entry-point for the Emacs Lisp native compiler. -FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. -When WITH-LATE-LOAD non-nil mark the compilation unit for late load -once finished compiling (internal use only). -When OUTPUT is non-nil use it as filename for the compiled object. -Return the compile object filename." +This is the syncronous entry-point for the Emacs Lisp native +compiler. +FUNCTION-OR-FILE is a function symbol, a form or the +filename of an Emacs Lisp source file. +When WITH-LATE-LOAD non-nil mark the compilation unit for late +load once finished compiling (internal use only). When OUTPUT is +non-nil use it as filename for the compiled object. +If FUNCTION-OR-FILE is a filename return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a +form return the compiled function." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -2888,7 +2892,10 @@ Return the compile object filename." (signal (car err) (if (consp err-val) (cons function-or-file err-val) (list function-or-file err-val)))))) - data)) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data)))) ;;;###autoload (defun batch-native-compile () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 317a6113af2..79bac3f711f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -359,7 +359,7 @@ Check that the resulting binaries do not differ." (interactive) 3) t) - (load (native-compile #'comp-tests-free-fun-f)) + (native-compile #'comp-tests-free-fun-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) (should (= (comp-tests-free-fun-f) 3)) @@ -692,7 +692,7 @@ CHECKER should always return nil to have a pass." b (comp-tests-tco-f (+ a b) a (- count 1)))) t) - (load (native-compile #'comp-tests-tco-f)) + (native-compile #'comp-tests-tco-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) @@ -714,7 +714,7 @@ CHECKER should always return nil to have a pass." (c (concat a b))) ; <= has to optimize (length c))) ; <= has to optimize t) - (load (native-compile #'comp-tests-fw-prop-1-f)) + (native-compile #'comp-tests-fw-prop-1-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) From e9c150b5c2efee4fad0e41668f5bf1ecb9fad0df Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 13 Oct 2020 21:43:01 +0200 Subject: [PATCH 1116/1452] * Add a test to verify form native compilation. * test/src/comp-tests.el (comp-deftest): Fix typo. (compile-forms): New test. --- test/src/comp-tests.el | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 79bac3f711f..a13235b2039 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -46,7 +46,7 @@ "Define a test for the native compiler tagging it as :nativecomp." (declare (indent defun) (doc-string 3)) - `(ert-deftest ,(intern (concat "compt-tests-" (symbol-name name))) ,args + `(ert-deftest ,(intern (concat "comp-tests-" (symbol-name name))) ,args :tags '(:nativecomp) ,@docstring-and-body)) @@ -409,6 +409,17 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx)) (should (equal comp-test-primitive-redefine-args '(10 2))))) +(comp-deftest compile-forms () + "Verify lambda form native compilation." + (should-error (native-compile '(+ 1 foo))) + (let ((f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3))) + (let* ((lexical-binding nil) + (f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 03e98f93f72c8a158a3584355bca174e2c63dce6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 13 Oct 2020 22:48:22 +0200 Subject: [PATCH 1117/1452] Use form native compilation in `comp-trampoline-compile' * lisp/emacs-lisp/comp.el (comp-trampoline-sym): Remove function. (comp-trampoline-filename): As we are introducing an ABI change in the eln trampoline format change the trampoline filename to disambiguate. (comp-trampoline-search): Rename from `comp-search-trampoline' and return directly the trampoline. (comp-trampoline-compile): Rework to use native form compilation in place of un-evaluating a function and return directly the trampoline. (comp-subr-trampoline-install): Update for `comp-trampoline-search' and `comp-trampoline-compile' new interfaces. * src/comp.c (Fcomp__install_trampoline): Store the trampoline itself as value in `comp-installed-trampolines-h'. (syms_of_comp): Doc update `comp-installed-trampolines-h'. --- lisp/emacs-lisp/comp.el | 66 +++++++++++++++++++---------------------- src/comp.c | 6 ++-- 2 files changed, 34 insertions(+), 38 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cd13c44fa91..a460340102a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2598,13 +2598,9 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive funciton advice machinery -(defsubst comp-trampoline-sym (subr-name) - "Given SUBR-NAME return the trampoline function name." - (intern (concat "--subr-trampoline-" (symbol-name subr-name)))) - (defsubst comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." - (concat (comp-c-func-name subr-name "subr-trampoline-" t) ".eln")) + (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) (defun comp-make-lambda-list-from-subr (subr) "Given SUBR return the equivalent lambda-list." @@ -2621,39 +2617,38 @@ Prepare every function for final compilation and drive the C back-end." (push (gensym "arg") lambda-list)) (reverse lambda-list))) -(defun comp-search-trampoline (subr-name) +(defun comp-trampoline-search (subr-name) "Search a trampoline file for SUBR-NAME. -Return the its filename if found or nil otherwise." +Return the trampoline if found or nil otherwise." (cl-loop with rel-filename = (comp-trampoline-filename subr-name) for dir in comp-eln-load-path for filename = (expand-file-name rel-filename (concat dir comp-native-version-dir)) when (file-exists-p filename) - do (cl-return filename))) + do (cl-return (native-elisp-load filename)))) (defun comp-trampoline-compile (subr-name) - "Synthesize and compile a trampoline for SUBR-NAME and return its filename." - (let ((trampoline-sym (comp-trampoline-sym subr-name)) - (lambda-list (comp-make-lambda-list-from-subr - (symbol-function subr-name))) - ;; Use speed 0 to maximize compilation speed and not to - ;; optimize away funcall calls! - (byte-optimize nil) - (comp-speed 0)) - ;; The synthesized trampoline must expose the exact same ABI of - ;; the primitive we are replacing in the function reloc table. - (defalias trampoline-sym - `(closure nil ,lambda-list - (let ((f #',subr-name)) - (,(if (memq '&rest lambda-list) #'apply 'funcall) - f - ,@(cl-loop - for arg in lambda-list - unless (memq arg '(&optional &rest)) - collect arg))))) + "Synthesize compile and return a trampoline for SUBR-NAME." + (let* ((lambda-list (comp-make-lambda-list-from-subr + (symbol-function subr-name))) + ;; The synthesized trampoline must expose the exact same ABI of + ;; the primitive we are replacing in the function reloc table. + (form `(lambda ,lambda-list + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) #'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + ;; Use speed 0 to maximize compilation speed and not to + ;; optimize away funcall calls! + (byte-optimize nil) + (comp-speed 0) + (lexical-binding t)) (native-compile - trampoline-sym nil + form nil (cl-loop for load-dir in comp-eln-load-path for dir = (concat load-dir comp-native-version-dir) @@ -2674,14 +2669,13 @@ Return the its filename if found or nil otherwise." "Make SUBR-NAME effectively advice-able when called from native code." (unless (or (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) - (let ((trampoline-sym (comp-trampoline-sym subr-name))) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (load (or (comp-search-trampoline subr-name) - (comp-trampoline-compile subr-name)) - nil t) - (cl-assert - (subr-native-elisp-p (symbol-function trampoline-sym))) - (comp--install-trampoline subr-name (symbol-function trampoline-sym))))) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (comp--install-trampoline + subr-name + (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name) + ;; Should never happen. + (cl-assert nil))))) ;; Some entry point support code. diff --git a/src/comp.c b/src/comp.c index f80172e89bf..0c555578f81 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4158,7 +4158,7 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, if (EQ (subr, orig_subr)) { freloc.link_table[i] = XSUBR (trampoline)->function.a0; - Fputhash (subr_name, Qt, Vcomp_installed_trampolines_h); + Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h); return Qt; } i++; @@ -5296,7 +5296,9 @@ The last directory of this list is assumed to be the system one. */); redefinable effectivelly. */); DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, - doc: /* Hash table subr-name -> bool. */); + doc: /* Hash table subr-name -> installed trampoline. +This is used to prevent double trampoline instantiation but also to +protect the trampolines against GC. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); Fprovide (intern_c_string ("nativecomp"), Qnil); From 03dfa83dc35738c9228b66b3d3f72753b344f939 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 15 Oct 2020 12:32:58 +0200 Subject: [PATCH 1118/1452] * Do not check eln timestamp as superseded by source hashing (bug#43532) * src/lread.c (maybe_swap_for_eln): Remove eln file timestamp check given is now unnecessary. (openp): Update for new 'maybe_swap_for_eln' signature. --- src/lread.c | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/src/lread.c b/src/lread.c index ea31131b755..6aab470eb2f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1589,7 +1589,7 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) If found replace the content of FILENAME and FD. */ static void -maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) +maybe_swap_for_eln (Lisp_Object *filename, int *fd) { #ifdef HAVE_NATIVE_COMP struct stat eln_st; @@ -1621,19 +1621,13 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) emacs_close (eln_fd); else { - struct timespec eln_mtime = get_stat_mtime (&eln_st); - if (timespec_cmp (eln_mtime, mtime) > 0) - { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - src_name, Vcomp_eln_to_el_h); - return; - } - else - emacs_close (eln_fd); + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + src_name, Vcomp_eln_to_el_h); + return; } } } @@ -1878,7 +1872,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - maybe_swap_for_eln (&string, &fd, get_stat_mtime (&st)); + maybe_swap_for_eln (&string, &fd); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; @@ -1890,7 +1884,7 @@ 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 (&save_string, &save_fd, save_mtime); + maybe_swap_for_eln (&save_string, &save_fd); if (storeptr) *storeptr = save_string; SAFE_FREE (); From 79ca25c085f89760cb87c8e10378a00a4af3fec7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 19 Oct 2020 21:48:31 +0200 Subject: [PATCH 1119/1452] * Have `native-compile' do not expose `with-late-load' parameter This is really for internal use only by deferred compilation. * lisp/emacs-lisp/comp.el (comp-trampoline-compile) (comp-run-async-workers): Make use of `comp--native-compile'. (comp--native-compile): New function. (native-compile, batch-native-compile): Make use of `comp--native-compile'. --- lisp/emacs-lisp/comp.el | 40 +++++++++++++++++++++++----------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a460340102a..6c54085750c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2647,7 +2647,7 @@ Return the trampoline if found or nil otherwise." (byte-optimize nil) (comp-speed 0) (lexical-binding t)) - (native-compile + (comp--native-compile form nil (cl-loop for load-dir in comp-eln-load-path @@ -2796,7 +2796,7 @@ display a message." load-path ',load-path) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) - (native-compile ,source-file ,(and load t)))) + (comp--native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ (temp-file (make-temp-file (concat "emacs-async-comp-" @@ -2842,22 +2842,11 @@ display a message." ;; Reset it anyway. (clrhash comp-deferred-pending-h))) - -;;; Compiler entry points. - -;;;###autoload -(defun native-compile (function-or-file &optional with-late-load output) +(defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. -This is the syncronous entry-point for the Emacs Lisp native -compiler. -FUNCTION-OR-FILE is a function symbol, a form or the -filename of an Emacs Lisp source file. +This serves as internal implementation of `native-compile'. When WITH-LATE-LOAD non-nil mark the compilation unit for late -load once finished compiling (internal use only). When OUTPUT is -non-nil use it as filename for the compiled object. -If FUNCTION-OR-FILE is a filename return the filename of the -compiled object. If FUNCTION-OR-FILE is a function symbol or a -form return the compiled function." +load once finished compiling." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -2891,6 +2880,23 @@ form return the compiled function." ;; So we return the compiled function. (native-elisp-load data)))) + +;;; Compiler entry points. + +;;;###autoload +(defun native-compile (function-or-file &optional output) + "Compile FUNCTION-OR-FILE into native code. +This is the syncronous entry-point for the Emacs Lisp native +compiler. +FUNCTION-OR-FILE is a function symbol, a form or the filename of +an Emacs Lisp source file. +When OUTPUT is non-nil use it as filename for the compiled +object. +If FUNCTION-OR-FILE is a filename return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a +form return the compiled function." + (comp--native-compile function-or-file nil output)) + ;;;###autoload (defun batch-native-compile () "Run `native-compile' on remaining command-line arguments. @@ -2900,7 +2906,7 @@ Ultra cheap impersonation of `batch-byte-compile'." if (or (null byte-native-for-bootstrap) (cl-notany (lambda (re) (string-match re file)) comp-bootstrap-black-list)) - do (native-compile file) + do (comp--native-compile file) else do (byte-compile-file file))) From 3be93390fb6680d1e0c3256af72c86635a9eb327 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 20 Oct 2020 20:55:11 +0100 Subject: [PATCH 1120/1452] Sanitize eln filename when native compiling single functions * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Fix temporary eln name generation. * test/src/comp-tests.el (free-fun-silly-name): New testcase. --- lisp/emacs-lisp/comp.el | 3 ++- test/src/comp-tests.el | 6 ++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6c54085750c..4967e8558b8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -664,7 +664,8 @@ clashes." "Byte-compile FUNCTION-NAME spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) - (make-temp-file (symbol-name function-name) nil ".eln"))) + (make-temp-file (comp-c-func-name function-name "freefn-") + nil ".eln"))) (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a13235b2039..b9a0a8771e5 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -369,6 +369,12 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(comp-deftest free-fun-silly-name () + "Check we are able to compile a single function." + (eval '(defun comp-tests/free\fun-f ()) t) + (native-compile #'comp-tests/free\fun-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + (comp-deftest bug-40187 () "Check function name shadowing. https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." From ada80d66d663ac9e07082f6038528f004f9aca1f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 25 Oct 2020 09:41:56 +0000 Subject: [PATCH 1121/1452] * Fix `comp-dry-run' effectiveness * lisp/emacs-lisp/comp.el (comp-compile-ctxt-to-file): Remove `comp-dry-run' guard. (comp-final): And move it here so is effective for interactive sessions and non. --- lisp/emacs-lisp/comp.el | 80 ++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4967e8558b8..a13b974b94d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2526,8 +2526,7 @@ Prepare every function for final compilation and drive the C back-end." ;; In case it's created in the meanwhile. (ignore-error 'file-already-exists (make-directory dir t))) - (unless comp-dry-run - (comp--compile-ctxt-to-file name)))) + (comp--compile-ctxt-to-file name))) (defun comp-final1 () (let (compile-result) @@ -2540,44 +2539,45 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." - (if noninteractive - (comp-final1) - ;; Call comp-final1 in a child process. - (let* ((output (comp-ctxt-output comp-ctxt)) - (print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle t) - (expr `(progn - (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - comp-ctxt ,comp-ctxt - comp-eln-load-path ',comp-eln-load-path - comp-native-driver-options - ',comp-native-driver-options - load-path ',load-path) - ,comp-async-env-modifier-form - (message "Compiling %s..." ',output) - (comp-final1))) - (temp-file (make-temp-file - (concat "emacs-int-comp-" - (file-name-base output) "-") - nil ".el"))) - (with-temp-file temp-file - (insert (prin1-to-string expr))) - (with-temp-buffer - (unwind-protect - (if (zerop - (call-process (expand-file-name invocation-name - invocation-directory) - nil t t "--batch" "-l" temp-file)) - output - (signal 'native-compiler-error (buffer-string))) - (comp-log-to-buffer (buffer-string))))))) + (unless comp-dry-run + (if noninteractive + (comp-final1) + ;; Call comp-final1 in a child process. + (let* ((output (comp-ctxt-output comp-ctxt)) + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t) + (expr `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + comp-ctxt ,comp-ctxt + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path) + ,comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) + (temp-file (make-temp-file + (concat "emacs-int-comp-" + (file-name-base output) "-") + nil ".el"))) + (with-temp-file temp-file + (insert (prin1-to-string expr))) + (with-temp-buffer + (unwind-protect + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + output + (signal 'native-compiler-error (buffer-string))) + (comp-log-to-buffer (buffer-string)))))))) ;;; Compiler type hints. From 868d3ff9b87ce85014870c9688b899e640866b48 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 23 Oct 2020 10:26:31 +0200 Subject: [PATCH 1122/1452] * Report warnings and errors from native asynchronous compilation (bug#44168) * lisp/emacs-lisp/comp.el (comp-last-scanned-async-output): New buffer local variable. (comp-accept-and-process-async-output): New function. (comp-run-async-workers): Use `comp-accept-and-process-async-output'. --- lisp/emacs-lisp/comp.el | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a13b974b94d..1808e727bb9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -128,6 +128,11 @@ before compilation. Usable to modify the compiler environment." :type 'list :group 'comp) +(defcustom comp-async-report-warnings-errors t + "Report warnings and errors from native asynchronous compilation." + :type 'boolean + :group 'comp) + (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. Note that not all options are meaningful; typically only the options @@ -2768,6 +2773,21 @@ processes from `comp-async-compilations'" 2)))) comp-async-jobs-number)) +(defvar comp-last-scanned-async-output nil) +(make-variable-buffer-local 'comp-last-scanned-async-output) +(defun comp-accept-and-process-async-output (process) + "Accept PROCESS output and check for diagnostic messages." + (if comp-async-report-warnings-errors + (with-current-buffer (process-buffer process) + (save-excursion + (accept-process-output process) + (goto-char (or comp-last-scanned-async-output (point-min))) + (while (re-search-forward "^.*+?\\(?:Error\\|Warning\\): .*$" + nil t) + (display-warning 'comp (match-string 0))) + (setq comp-last-scanned-async-output (point-max)))) + (accept-process-output process))) + (defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. When compilation is finished, run `comp-async-all-done-hook' and @@ -2822,7 +2842,7 @@ display a message." (run-hook-with-args 'comp-async-cu-done-hook source-file) - (accept-process-output process) + (comp-accept-and-process-async-output process) (ignore-errors (delete-file temp-file)) (when (and load1 (zerop (process-exit-status process))) From ac143165ccf31f4c0b18947e92cb6cb18ae67323 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 25 Oct 2020 15:45:27 +0000 Subject: [PATCH 1123/1452] * Fix ELC+ELN vs ELC prefix while building non AoT native compiled files * lisp/Makefile.in (am__v_ELC_0): Set it correctly when NATIVE_DISABLED is 1. --- lisp/Makefile.in | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 91873086d2b..d6bb4cf5570 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -37,7 +37,11 @@ HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) ifeq ($(HAVE_NATIVE_COMP),yes) +ifeq ($(NATIVE_DISABLED),1) +am__v_ELC_0 = @echo " ELC " $@; +else am__v_ELC_0 = @echo " ELC+ELN " $@; +endif ifndef NATIVE_FULL_AOT NATIVE_SKIP_NONDUMP = 1 endif From 096c78523d849a75847152dff7458e883d668cb8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 25 Oct 2020 19:31:39 +0000 Subject: [PATCH 1124/1452] * Fix a function for native compilation in cc-bytecomp.el * lisp/progmodes/cc-bytecomp.el (cc-bytecomp-compiling-or-loading): Update for native compilation. --- lisp/progmodes/cc-bytecomp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index ad884288a6d..7798b49f398 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -110,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") From 5edc7aa0193ec73f757e85012273c159301f64a9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 25 Oct 2020 21:19:25 +0000 Subject: [PATCH 1125/1452] Fix defsubst effectiveness (bug#44209) * lisp/emacs-lisp/byte-run.el (defsubst): Fix macro definition. * test/src/comp-tests.el (comp-test-defsubst): New testcase. * test/src/comp-test-funcs.el (comp-test-defsubst-f): New function. --- lisp/emacs-lisp/byte-run.el | 8 ++++---- test/src/comp-test-funcs.el | 3 +++ test/src/comp-tests.el | 4 ++++ 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 042a26a2e31..1bc78391886 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -363,13 +363,13 @@ You don't need this. (See bytecomp.el commentary for more details.) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) - ;; Never native-compile defsubsts as we need the byte - ;; definition in `byte-compile-unfold-bcf' to perform the - ;; inlining (Bug#42664). - (byte-run--set-speed name nil -1) `(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)) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 9285ed62c2a..35df46a9b84 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -345,6 +345,9 @@ (declare (speed 2)) (- x y)) +(defsubst comp-test-defsubst-f () + t) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b9a0a8771e5..ae96e5d3868 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -426,6 +426,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (subr-native-elisp-p f)) (should (= (funcall f 2) 3)))) +(comp-deftest comp-test-defsubst () + ;; Bug#42664, Bug#43280, Bug#44209. + (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From fd9e9308d27138a16e2e93417bd7ad4448fea40a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 26 Oct 2020 16:31:13 +0000 Subject: [PATCH 1126/1452] Make native compiler tollerant to redefined primitives (bug#44221). * lisp/emacs-lisp/comp.el (comp-emit-set-call-subr): Rework based on the fact that the subr can now be redefined. * test/src/comp-tests.el (primitive-redefine-compile-44221): New testcase. --- lisp/emacs-lisp/comp.el | 4 +--- test/src/comp-tests.el | 9 +++++++++ 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1808e727bb9..15b8b3ab8da 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1153,9 +1153,7 @@ Return value is the fall through block name." SP-DELTA is the stack adjustment." (let ((subr (symbol-function subr-name)) (nargs (1+ (- sp-delta)))) - (unless (subrp subr) - (signal 'native-ice (list "not a subr" subr))) - (let* ((arity (subr-arity subr)) + (let* ((arity (func-arity subr)) (minarg (car arity)) (maxarg (cdr arity))) (when (eq maxarg 'unevalled) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ae96e5d3868..446a61549d9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -430,6 +430,15 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ;; Bug#42664, Bug#43280, Bug#44209. (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) +(comp-deftest primitive-redefine-compile-44221 () + "Test the compiler still works while primitives are redefined (bug#44221)." + (cl-letf (((symbol-function #'delete-region) + (lambda (_ _)))) + (should (subr-native-elisp-p + (native-compile + '(lambda () + (delete-region (point-min) (point-max)))))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 047fe3292d2f102c9aed4dc305de165b627bcddd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Nov 2020 09:57:06 +0100 Subject: [PATCH 1127/1452] * Rework some native compiler test infrastructure * test/src/comp-tests.el (comp-tests-map-checker): New function returning a list holding checker results. (comp-tests-tco-checker, comp-tests-fw-prop-checker-1) (comp-tests-pure-checker-1, comp-tests-pure-checker-2): Make use of `comp-tests-map-checker'. --- test/src/comp-tests.el | 79 ++++++++++++++++++++++++------------------ 1 file changed, 45 insertions(+), 34 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 446a61549d9..4834e21fba3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -686,28 +686,29 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." 'comment) (comp-tests-mentioned-p-1 x insn))) -(defun comp-tests-make-insn-checker (func-name checker) - "Apply CHECKER to each insn in FUNC-NAME. -CHECKER should always return nil to have a pass." - (should-not - (cl-loop - named checker-loop - with func-c-name = (comp-c-func-name func-name "F" t) +(defun comp-tests-map-checker (func-name checker) + "Apply CHECKER to each insn of FUNC-NAME. +Return a list of results." + (cl-loop + with func-c-name = (comp-c-func-name (or func-name 'anonymous-lambda) "F" t) with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt)) for bb being each hash-value of (comp-func-blocks f) - do (cl-loop - for insn in (comp-block-insns bb) - when (funcall checker insn) - do (cl-return-from checker-loop 'mentioned))))) + nconc + (cl-loop + for insn in (comp-block-insns bb) + collect (funcall checker insn)))) (defun comp-tests-tco-checker (_) "Check that inside `comp-tests-tco-f' we have no recursion." - (comp-tests-make-insn-checker - 'comp-tests-tco-f - (lambda (insn) - (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) - (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) - insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-tco-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) + insn))))))) (comp-deftest tco () "Check for tail recursion elimination." @@ -728,11 +729,14 @@ CHECKER should always return nil to have a pass." (defun comp-tests-fw-prop-checker-1 (_) "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded." - (comp-tests-make-insn-checker - 'comp-tests-fw-prop-1-f - (lambda (insn) - (or (comp-tests-mentioned-p 'concat insn) - (comp-tests-mentioned-p 'length insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-fw-prop-1-f + (lambda (insn) + (or (comp-tests-mentioned-p 'concat insn) + (comp-tests-mentioned-p 'length insn))))))) (comp-deftest fw-prop () "Some tests for forward propagation." @@ -751,21 +755,28 @@ CHECKER should always return nil to have a pass." (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is folded." - (comp-tests-make-insn-checker - 'comp-tests-pure-caller-f - (lambda (insn) - (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) - (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-callee-f "F" t) - insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-caller-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) + (comp-tests-mentioned-p (comp-c-func-name + 'comp-tests-pure-callee-f "F" t) + insn))))))) (defun comp-tests-pure-checker-2 (_) "Check that `comp-tests-pure-fibn-f' is folded." - (comp-tests-make-insn-checker - 'comp-tests-pure-fibn-entry-f - (lambda (insn) - (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) - (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) - insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-fibn-entry-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) + insn))))))) (comp-deftest pure () "Some tests for pure functions optimization." From 42970cceb9b15212f1a2a28a4595efc8c960f929 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 27 Oct 2020 19:40:55 +0000 Subject: [PATCH 1128/1452] Add new cond-rw pass to have forward propagation track cond branches Add a new pass to rewrite conditional branches. This is introducing and placing a new LIMPLE operator 'assume' in use by fwprop to propagate conditional branch test informations on target basic blocks. * lisp/emacs-lisp/comp.el (comp-passes): Add `comp-cond-rw'. (comp-limple-assignments): Add `assume' operator. (comp-emit-assume, comp-cond-rw-target-slot, comp-cond-rw-func) (comp-cond-rw): Add new functions. (comp-fwprop-insn): Update to pattern match `assume' insns. * src/comp.c (emit_limple_insn): Add for `assume'. (syms_of_comp): Define 'Qassume' symbol. --- lisp/emacs-lisp/comp.el | 83 ++++++++++++++++++++++++++++++++++++++++- src/comp.c | 5 ++- 2 files changed, 85 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 15b8b3ab8da..9b26f6c4198 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -171,6 +171,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-fwprop comp-call-optim comp-ipa-pure + comp-cond-rw comp-fwprop comp-dead-code comp-tco @@ -216,7 +217,8 @@ Useful to hook into pass checkers.") set-rest-args-to-local) "Limple set operators.") -(defconst comp-limple-assignments `(fetch-handler +(defconst comp-limple-assignments `(assume + fetch-handler ,@comp-limple-sets) "Limple operators that clobbers the first m-var argument.") @@ -1676,6 +1678,73 @@ into the C code forwarding the compilation unit." (when (comp-ctxt-with-late-load comp-ctxt) (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + +;;; conditional branches rewrite pass specific code. + +(defun comp-emit-assume (target-slot rhs bb-name kind) + "Emit an assume of kind KIND for TARGET-SLOT being RHS. +The assume is emitted at the beginning of the block named +BB-NAME." + (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind) + (comp-block-insns (gethash bb-name (comp-func-blocks comp-func)))) + (setf (comp-func-ssa-status comp-func) 'dirty)) + +(defun comp-cond-rw-target-slot (slot-num exit-insn bb) + "Search for the last assignment of SLOT-NUM in BB. +Keep on searching till EXIT-INSN is encountered. +Return the corresponding rhs slot number." + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-num (comp-mvar-slot x))))) + (cl-loop + with res = nil + for insn in (comp-block-insns bb) + when (eq insn exit-insn) + do (cl-return (and (comp-mvar-p res) (comp-mvar-slot res))) + do (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (setf res rhs))) + finally (cl-assert nil)))) + +(defun comp-cond-rw-func () + "`comp-cond-rw' worker function for each selected function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) cond) + (,(pred comp-call-op-p) + ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) + (comment ,_comment-str) + (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2)) + (when-let ((target-slot1 (comp-cond-rw-target-slot + (comp-mvar-slot op1) (car insns-seq) b))) + (comp-emit-assume target-slot1 op2 bb-1 test-fn)) + (when-let ((target-slot2 (comp-cond-rw-target-slot + (comp-mvar-slot op2) (car insns-seq) b))) + (comp-emit-assume target-slot2 op1 bb-1 test-fn)) + (cl-return-from in-the-basic-block)))))) + +(defun comp-cond-rw (_) + "Rewrite conditional branches adding appropriate 'assume' insns. +This is introducing and placing 'assume' insns in use by fwprop +to propagate conditional branch test informations on target basic +blocks." + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 1) + ;; No point to run this on dynamic scope as + ;; this pass is effecive only on local + ;; variables. + (comp-func-l-p f) + (not (comp-func-has-non-local f))) + (let ((comp-func f)) + (comp-cond-rw-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + ;;; pure-func pass specific code. @@ -2158,6 +2227,18 @@ Forward propagate immediate involed in assignments." (comp-function-call-maybe-remove insn f args))) (_ (comp-mvar-propagate lval rval)))) + (`(assume ,lval ,rval ,kind) + (pcase kind + ('eq + (comp-mvar-propagate lval rval)) + ((or 'eql 'equal) + (if (memq (comp-mvar-type rval) '(symbol fixnum)) + (comp-mvar-propagate lval rval) + (setf (comp-mvar-type lval) (comp-mvar-type rval)))) + ('= + (if (eq (comp-mvar-type rval) 'fixnum) + (comp-mvar-propagate lval rval) + (setf (comp-mvar-type lval) 'number))))) (`(setimm ,lval ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v diff --git a/src/comp.c b/src/comp.c index 0c555578f81..48e4f1c8cde 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2131,9 +2131,9 @@ emit_limple_insn (Lisp_Object insn) n); emit_cond_jump (test, target2, target1); } - else if (EQ (op, Qphi)) + else if (EQ (op, Qphi) || EQ (op, Qassume)) { - /* Nothing to do for phis into the backend. */ + /* Nothing to do for phis or assumes in the backend. */ } else if (EQ (op, Qpush_handler)) { @@ -5134,6 +5134,7 @@ native compiled one. */); DEFSYM (Qcallref, "callref"); DEFSYM (Qdirect_call, "direct-call"); DEFSYM (Qdirect_callref, "direct-callref"); + DEFSYM (Qassume, "assume"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); From e1a168f9a73cfb5a70d3f313e62dd1eaab14e214 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Nov 2020 14:37:13 +0100 Subject: [PATCH 1129/1452] * Add some 'cond-rw' pass related tests * test/src/comp-tests.el (comp-tests-cond-rw-checked-function): Declare var. (comp-tests-cond-rw-checker-val): New function. (comp-tests-cond-rw-checker-type): Declare var. (comp-tests-cond-rw-checker-type): New function. (comp-tests-cond-rw-0-var): Declare var. (comp-tests-cond-rw-0, comp-tests-cond-rw-1, comp-tests-cond-rw-2) (comp-tests-cond-rw-3, comp-tests-cond-rw-4) (comp-tests-cond-rw-5): New testcases. --- test/src/comp-tests.el | 91 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4834e21fba3..9c3c7f62a30 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -791,4 +791,95 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) (should (= (comp-tests-pure-fibn-entry-f) 6765)))) +(defvar comp-tests-cond-rw-checked-function nil + "Function to be checked.") +(defun comp-tests-cond-rw-checker-val (_) + "Check we manage to propagate the correct return value." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (and (comp-mvar-const-vld mvar) + (= (comp-mvar-constant mvar) 123))))))))) + +(defvar comp-tests-cond-rw-expected-type nil + "Type to expect in `comp-tests-cond-rw-checker-type'.") +(defun comp-tests-cond-rw-checker-type (_) + "Check we manage to propagate the correct return type." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (eq (comp-mvar-type mvar) comp-tests-cond-rw-expected-type)))))))) + +(defvar comp-tests-cond-rw-0-var) +(comp-deftest cond-rw-0 () + "Check we do not miscompile some simple functions." + (let ((lexical-binding t)) + (let ((f (native-compile '(lambda (l) + (when (eq (car l) 'x) + (cdr l)))))) + (should (subr-native-elisp-p f)) + (should (eq (funcall f '(x . y)) 'y)) + (should (null (funcall f '(z . y))))) + + (should + (subr-native-elisp-p + (native-compile '(lambda () (if (eq comp-tests-cond-rw-0-var 123) 5 10))))))) + +(comp-deftest cond-rw-1 () + "Test cond-rw pass allow us to propagate type+val under `eq' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) + (comp-final comp-tests-cond-rw-checker-val)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t)))))) + +(comp-deftest cond-rw-2 () + "Test cond-rw pass allow us to propagate type+val under `=' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) + (comp-final comp-tests-cond-rw-checker-val)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t)))))) + +(comp-deftest cond-rw-3 () + "Test cond-rw pass allow us to propagate type+val under `eql' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) + (comp-final comp-tests-cond-rw-checker-val)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t)))))) + +(comp-deftest cond-rw-4 () + "Test cond-rw pass allow us to propagate type under `=' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'number) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) + (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t)))))) + +(comp-deftest cond-rw-5 () + "Test cond-rw pass allow us to propagate type under `=' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) + (eval '(defun comp-tests-cond-rw-4-f (x y) + (declare (speed 3)) + (if (= x (comp-hint-fixnum y)) + x + t)) + t) + (native-compile #'comp-tests-cond-rw-4-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f))))) + ;;; comp-tests.el ends here From 933fd76f8fa4583aa3c4cc6e6e22f9a96638c5a5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Nov 2020 14:41:17 +0100 Subject: [PATCH 1130/1452] * test/src/comp-tests.el (compile-forms): Fix missing lexical binding. --- test/src/comp-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9c3c7f62a30..21c8abad038 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -418,7 +418,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest compile-forms () "Verify lambda form native compilation." (should-error (native-compile '(+ 1 foo))) - (let ((f (native-compile '(lambda (x) (1+ x))))) + (let ((lexical-binding t) + (f (native-compile '(lambda (x) (1+ x))))) (should (subr-native-elisp-p f)) (should (= (funcall f 2) 3))) (let* ((lexical-binding nil) From 3e3843512bfae0b7a532f633e45d4c140807ec9b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 1 Nov 2020 13:58:06 +0100 Subject: [PATCH 1131/1452] * Fix 'comp-call-optim pass' for anonymous lambdas * lisp/emacs-lisp/comp.el (comp-call-optim-func): Remove anonymous lambdas gate. (comp-call-optim-form-call): Add the correct missing condition. --- lisp/emacs-lisp/comp.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9b26f6c4198..b35fe9bfcbb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2346,6 +2346,7 @@ FUNCTION can be a function-name or byte compiled function." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and comp-func-callee + (comp-func-c-name comp-func-callee) (or (and (>= (comp-func-speed comp-func) 3) (comp-func-unique-in-cu-p callee)) (and (>= (comp-func-speed comp-func) 2) @@ -2365,9 +2366,7 @@ FUNCTION can be a function-name or byte compiled function." (defun comp-call-optim-func () "Perform the trampoline call optimization for the current function." (cl-loop - with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) - when self ;; FIXME add proper anonymous lambda support. do (comp-loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) From c6abe97f941a5021d416e01fb0f61a675c5f6b29 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 5 Nov 2020 22:23:48 +0100 Subject: [PATCH 1132/1452] * A native compiler forward propagation fix * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Fix `comp-mvar' `const-vld' slot left unset while propagating in phis. --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b35fe9bfcbb..51fed2ffd3b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2249,7 +2249,8 @@ Forward propagate immediate involed in assignments." (consts (mapcar #'comp-mvar-constant rest)) (x (car consts)) (equals (cl-every (lambda (y) (equal x y)) consts))) - (setf (comp-mvar-constant lval) x)) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) x)) ;; Forward type propagation. ;; FIXME: checking for type equality is not sufficient cause does not ;; account type hierarchy! From acf101c63644da5587822afbea1b186d91ff3348 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 6 Nov 2020 22:22:48 +0100 Subject: [PATCH 1133/1452] Handle type hierarchy in native compiler forward propagation 2020-11-07 Andrea Corallo * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Add fixnum and bignum. * lisp/emacs-lisp/comp.el (comp-ctxt): Add `supertype-memoize' slot. (comp-supertypes, comp-common-supertype-2) (comp-common-supertype): New functions. (comp-fwprop-insn): Make use of `comp-common-supertype' to identify the common supertype to be propagated. --- lisp/emacs-lisp/cl-preloaded.el | 3 ++- lisp/emacs-lisp/comp.el | 44 +++++++++++++++++++++++++++++---- 2 files changed, 41 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index eed43c5ed38..b5dbcbda473 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -52,7 +52,8 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. - '((integer number number-or-marker atom) + '((fixnum integer number number-or-marker atom) + (bignum integer number number-or-marker atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 51fed2ffd3b..bb32aefcad5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -278,7 +278,10 @@ This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean - :documentation "When non-nil support late load.")) + :documentation "When non-nil support late load.") + (supertype-memoize (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for + `comp-common-supertype'.")) (cl-defstruct comp-args-base (min nil :type number @@ -2124,6 +2127,40 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." 'fixnum (type-of obj))) +(defun comp-supertypes (type) + "Return a list of pairs (supertype . hierarchy-level) for TYPE." + (cl-loop + named outer + with found = nil + for l in cl--typeof-types + do (cl-loop + for x in l + for i from (length l) downto 0 + when (eq type x) + do (setf found t) + when found + collect `(,x . ,i) into res + finally (when found + (cl-return-from outer res))))) + +(defun comp-common-supertype-2 (type1 type2) + "Return the first common supertype of TYPE1 TYPE2." + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) + x + y)) + (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car)))) + +(defun comp-common-supertype (&rest types) + "Return the first common supertype of TYPES." + (or (gethash types (comp-ctxt-supertype-memoize comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-ctxt-supertype-memoize comp-ctxt)))) + (defun comp-copy-insn (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. @@ -2252,12 +2289,9 @@ Forward propagate immediate involed in assignments." (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) x)) ;; Forward type propagation. - ;; FIXME: checking for type equality is not sufficient cause does not - ;; account type hierarchy! (when-let* ((types (mapcar #'comp-mvar-type rest)) (non-empty (cl-notany #'null types)) - (x (car types)) - (eqs (cl-every (lambda (y) (eq x y)) types))) + (x (comp-common-supertype types))) (setf (comp-mvar-type lval) x))))) (defun comp-fwprop* () From 4a69e953f34d504809b94a0c4634444d34100039 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 00:13:01 +0100 Subject: [PATCH 1134/1452] Allow for native compilation qualities to be specified per input file * lisp/emacs-lisp/bytecomp.el (byte-native-qualities): Define variable. (byte-compile-from-buffer): Spill compilation qualities. * lisp/emacs-lisp/comp.el (comp-speed, comp-debug): Make them file local variables. (comp-ctxt): Add `speed' and `debug' slots. (comp-spill-speed, comp-spill-lap-function): Make use of these. (comp-spill-lap-function): Spill qualities from `byte-native-qualities'. (comp-limplify-top-level): Do not use `comp-speed' but ctxt value unstead. (comp-final): Do not propagate qualities as they are already in the `comp-ctxt'. (comp--native-compile): Close on `byte-native-qualities'. * src/comp.c (comp_t): Add 'speed' and 'debug' fields. (emit_comment, emit_mvar_rval, emit_static_object) (emit_ctxt_code, Fcomp__init_ctxt): Use these instead of the global variables. (Fcomp__compile_ctxt_to_file): Set comp.speed and comp.debug and use them. --- lisp/emacs-lisp/bytecomp.el | 7 +++++++ lisp/emacs-lisp/comp.el | 25 +++++++++++++++++-------- src/comp.c | 32 +++++++++++++++----------------- 3 files changed, 39 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a3c830e60dd..5508a60c444 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -598,6 +598,8 @@ Each element is (INDEX . VALUE)") (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 boostrap we produce both the .eln and the .elc together. @@ -2216,6 +2218,11 @@ 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)) ;; Compile the forms from the input buffer. (while (progn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bb32aefcad5..9fbf60c96c2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -51,6 +51,7 @@ - 3 max optimization level, to be used only when necessary. Warning: the compiler is free to perform dangerous optimizations." :type 'number + :safe #'numberp :group 'comp) (defcustom comp-debug 0 @@ -62,6 +63,7 @@ This intended for debugging the compiler itself. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." :type 'number + :safe #'numberp :group 'comp) (defcustom comp-verbose 0 @@ -256,6 +258,10 @@ Useful to hook into pass checkers.") "Lisp side of the compiler context." (output nil :type string :documentation "Target output file-name for the compilation.") + (speed comp-speed :type number + :documentation "Default speed for this compilation unit.") + (debug comp-debug :type number + :documentation "Default debug level for this compilation unit.") (top-level-forms () :type list :documentation "List of spilled top level forms.") (funcs-h (make-hash-table :test #'equal) :type hash-table @@ -605,7 +611,7 @@ instruction." (defun comp-spill-speed (function-name) "Return the speed for FUNCTION-NAME." (or (comp-spill-decl-spec function-name 'speed) - comp-speed)) + (comp-ctxt-speed comp-ctxt))) ;; Autoloaded as might be used by `disassemble-internal'. ;;;###autoload @@ -723,11 +729,11 @@ clashes." (make-comp-func-l :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) - :speed comp-speed) + :speed (comp-ctxt-speed comp-ctxt)) (make-comp-func-d :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) - :speed comp-speed)))) + :speed (comp-ctxt-speed comp-ctxt))))) (let ((lap (byte-to-native-lambda-lap (gethash (aref byte-code 1) byte-to-native-lambdas-h)))) @@ -798,7 +804,11 @@ clashes." filename (when byte-native-for-bootstrap (car (last comp-eln-load-path)))))) - (setf (comp-ctxt-top-level-forms comp-ctxt) + (setf (comp-ctxt-speed comp-ctxt) (alist-get 'comp-speed + byte-native-qualities) + (comp-ctxt-debug comp-ctxt) (alist-get 'comp-debug + byte-native-qualities) + (comp-ctxt-top-level-forms comp-ctxt) (cl-loop for form in (reverse byte-to-native-top-level-forms) collect @@ -1575,7 +1585,7 @@ into the C code forwarding the compilation unit." ;; the last function being ;; registered. :frame-size 2 - :speed comp-speed)) + :speed (comp-ctxt-speed comp-ctxt))) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -2670,9 +2680,7 @@ Prepare every function for final compilation and drive the C back-end." (print-circle t) (expr `(progn (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose + (setf comp-verbose ,comp-verbose comp-ctxt ,comp-ctxt comp-eln-load-path ',comp-eln-load-path comp-native-driver-options @@ -2988,6 +2996,7 @@ load once finished compiling." (list "Not a function symbol or file" function-or-file))) (let* ((data function-or-file) (comp-native-compiling t) + (byte-native-qualities nil) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output diff --git a/src/comp.c b/src/comp.c index 48e4f1c8cde..05ec073c1fd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -423,10 +423,6 @@ load_gccjit_if_necessary (bool mandatory) #define TEXT_OPTIM_QLY_SYM "text_optim_qly" #define TEXT_FDOC_SYM "text_data_fdoc" - -#define COMP_SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) -#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) - #define STR_VALUE(s) #s #define STR(s) STR_VALUE (s) @@ -485,6 +481,8 @@ enum cast_kind_of_type /* C side of the compiler context. */ typedef struct { + EMACS_INT speed; + EMACS_INT debug; gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *bool_type; @@ -916,7 +914,7 @@ obj_to_reloc (Lisp_Object obj) static void emit_comment (const char *str) { - if (COMP_DEBUG) + if (comp.debug) gcc_jit_block_add_comment (comp.block, NULL, str); @@ -1847,7 +1845,7 @@ emit_mvar_rval (Lisp_Object mvar) if (!NILP (const_vld)) { - if (COMP_DEBUG > 1) + if (comp.debug > 1) { Lisp_Object func = Fgethash (constant, @@ -2566,7 +2564,7 @@ emit_static_object (const char *name, Lisp_Object obj) 0, NULL, 0); DECL_BLOCK (block, f); - if (COMP_DEBUG > 1) + if (comp.debug > 1) { char *comment = memcpy (xmalloc (len), p, len); for (ptrdiff_t i = 0; i < len - 1; i++) @@ -2789,10 +2787,8 @@ emit_ctxt_code (void) { /* Emit optimize qualities. */ Lisp_Object opt_qly[] = - { Fcons (Qcomp_speed, - Fsymbol_value (Qcomp_speed)), - Fcons (Qcomp_debug, - Fsymbol_value (Qcomp_debug)), + { Fcons (Qcomp_speed, make_fixnum (comp.speed)), + Fcons (Qcomp_debug, make_fixnum (comp.debug)), Fcons (Qgccjit, Fcomp_libgccjit_version ()) }; emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly)); @@ -4212,13 +4208,13 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.ctxt = gcc_jit_context_acquire (); - if (COMP_DEBUG) + if (comp.debug) { gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); } - if (COMP_DEBUG > 2) + if (comp.debug > 2) { logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, @@ -4403,10 +4399,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CHECK_STRING (filename); Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); + comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - COMP_SPEED < 0 ? 0 - : (COMP_SPEED > 3 ? 3 : COMP_SPEED)); + comp.speed < 0 ? 0 + : (comp.speed > 3 ? 3 : comp.speed)); comp.d_default_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); comp.d_impure_idx = @@ -4456,11 +4454,11 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, add_driver_options (); - if (COMP_DEBUG) + if (comp.debug) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (base_name)), 1); - if (COMP_DEBUG > 2) + if (comp.debug > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); Lisp_Object tmp_file = From 6c271ffaa808c602e177db4bd2297ff81112147e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 12:31:37 +0100 Subject: [PATCH 1135/1452] * Fix non native compiled build * lisp/emacs-lisp/advice.el (ad-add-advice): Do not try to install trampolines in vanilla builds. --- lisp/emacs-lisp/advice.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 509e2551914..086aa98bb0b 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2077,7 +2077,8 @@ 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 (subr-primitive-p (symbol-function function)) + (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) From 04a073f4bf1cc31a3a2606468b0e017b69d7ff39 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 16:03:14 +0100 Subject: [PATCH 1136/1452] * Allow for manually bumbing new native compiler ABI versions * src/comp.c (ABI_VERSION): Define macro. (hash_native_abi): Include ABI_VERSION in the hashing. (syms_of_comp): Tweak docstring. --- src/comp.c | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 05ec073c1fd..cb5f1a1ce96 100644 --- a/src/comp.c +++ b/src/comp.c @@ -406,6 +406,9 @@ load_gccjit_if_necessary (bool mandatory) } +/* Increase this number to force a new Vcomp_abi_hash to be generated. */ +#define ABI_VERSION "0" + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -778,8 +781,10 @@ hash_native_abi (void) eassert (NILP (Vcomp_abi_hash)); Vcomp_abi_hash = - comp_hash_string (Fmapconcat (intern_c_string ("subr-name"), - Vcomp_subr_list, build_string (""))); + comp_hash_string ( + concat2 (build_string (ABI_VERSION), + Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string ("")))); Lisp_Object separator = build_string ("-"); Vcomp_native_version_dir = concat3 (Vemacs_version, @@ -5262,7 +5267,7 @@ native compiled one. */); DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, - doc: /* String signing the ABI exposed to .eln files. */); + doc: /* String signing the .eln files ABI. */); Vcomp_abi_hash = Qnil; DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir, doc: /* Directory in use to disambiguate eln compatibility. */); From a5408d5715de5ee9b6858c6eb0638043f4cdb136 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 21:00:14 +0100 Subject: [PATCH 1137/1452] * lisp/emacs-lisp/comp.el (comp-common-supertype-2): Fix null intersection --- lisp/emacs-lisp/comp.el | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9fbf60c96c2..c837e020603 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2155,14 +2155,13 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (defun comp-common-supertype-2 (type1 type2) "Return the first common supertype of TYPE1 TYPE2." - (car (cl-reduce (lambda (x y) - (if (> (cdr x) (cdr y)) - x - y)) - (cl-intersection - (comp-supertypes type1) - (comp-supertypes type2) - :key #'car)))) + (when-let ((types (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car))) + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) x y)) + types)))) (defun comp-common-supertype (&rest types) "Return the first common supertype of TYPES." From e20cdf937e74ebcaa2c6dabb63be1c20a6ea44f6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Nov 2020 20:45:43 +0100 Subject: [PATCH 1138/1452] * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Fix phi function. --- lisp/emacs-lisp/comp.el | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c837e020603..887a6a503ec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2289,19 +2289,20 @@ Forward propagate immediate involed in assignments." (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v (comp-mvar-type lval) (comp-strict-type-of v))) - (`(phi (,lval . _) . ,rest) - ;; Forward const prop here. - (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) - (consts (mapcar #'comp-mvar-constant rest)) - (x (car consts)) - (equals (cl-every (lambda (y) (equal x y)) consts))) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) x)) - ;; Forward type propagation. - (when-let* ((types (mapcar #'comp-mvar-type rest)) - (non-empty (cl-notany #'null types)) - (x (comp-common-supertype types))) - (setf (comp-mvar-type lval) x))))) + (`(phi ,lval . ,rest) + (let ((rvals (mapcar #'car rest))) + ;; Forward const prop here. + (when-let* ((vld (cl-every #'comp-mvar-const-vld rvals)) + (consts (mapcar #'comp-mvar-constant rvals)) + (x (car consts)) + (equals (cl-every (lambda (y) (equal x y)) consts))) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) x)) + ;; Forward type propagation. + (when-let* ((types (mapcar #'comp-mvar-type rvals)) + (non-empty (cl-notany #'null types)) + (x (comp-common-supertype types))) + (setf (comp-mvar-type lval) x)))))) (defun comp-fwprop* () "Propagate for set* and phi operands. From c3d0e2a09fd72aa9209dda3057bbb02f6a3b3df6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Nov 2020 10:40:05 +0100 Subject: [PATCH 1139/1452] * Rename two nativecomp functions * lisp/emacs-lisp/comp.el (comp-function-foldable-p): Rename from comp-function-optimizable-p. (comp-function-call-maybe-fold): Same from comp-function-call-maybe-fold. --- lisp/emacs-lisp/comp.el | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 887a6a503ec..8bee8afeacf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2223,12 +2223,12 @@ Forward propagate immediate involed in assignments." (comp-mvar-constant lval) (comp-mvar-constant rval) (comp-mvar-type lval) (comp-mvar-type rval))) -(defsubst comp-function-optimizable-p (f args) +(defsubst comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." (and (cl-every #'comp-mvar-const-vld args) (comp-function-pure-p f))) -(defsubst comp-function-call-maybe-remove (insn f args) +(defsubst comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. @@ -2243,7 +2243,7 @@ Forward propagate immediate involed in assignments." comp-symbol-values-optimizable))) (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant (car args)))))) - ((comp-function-optimizable-p f args) + ((comp-function-foldable-p f args) (ignore-errors ;; No point to complain here in case of error because we ;; should do basic block pruning in order to be sure that this @@ -2265,12 +2265,12 @@ Forward propagate immediate involed in assignments." (`(,(or 'call 'callref) ,f . ,args) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-maybe-remove insn f args)) + (comp-function-call-maybe-fold insn f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-maybe-remove insn f args))) + (comp-function-call-maybe-fold insn f args))) (_ (comp-mvar-propagate lval rval)))) (`(assume ,lval ,rval ,kind) From e96cd4e82c9aca01f136ccdd7a3b0fbf2db01e50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 21:47:30 +0100 Subject: [PATCH 1140/1452] Add initial nativecomp typeset and range propagation support This commit add an initial support for a better type propagation and integer range propagation. Each mvar can be now characterized by a set of types, a set of values and an integral range. * lisp/emacs-lisp/comp.el (comp-known-ret-types): Store into typeset and remove fixnum. (comp-known-ret-ranges, comp-type-predicates): New variables. (comp-ctxt): Remove supertype-memoize slot and add union-typesets-mem. (comp-mvar): Remove const-vld, constant, type slots. Add typeset, valset, range slots. (comp-mvar-value-vld-p, comp-mvar-value, comp-mvar-fixnum-p) (comp-mvar-symbol-p, comp-mvar-cons-p) (comp-mvar-type-hint-match-p, comp-func-ret-typeset) (comp-func-ret-range): New functions. (make-comp-mvar, make-comp-ssa-mvar): Update logic. (comp--typeof-types): New variable. (comp-supertypes, comp-common-supertype): Logic update. (comp-subtype-p, comp-union-typesets, comp-range-1+) (comp-range-1-, comp-range-<, comp-range-union) (comp-range-intersection): New functions. (comp-fwprop-prologue, comp-mvar-propagate) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-fwprop-insn, comp-call-optim-func, comp-finalize-relocs): Logic update. * src/comp.c (emit_mvar_rval, emit_call_with_type_hint) (emit_call2_with_type_hint): Logic update. * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Undo the add of fixnum and bignum as unnecessary. * test/src/comp-tests.el (comp-tests-mentioned-p-1, comp-tests-cond-rw-checker-val) (comp-tests-cond-rw-checker-type, cond-rw-1, cond-rw-2) (cond-rw-3, cond-rw-4, cond-rw-5): Update for new type interface. (range-simple-union, range-simple-intersection): New integer range tests. (union-types): New union type test. --- lisp/emacs-lisp/cl-preloaded.el | 3 +- lisp/emacs-lisp/comp.el | 350 ++++++++++++++++++++++++-------- src/comp.c | 24 ++- test/src/comp-tests.el | 82 ++++++-- 4 files changed, 347 insertions(+), 112 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index b5dbcbda473..eed43c5ed38 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -52,8 +52,7 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. - '((fixnum integer number number-or-marker atom) - (bignum integer number number-or-marker atom) + '((integer number number-or-marker atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8bee8afeacf..ad0ac21389e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,19 +191,31 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -(defconst comp-known-ret-types '((cons . cons) - (1+ . number) - (1- . number) - (+ . number) - (- . number) - (* . number) - (/ . number) - (% . number) +(defconst comp-known-ret-types '((cons . (cons)) + (1+ . (number)) + (1- . (number)) + (+ . (number)) + (- . (number)) + (* . (number)) + (/ . (number)) + (% . (number)) ;; Type hints - (comp-hint-fixnum . fixnum) - (comp-hint-cons . cons)) + (comp-hint-cons . (cons))) "Alist used for type propagation.") +(defconst comp-known-ret-ranges + `((comp-hint-fixnum . (,most-negative-fixnum . ,most-positive-fixnum))) + "Known returned ranges.") + +;; TODO fill it. +(defconst comp-type-predicates '((cons . consp) + (float . floatp) + (integer . integerp) + (number . numberp) + (string . stringp) + (symbol . symbolp)) + "Alist type -> predicate.") + (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -285,9 +297,9 @@ This is tipically for top-level forms other than defun.") :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean :documentation "When non-nil support late load.") - (supertype-memoize (make-hash-table :test #'equal) :type hash-table - :documentation "Serve memoization for - `comp-common-supertype'.")) + (union-typesets-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-union-typesets'.")) (cl-defstruct comp-args-base (min nil :type number @@ -419,14 +431,68 @@ CFG is mutated by a pass.") (slot nil :type (or fixnum symbol) :documentation "Slot number in the array if a number or 'scratch' for scratch slot.") - (const-vld nil :type boolean - :documentation "Valid signal for the following slot.") - (constant nil - :documentation "When const-vld non-nil this is used for holding - a value known at compile time.") - (type nil :type symbol - :documentation "When non-nil indicates the type when known at compile - time.")) + (typeset '(t) :type list + :documentation "List of possible types the mvar can assume. +Each element cannot be a subtype of any other element of this slot.") + (valset '() :type list + :documentation "List of possible values the mvar can assume. +Interg values are handled in the `range' slot.") + (range '() :type list + :documentation "Integer interval.")) + +(defsubst comp-mvar-value-vld-p (mvar) + "Return t if one single value can be extracted by the MVAR constrains." + (or (= (length (comp-mvar-valset mvar)) 1) + (let ((r (comp-mvar-range mvar))) + (and (= (length r) 1) + (let ((low (caar r)) + (high (cdar r))) + (and + (integerp low) + (integerp high) + (= low high))))))) + +(defsubst comp-mvar-value (mvar) + "Return the constant value of MVAR. +`comp-mvar-value-vld-p' *must* be satisfied before calling +`comp-mvar-const'." + (declare (gv-setter + (lambda (val) + `(if (integerp ,val) + (setf (comp-mvar-typeset ,mvar) nil + (comp-mvar-range ,mvar) (list (cons ,val ,val))) + (setf (comp-mvar-typeset ,mvar) nil + (comp-mvar-valset ,mvar) (list ,val)))))) + (let ((v (comp-mvar-valset mvar))) + (if (= (length v) 1) + (car v) + (caar (comp-mvar-range mvar))))) + +(defsubst comp-mvar-fixnum-p (mvar) + "Return t if MVAR is certainly a fixnum." + (when-let (range (comp-mvar-range mvar)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t)))) + +(defsubst comp-mvar-symbol-p (mvar) + "Return t if MVAR is certainly a symbol." + (equal (comp-mvar-typeset mvar) '(symbol))) + +(defsubst comp-mvar-cons-p (mvar) + "Return t if MVAR is certainly a cons." + (equal (comp-mvar-typeset mvar) '(cons))) + +(defun comp-mvar-type-hint-match-p (mvar type-hint) + "Match MVAR against TYPE-HINT. +In use by the backend." + (cl-ecase type-hint + (cons (comp-mvar-cons-p mvar)) + (fixnum (comp-mvar-fixnum-p mvar)))) ;; Special vars used by some passes (defvar comp-func) @@ -463,6 +529,14 @@ To be used by all entry points." "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) +(defsubst comp-func-ret-typeset (func) + "Return the typeset returned by function FUNC. " + (or (alist-get func comp-known-ret-types) '(t))) + +(defsubst comp-func-ret-range (func) + "Return the range returned by function FUNC. " + (alist-get func comp-known-ret-ranges)) + (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) @@ -943,10 +1017,14 @@ STACK-OFF is the index of the first slot frame involved." collect (comp-slot-n sp)))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) - (when const-vld - (comp-add-const-to-relocs constant)) - (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type)) + "`comp-mvar' intitializer." + (let ((mvar (make--comp-mvar :slot slot))) + (when const-vld + (comp-add-const-to-relocs constant) + (setf (comp-mvar-value mvar) constant)) + (when type + (setf (comp-mvar-typeset mvar) (list type))) + mvar)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1823,11 +1901,9 @@ blocks." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) - (let ((mvar (make--comp-mvar :slot slot - :const-vld const-vld - :constant constant - :type type))) +(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type) + "Same as `make-comp-mvar' but set the `id' slot." + (let ((mvar (apply #'make-comp-mvar rest))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) @@ -2130,19 +2206,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defsubst comp-strict-type-of (obj) - "Given OBJ return its type understanding fixnums." - ;; Should be certainly smarter but now we take advantages just from fixnums. - (if (fixnump obj) - 'fixnum - (type-of obj))) +(defconst comp--typeof-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) + ;; TODO can we just add t in `cl--typeof-types'? + "Like `cl--typeof-types' but with t as common supertype.") (defun comp-supertypes (type) "Return a list of pairs (supertype . hierarchy-level) for TYPE." (cl-loop named outer with found = nil - for l in cl--typeof-types + for l in comp--typeof-types do (cl-loop for x in l for i from (length l) downto 0 @@ -2165,10 +2240,105 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (defun comp-common-supertype (&rest types) "Return the first common supertype of TYPES." - (or (gethash types (comp-ctxt-supertype-memoize comp-ctxt)) - (puthash types - (cl-reduce #'comp-common-supertype-2 types) - (comp-ctxt-supertype-memoize comp-ctxt)))) + (cl-reduce #'comp-common-supertype-2 types)) + +(defsubst comp-subtype-p (type1 type2) + "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise." + (eq (comp-common-supertype-2 type1 type2) type2)) + +(defun comp-union-typesets (&rest typesets) + "Union types present into TYPESETS." + (or (gethash typesets (comp-ctxt-union-typesets-mem comp-ctxt)) + (puthash typesets + (cl-loop + with types = (apply #'append typesets) + with res = '() + for lane in comp--typeof-types + do (cl-loop + with last = nil + for x in lane + when (memq x types) + do (setf last x) + finally (when last + (push last res))) + finally (cl-return (cl-remove-duplicates res))) + (comp-ctxt-union-typesets-mem comp-ctxt)))) + +(defsubst comp-range-1+ (x) + (if (symbolp x) + x + (1+ x))) + +(defsubst comp-range-1- (x) + (if (symbolp x) + x + (1- x))) + +(defsubst comp-range-< (x y) + (cond + ((eq x '+) nil) + ((eq x '-) t) + ((eq y '+) t) + ((eq y '-) nil) + (t (< x y)))) + +(defun comp-range-union (&rest ranges) + "Combine integer intervals RANGES by union operation." + (cl-loop + with all-ranges = (apply #'append ranges) + with lows = (mapcar (lambda (x) + (cons (comp-range-1- (car x)) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (when (zerop nest) + (setf low i)) + (cl-incf nest) + else + do + (when (= nest 1) + (push `(,(comp-range-1+ low) . ,i) res)) + (cl-decf nest) + finally (cl-return (reverse res)))) + +(defun comp-range-intersection (&rest ranges) + "Combine integer intervals RANGES by intersecting." + (cl-loop + with all-ranges = (apply #'append ranges) + with n-ranges = (length ranges) + with lows = (mapcar (lambda (x) + (cons (car x) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + initially (when (cl-some #'null ranges) + ;; Intersecting with a null range always results in a + ;; null range. + (cl-return '())) + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (cl-incf nest) + (when (= nest n-ranges) + (setf low i)) + else + do + (when (= nest n-ranges) + (push `(,low . ,i) + res)) + (cl-decf nest) + finally (cl-return (reverse res)))) (defun comp-copy-insn (insn) "Deep copy INSN." @@ -2213,20 +2383,18 @@ Forward propagate immediate involed in assignments." for insn in (comp-block-insns b) do (pcase insn (`(setimm ,lval ,v) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) v - (comp-mvar-type lval) (comp-strict-type-of v))))))) + (setf (comp-mvar-value lval) v)))))) (defsubst comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval) - (comp-mvar-constant lval) (comp-mvar-constant rval) - (comp-mvar-type lval) (comp-mvar-type rval))) + (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) + (comp-mvar-valset lval) (comp-mvar-valset rval) + (comp-mvar-range lval) (comp-mvar-range rval))) (defsubst comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." - (and (cl-every #'comp-mvar-const-vld args) - (comp-function-pure-p f))) + (and (comp-function-pure-p f) + (cl-every #'comp-mvar-value-vld-p args))) (defsubst comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." @@ -2238,10 +2406,10 @@ Forward propagate immediate involed in assignments." (cond ((eq f 'symbol-value) (when-let* ((arg0 (car args)) - (const (comp-mvar-const-vld arg0)) - (ok-to-optim (member (comp-mvar-constant arg0) + (const (comp-mvar-value-vld-p arg0)) + (ok-to-optim (member (comp-mvar-value arg0) comp-symbol-values-optimizable))) - (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant + (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-value (car args)))))) ((comp-function-foldable-p f args) (ignore-errors @@ -2254,7 +2422,7 @@ Forward propagate immediate involed in assignments." ;; and know to be pure. (comp-func-byte-func f-in-ctxt) f)) - (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args)))) + (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) (rewrite-insn-as-setimm insn value))))))) (defun comp-fwprop-insn (insn) @@ -2263,13 +2431,19 @@ Forward propagate immediate involed in assignments." (`(set ,lval ,rval) (pcase rval (`(,(or 'call 'callref) ,f . ,args) - (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types)) + (if-let ((range (comp-func-ret-range f))) + (setf (comp-mvar-range lval) (list range) + (comp-mvar-typeset lval) nil) + (setf (comp-mvar-typeset lval) + (comp-func-ret-typeset f))) (comp-function-call-maybe-fold insn f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) - (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types)) + (if-let ((range (comp-func-ret-range f))) + (setf (comp-mvar-range lval) (list range) + (comp-mvar-typeset lval) nil) + (setf (comp-mvar-typeset lval) + (comp-func-ret-typeset f))) (comp-function-call-maybe-fold insn f args))) (_ (comp-mvar-propagate lval rval)))) @@ -2278,31 +2452,46 @@ Forward propagate immediate involed in assignments." ('eq (comp-mvar-propagate lval rval)) ((or 'eql 'equal) - (if (memq (comp-mvar-type rval) '(symbol fixnum)) + (if (or (comp-mvar-symbol-p rval) + (comp-mvar-fixnum-p rval)) (comp-mvar-propagate lval rval) - (setf (comp-mvar-type lval) (comp-mvar-type rval)))) + (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)))) ('= - (if (eq (comp-mvar-type rval) 'fixnum) + (if (comp-mvar-fixnum-p rval) (comp-mvar-propagate lval rval) - (setf (comp-mvar-type lval) 'number))))) + (setf (comp-mvar-typeset lval) + (unless (comp-mvar-range rval) + '(number))))))) (`(setimm ,lval ,v) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) v - (comp-mvar-type lval) (comp-strict-type-of v))) + (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) - (let ((rvals (mapcar #'car rest))) - ;; Forward const prop here. - (when-let* ((vld (cl-every #'comp-mvar-const-vld rvals)) - (consts (mapcar #'comp-mvar-constant rvals)) - (x (car consts)) - (equals (cl-every (lambda (y) (equal x y)) consts))) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) x)) - ;; Forward type propagation. - (when-let* ((types (mapcar #'comp-mvar-type rvals)) - (non-empty (cl-notany #'null types)) - (x (comp-common-supertype types))) - (setf (comp-mvar-type lval) x)))))) + (let* ((rvals (mapcar #'car rest)) + (values (mapcar #'comp-mvar-valset rvals)) + (from-latch (cl-some + (lambda (x) + (comp-latch-p + (gethash (cdr x) + (comp-func-blocks comp-func)))) + rest))) + + ;; Type propagation. + (setf (comp-mvar-typeset lval) + (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rvals))) + ;; Value propagation. + (setf (comp-mvar-valset lval) + (when (cl-every #'consp values) + ;; TODO memoize? + (cl-remove-duplicates (apply #'append values) + :test #'equal))) + ;; Range propagation + (setf (comp-mvar-range lval) + (when (and (not from-latch) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-mvar-typeset lval))) + ;; TODO memoize? + (apply #'comp-range-union + (mapcar #'comp-mvar-range rvals)))))))) (defun comp-fwprop* () "Propagate for set* and phi operands. @@ -2416,11 +2605,11 @@ FUNCTION can be a function-name or byte compiled function." (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) + (comp-mvar-value f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) + (comp-mvar-value f) rest))) (setf insn new-form))))))) (defun comp-call-optim (_) @@ -2639,7 +2828,8 @@ Update all insn accordingly." do (cl-assert (null (gethash idx reverse-h))) (cl-assert (fixnump idx)) - (setf (comp-mvar-constant mvar) idx) + (setf (comp-mvar-valset mvar) () + (comp-mvar-range mvar) (list (cons idx idx))) (puthash idx t reverse-h)))) (defun comp-compile-ctxt-to-file (name) diff --git a/src/comp.c b/src/comp.c index cb5f1a1ce96..0d464281858 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1845,32 +1845,32 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_rval (Lisp_Object mvar) { - Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); - Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); + Lisp_Object const_vld = CALL1I (comp-mvar-value-vld-p, mvar); if (!NILP (const_vld)) { + Lisp_Object value = CALL1I (comp-mvar-value, mvar); if (comp.debug > 1) { Lisp_Object func = - Fgethash (constant, + Fgethash (value, CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), Qnil); emit_comment ( SSDATA ( Fprin1_to_string ( - NILP (func) ? constant : CALL1I (comp-func-c-name, func), + NILP (func) ? value : CALL1I (comp-func-c-name, func), Qnil))); } - if (FIXNUMP (constant)) + if (FIXNUMP (value)) { /* We can still emit directly objects that are self-contained in a word (read fixnums). */ - return emit_rvalue_from_lisp_obj (constant); + return emit_rvalue_from_lisp_obj (value); } /* Other const objects are fetched from the reloc array. */ - return emit_lisp_obj_rval (constant); + return emit_lisp_obj_rval (value); } return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); @@ -2371,12 +2371,13 @@ static gcc_jit_rvalue * emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + bool hint_match = + !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type)); gcc_jit_rvalue *args[] = { emit_mvar_rval (SECOND (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, - type_hint) }; + hint_match) }; return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); } @@ -2386,13 +2387,14 @@ static gcc_jit_rvalue * emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + bool hint_match = + !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type)); gcc_jit_rvalue *args[] = { emit_mvar_rval (SECOND (insn)), emit_mvar_rval (THIRD (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, - type_hint) }; + hint_match) }; return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args); } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 21c8abad038..48687d92021 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -37,7 +37,7 @@ (defconst comp-test-dyn-src (concat comp-test-directory "comp-test-funcs-dyn.el")) -(when (boundp 'comp-ctxt) +(when (featurep 'nativecomp) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) @@ -676,8 +676,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (cl-loop for y in insn when (cond ((consp y) (comp-tests-mentioned-p x y)) - ((and (comp-mvar-p y) (comp-mvar-const-vld y)) - (equal (comp-mvar-constant y) x)) + ((and (comp-mvar-p y) (comp-mvar-value-vld-p y)) + (equal (comp-mvar-value y) x)) (t (equal x y))) return t)) @@ -804,8 +804,8 @@ Return a list of results." (lambda (insn) (pcase insn (`(return ,mvar) - (and (comp-mvar-const-vld mvar) - (= (comp-mvar-constant mvar) 123))))))))) + (and (comp-mvar-value-vld-p mvar) + (eql (comp-mvar-value mvar) 123))))))))) (defvar comp-tests-cond-rw-expected-type nil "Type to expect in `comp-tests-cond-rw-checker-type'.") @@ -819,7 +819,8 @@ Return a list of results." (lambda (insn) (pcase insn (`(return ,mvar) - (eq (comp-mvar-type mvar) comp-tests-cond-rw-expected-type)))))))) + (equal (comp-mvar-typeset mvar) + comp-tests-cond-rw-expected-type)))))))) (defvar comp-tests-cond-rw-0-var) (comp-deftest cond-rw-0 () @@ -839,40 +840,39 @@ Return a list of results." (comp-deftest cond-rw-1 () "Test cond-rw pass allow us to propagate type+val under `eq' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'fixnum) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) - (comp-final comp-tests-cond-rw-checker-val)))) + (comp-tests-cond-rw-expected-type '(integer)) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type + comp-tests-cond-rw-checker-val)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t)))))) (comp-deftest cond-rw-2 () "Test cond-rw pass allow us to propagate type+val under `=' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'fixnum) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) - (comp-final comp-tests-cond-rw-checker-val)))) + (comp-tests-cond-rw-expected-type '(integer)) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type + comp-tests-cond-rw-checker-val)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t)))))) (comp-deftest cond-rw-3 () "Test cond-rw pass allow us to propagate type+val under `eql' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'fixnum) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) - (comp-final comp-tests-cond-rw-checker-val)))) + (comp-tests-cond-rw-expected-type '(integer)) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type + comp-tests-cond-rw-checker-val)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t)))))) (comp-deftest cond-rw-4 () "Test cond-rw pass allow us to propagate type under `=' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'number) + (comp-tests-cond-rw-expected-type '(number)) (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t)))))) (comp-deftest cond-rw-5 () "Test cond-rw pass allow us to propagate type under `=' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) - (comp-tests-cond-rw-expected-type 'fixnum) + (let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) + (comp-tests-cond-rw-expected-type '(integer)) (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) (eval '(defun comp-tests-cond-rw-4-f (x y) (declare (speed 3)) @@ -883,4 +883,48 @@ Return a list of results." (native-compile #'comp-tests-cond-rw-4-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Range propagation tests. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(comp-deftest range-simple-union () + (should (equal (comp-range-union '((-1 . 0)) '((3 . 4))) + '((-1 . 0) (3 . 4)))) + (should (equal (comp-range-union '((-1 . 2)) '((3 . 4))) + '((-1 . 4)))) + (should (equal (comp-range-union '((-1 . 3)) '((3 . 4))) + '((-1 . 4)))) + (should (equal (comp-range-union '((-1 . 4)) '((3 . 4))) + '((-1 . 4)))) + (should (equal (comp-range-union '((-1 . 5)) '((3 . 4))) + '((-1 . 5)))) + (should (equal (comp-range-union '((-1 . 0)) '()) + '((-1 . 0))))) + +(comp-deftest range-simple-intersection () + (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) + '())) + (should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4))) + '())) + (should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4))) + '((3 . 3)))) + (should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4))) + '((3 . 4)))) + (should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4))) + '((3 . 4)))) + (should (equal (comp-range-intersection '((-1 . 0)) '()) + '()))) + +(comp-deftest union-types () + (let ((comp-ctxt (make-comp-ctxt))) + (should (equal (comp-union-typesets '(integer) '(number)) + '(number))) + (should (equal (comp-union-typesets '(integer symbol) '(number)) + '(symbol number))) + (should (equal (comp-union-typesets '(integer symbol) '(number list)) + '(list symbol number))) + (should (equal (comp-union-typesets '(integer symbol) '()) + '(symbol integer))))) + ;;; comp-tests.el ends here From 175efec0732fc7317a444a2005f7b968a972b8e6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Nov 2020 16:17:03 +0100 Subject: [PATCH 1141/1452] Add a nativecomp testcase Having this while re-debugging the boostrap would have saved few hours of debug so let's add it. * test/src/comp-tests.el (and-3): Add test. * test/src/comp-test-funcs.el (comp-test-and-3-var): New var. (comp-test-and-3-f): New function. --- test/src/comp-test-funcs.el | 6 ++++++ test/src/comp-tests.el | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 35df46a9b84..1b0f3056b98 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -348,6 +348,12 @@ (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)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 48687d92021..8bedad5db73 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -440,6 +440,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." '(lambda () (delete-region (point-min) (point-max)))))))) +(comp-deftest and-3 () + (should (= (comp-test-and-3-f t) 2)) + (should (null (comp-test-and-3-f '(1 2))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 00b4e0a9bb0aa6fc6af997eeeff109cb263eddcf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 8 Nov 2020 12:16:34 +0100 Subject: [PATCH 1142/1452] * Fix limple-mode for new type and range limple semantic * lisp/emacs-lisp/comp.el (comp-limple-branches, comp-limple-ops): New variables. (comp-limple-lock-keywords): Update value. --- lisp/emacs-lisp/comp.el | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ad0ac21389e..055adcc4973 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -242,6 +242,15 @@ Useful to hook into pass checkers.") direct-callref) "Limple operators use to call subrs.") +(defconst comp-limple-branches '(jump cond-jump) + "Limple operators use for conditional and unconditional branches.") + +(defconst comp-limple-ops `(,@comp-limple-calls + ,@comp-limple-assignments + ,@comp-limple-branches + return) + "All limple operators.") + (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" 'native-compiler-error) @@ -584,7 +593,8 @@ Assume allocation class 'd-default as default." (seq (or "entry_" "entry_fallback_" "bb_") (1+ num) (? "_latch"))))) (1 font-lock-constant-face)) - (,(rx "(" (group-n 1 (1+ (or word "-")))) + (,(rx-to-string + `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) (1 font-lock-keyword-face))) "Highlights used by comp-limple-mode.") From a214882354c7b0f4842698b5a1a65db6806853a2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 10 Nov 2020 18:58:56 +0100 Subject: [PATCH 1143/1452] * Add to elisp-mode `emacs-lisp-native-compile-and-load' * lisp/progmodes/elisp-mode.el (emacs-lisp--before-compile-buffer): New function. (emacs-lisp-byte-compile-and-load): Use the previous. (emacs-lisp-native-compile-and-load): New function. --- lisp/progmodes/elisp-mode.el | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 12788eacf1b..dac3aaf2a53 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -186,19 +186,34 @@ 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) +(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) + (emacs-lisp--before-compile-buffer) + (require 'bytecomp) (byte-recompile-file buffer-file-name nil 0) (load buffer-file-name)) +(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) + (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." From 6b7c257e0bab055ab62ff15fb3d1e5fe352bc816 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Nov 2020 15:54:58 +0100 Subject: [PATCH 1144/1452] * Unline some functions to optimize bootstrap time * lisp/emacs-lisp/comp.el (comp-mvar-value-vld-p) (comp-mvar-value, comp-mvar-fixnum-p, comp-set-op-p) (comp-assign-op-p, comp-call-op-p, comp-type-hint-p) (comp-func-ret-typeset, comp-function-pure-p) (comp-alloc-class-to-container, comp-lex-byte-func-p) (comp-lap-eob-p, comp-lap-fall-through-p, comp-emit) (comp-emit-set-call, comp-mvar-propagate) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-trampoline-filename): Uninline functions. --- lisp/emacs-lisp/comp.el | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 055adcc4973..e026d3b6adb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -449,7 +449,7 @@ Interg values are handled in the `range' slot.") (range '() :type list :documentation "Integer interval.")) -(defsubst comp-mvar-value-vld-p (mvar) +(defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." (or (= (length (comp-mvar-valset mvar)) 1) (let ((r (comp-mvar-range mvar))) @@ -461,7 +461,7 @@ Interg values are handled in the `range' slot.") (integerp high) (= low high))))))) -(defsubst comp-mvar-value (mvar) +(defun comp-mvar-value (mvar) "Return the constant value of MVAR. `comp-mvar-value-vld-p' *must* be satisfied before calling `comp-mvar-const'." @@ -477,7 +477,7 @@ Interg values are handled in the `range' slot.") (car v) (caar (comp-mvar-range mvar))))) -(defsubst comp-mvar-fixnum-p (mvar) +(defun comp-mvar-fixnum-p (mvar) "Return t if MVAR is certainly a fixnum." (when-let (range (comp-mvar-range mvar)) (let* ((low (caar range)) @@ -518,15 +518,15 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) -(defsubst comp-set-op-p (op) +(defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) -(defsubst comp-assign-op-p (op) +(defun comp-assign-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) -(defsubst comp-call-op-p (op) +(defun comp-call-op-p (op) "Call predicate for OP." (when (memq op comp-limple-calls) t)) @@ -534,11 +534,11 @@ To be used by all entry points." "Limple INSN call predicate." (comp-call-op-p (car-safe insn))) -(defsubst comp-type-hint-p (func) +(defun comp-type-hint-p (func) "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defsubst comp-func-ret-typeset (func) +(defun comp-func-ret-typeset (func) "Return the typeset returned by function FUNC. " (or (alist-get func comp-known-ret-types) '(t))) @@ -564,13 +564,13 @@ To be used by all entry points." comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt))) -(defsubst comp-function-pure-p (f) +(defun comp-function-pure-p (f) "Return t if F is pure." (or (get f 'pure) (when-let ((func (comp-symbol-func-to-fun f))) (comp-func-pure func)))) -(defsubst comp-alloc-class-to-container (alloc-class) +(defun comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. Assume allocation class 'd-default as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) @@ -682,7 +682,7 @@ instruction." ;;; spill-lap pass specific code. -(defsubst comp-lex-byte-func-p (f) +(defun comp-lex-byte-func-p (f) "Return t if F is a lexically-scoped byte compiled function." (and (byte-code-function-p f) (fixnump (aref f 0)))) @@ -945,12 +945,12 @@ Points to the next slot to be filled.") byte-switch byte-pushconditioncase) "LAP end of basic blocks op codes.") -(defsubst comp-lap-eob-p (inst) +(defun comp-lap-eob-p (inst) "Return t if INST closes the current basic blocks, nil otherwise." (when (memq (car inst) comp-lap-eob-ops) t)) -(defsubst comp-lap-fall-through-p (inst) +(defun comp-lap-fall-through-p (inst) "Return t if INST fall through, nil otherwise." (when (not (memq (car inst) '(byte-goto byte-return))) t)) @@ -1047,13 +1047,13 @@ If SSA non-nil populate it of m-var in ssa form." do (aset v i mvar) finally return v)) -(defsubst comp-emit (insn) +(defun comp-emit (insn) "Emit INSN into basic block BB." (let ((bb (comp-limplify-curr-block comp-pass))) (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) -(defsubst comp-emit-set-call (call) +(defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." (cl-assert call) @@ -2395,18 +2395,18 @@ Forward propagate immediate involed in assignments." (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)))))) -(defsubst comp-mvar-propagate (lval rval) +(defun comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) (comp-mvar-valset lval) (comp-mvar-valset rval) (comp-mvar-range lval) (comp-mvar-range rval))) -(defsubst comp-function-foldable-p (f args) +(defun comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." (and (comp-function-pure-p f) (cl-every #'comp-mvar-value-vld-p args))) -(defsubst comp-function-call-maybe-fold (insn f args) +(defun comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. @@ -2925,7 +2925,7 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive funciton advice machinery -(defsubst comp-trampoline-filename (subr-name) +(defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) From 93a80a4fae2b90471a3a3cf4f17751ce48f4af2f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Nov 2020 17:23:25 +0100 Subject: [PATCH 1145/1452] * Add nativecomp derived return type specifier computation support * lisp/emacs-lisp/comp.el (comp-post-pass-hooks): Nit. (comp-func): Add `ret-type-specifier' slot. (comp-ret-type-spec): New function. (comp-final): Call `comp-ret-type-spec'. --- lisp/emacs-lisp/comp.el | 54 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e026d3b6adb..c863c29991f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,7 +186,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") "List of disabled passes. For internal use only by the testsuite.") -(defvar comp-post-pass-hooks () +(defvar comp-post-pass-hooks '() "Alist PASS FUNCTIONS. Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") @@ -421,7 +421,9 @@ CFG is mutated by a pass.") (speed nil :type number :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean - :documentation "t if pure nil otherwise.")) + :documentation "t if pure nil otherwise.") + (ret-type-specifier '(t) :type list + :documentation "Derived return type specifier.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -2768,6 +2770,53 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. +(defun comp-ret-type-spec (_ func) + "Compute type specifier for `comp-func' FUNC. +Set it into the `ret-type-specifier' slot." + (cl-loop + with res-typeset = nil + with res-valset = nil + with res-range = nil + for bb being the hash-value in (comp-func-blocks func) + do (cl-loop + for insn in (comp-block-insns bb) + do (pcase insn + (`(return ,mvar) + (when-let ((typeset (comp-mvar-typeset mvar))) + (setf res-typeset (comp-union-typesets res-typeset typeset))) + (when-let ((valset (comp-mvar-valset mvar))) + (setf res-valset (append res-valset valset))) + (when-let (range (comp-mvar-range mvar)) + (setf res-range (comp-range-union res-range range)))))) + finally + (when res-valset + (setf res-typeset + (cl-loop + with res = (copy-sequence res-typeset) + for type in res-typeset + for pred = (alist-get type comp-type-predicates) + when pred + do (cl-loop + for v in res-valset + when (funcall pred v) + do (setf res (remove type res))) + finally (cl-return res)))) + (setf res-range (cl-loop for (l . h) in res-range + for low = (if (numberp l) l '*) + for high = (if (numberp h) h '*) + collect `(integer ,low , high)) + res-valset (cl-remove-duplicates res-valset)) + (let ((res (append res-typeset + (when res-valset + `((member ,@res-valset))) + res-range))) + (setf (comp-func-ret-type-specifier func) + (if (> (length res) 1) + `(or ,@res) + (if (consp (car res)) + (car res) + res)))))) + (defun comp-finalize-container (cont) "Finalize data container CONT." (setf (comp-data-container-l cont) @@ -2867,6 +2916,7 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." + (maphash #'comp-ret-type-spec (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run (if noninteractive (comp-final1) From 2435c103a4da85ae8b6bc48f3f964014d1cb6341 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Nov 2020 17:59:46 +0100 Subject: [PATCH 1146/1452] * Nativecomp testsuite rework for derived return type specifiers As we have derived return type specifiers as some test for them. Also rewrite some propagation related test using return type specifiers too as it's way more convenient. * test/src/comp-tests.el (fw-prop-1): Nit rename. (comp-tests-check-ret-type-spec): New function. (comp-tests-type-spec-tests): New variable. (comp-tests-cond-rw-0-var) Remove variable. (cond-rw-0, cond-rw-1, cond-rw-2, cond-rw-3, cond-rw-4, cond-rw-5) Remove tests as now covered by `comp-tests-check-ret-type-spec'. --- test/src/comp-tests.el | 167 ++++++++++++++++++++++++++--------------- 1 file changed, 105 insertions(+), 62 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8bedad5db73..23c4df88201 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -743,7 +743,7 @@ Return a list of results." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))))) -(comp-deftest fw-prop () +(comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((comp-speed 2) (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) @@ -757,6 +757,110 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) +(defun comp-tests-check-ret-type-spec (func-form type-specifier) + (let ((lexical-binding t) + (speed 2) + (comp-post-pass-hooks + `((comp-final + ,(lambda (_) + (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) + (comp-ctxt-funcs-h comp-ctxt)))) + (should (equal (comp-func-ret-type-specifier f) + type-specifier)))))))) + (eval func-form t) + (native-compile (cadr func-form)))) + +(defconst comp-tests-type-spec-tests + `(((defun comp-tests-ret-type-spec-0-f (x) + x) + (t)) + + ((defun comp-tests-ret-type-spec-1-f () + 1) + (integer 1 1)) + + ((defun comp-tests-ret-type-spec-2-f (x) + (if x 1 3)) + (or (integer 1 1) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-3-f (x) + (let (y) + (if x + (setf y 1) + (setf y 2)) + y)) + (integer 1 2)) + + ((defun comp-tests-ret-type-spec-4-f (x) + (let (y) + (if x + (setf y 1) + (setf y 3)) + y)) + (or (integer 1 1) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-5-f (x) + (if x + (list x) + 3)) + (or cons (integer 3 3))) + + ((defun comp-tests-ret-type-spec-6-f (x) + (if x + 'foo + 3)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-7-1-f (x) + (if (eq x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-7-2-f (x) + (if (eq 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-8-1-f (x) + (if (= x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-8-2-f (x) + (if (= 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; FIXME returning ATM (or t (member foo)) + ;; ((defun comp-tests-ret-type-spec-8-3-f (x) + ;; (if (= x 3) + ;; 'foo + ;; x)) + ;; (or number (member foo))) + + ((defun comp-tests-ret-type-spec-8-4-f (x y) + (if (= x y) + x + 'foo)) + (or number (member foo))) + + ((defun comp-tests-ret-type-spec-9-1-f (x) + (comp-hint-fixnum y)) + (integer ,most-negative-fixnum ,most-positive-fixnum)) + + ((defun comp-tests-ret-type-spec-9-1-f (x) + (comp-hint-cons x)) + (cons)))) + +(comp-deftest ret-type-spec () + "Some derived return type specifier tests." + (cl-loop for (func-form type-spec) in comp-tests-type-spec-tests + do (comp-tests-check-ret-type-spec func-form type-spec))) + (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is folded." @@ -826,67 +930,6 @@ Return a list of results." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) -(defvar comp-tests-cond-rw-0-var) -(comp-deftest cond-rw-0 () - "Check we do not miscompile some simple functions." - (let ((lexical-binding t)) - (let ((f (native-compile '(lambda (l) - (when (eq (car l) 'x) - (cdr l)))))) - (should (subr-native-elisp-p f)) - (should (eq (funcall f '(x . y)) 'y)) - (should (null (funcall f '(z . y))))) - - (should - (subr-native-elisp-p - (native-compile '(lambda () (if (eq comp-tests-cond-rw-0-var 123) 5 10))))))) - -(comp-deftest cond-rw-1 () - "Test cond-rw pass allow us to propagate type+val under `eq' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type - comp-tests-cond-rw-checker-val)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t)))))) - -(comp-deftest cond-rw-2 () - "Test cond-rw pass allow us to propagate type+val under `=' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type - comp-tests-cond-rw-checker-val)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t)))))) - -(comp-deftest cond-rw-3 () - "Test cond-rw pass allow us to propagate type+val under `eql' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type - comp-tests-cond-rw-checker-val)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t)))))) - -(comp-deftest cond-rw-4 () - "Test cond-rw pass allow us to propagate type under `=' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(number)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) - (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t)))))) - -(comp-deftest cond-rw-5 () - "Test cond-rw pass allow us to propagate type under `=' tests." - (let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) - (eval '(defun comp-tests-cond-rw-4-f (x y) - (declare (speed 3)) - (if (= x (comp-hint-fixnum y)) - x - t)) - t) - (native-compile #'comp-tests-cond-rw-4-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Range propagation tests. ;; From c4749cebeb68d75456d5ea9188323276f26d5b43 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 15:08:44 +0100 Subject: [PATCH 1147/1452] * Move phi function code into dedicated function and improve it * lisp/emacs-lisp/comp.el (comp-phi): New function moving logic from `comp-fwprop-insn'. --- lisp/emacs-lisp/comp.el | 67 ++++++++++++++++++++++++----------------- 1 file changed, 40 insertions(+), 27 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c863c29991f..2c871ee7fc7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2437,6 +2437,45 @@ Forward propagate immediate involed in assignments." (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) (rewrite-insn-as-setimm insn value))))))) +(defun comp-phi (lval &rest rvals) + "Phi function propagating RVALS into LVAL. +Return LVAL." + (let* ((rhs-mvars (mapcar #'car rvals)) + (values (mapcar #'comp-mvar-valset rhs-mvars)) + (from-latch (cl-some + (lambda (x) + (comp-latch-p + (gethash (cdr x) + (comp-func-blocks comp-func)))) + rvals))) + + ;; Type propagation. + (setf (comp-mvar-typeset lval) + (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rhs-mvars))) + + ;; Value propagation. + (setf (comp-mvar-valset lval) + (cl-loop + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-mvar-typeset lval)) + collect v)) + + ;; Range propagation + (setf (comp-mvar-range lval) + (when (and (not from-latch) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-mvar-typeset lval))) + ;; TODO memoize? + (apply #'comp-range-union + (mapcar #'comp-mvar-range rhs-mvars)))) + lval)) + (defun comp-fwprop-insn (insn) "Propagate within INSN." (pcase insn @@ -2477,33 +2516,7 @@ Forward propagate immediate involed in assignments." (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) - (let* ((rvals (mapcar #'car rest)) - (values (mapcar #'comp-mvar-valset rvals)) - (from-latch (cl-some - (lambda (x) - (comp-latch-p - (gethash (cdr x) - (comp-func-blocks comp-func)))) - rest))) - - ;; Type propagation. - (setf (comp-mvar-typeset lval) - (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rvals))) - ;; Value propagation. - (setf (comp-mvar-valset lval) - (when (cl-every #'consp values) - ;; TODO memoize? - (cl-remove-duplicates (apply #'append values) - :test #'equal))) - ;; Range propagation - (setf (comp-mvar-range lval) - (when (and (not from-latch) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (comp-mvar-typeset lval))) - ;; TODO memoize? - (apply #'comp-range-union - (mapcar #'comp-mvar-range rvals)))))))) + (apply #'comp-phi lval rest)))) (defun comp-fwprop* () "Propagate for set* and phi operands. From 6f10e0f09fc3adc9a7a114100cd2864a4bd7c708 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 15:08:58 +0100 Subject: [PATCH 1148/1452] * Rework `comp-ret-type-spec' in terms of `comp-phi' * lisp/emacs-lisp/comp.el (comp-ret-type-spec): Use `comp-func' not to duplicate logic plus add null type specifier support and some comments. --- lisp/emacs-lisp/comp.el | 85 ++++++++++++++++++++--------------------- 1 file changed, 42 insertions(+), 43 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2c871ee7fc7..59654913977 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2786,49 +2786,48 @@ These are substituted with a normal 'set' op." (defun comp-ret-type-spec (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `ret-type-specifier' slot." - (cl-loop - with res-typeset = nil - with res-valset = nil - with res-range = nil - for bb being the hash-value in (comp-func-blocks func) - do (cl-loop - for insn in (comp-block-insns bb) - do (pcase insn - (`(return ,mvar) - (when-let ((typeset (comp-mvar-typeset mvar))) - (setf res-typeset (comp-union-typesets res-typeset typeset))) - (when-let ((valset (comp-mvar-valset mvar))) - (setf res-valset (append res-valset valset))) - (when-let (range (comp-mvar-range mvar)) - (setf res-range (comp-range-union res-range range)))))) - finally - (when res-valset - (setf res-typeset - (cl-loop - with res = (copy-sequence res-typeset) - for type in res-typeset - for pred = (alist-get type comp-type-predicates) - when pred - do (cl-loop - for v in res-valset - when (funcall pred v) - do (setf res (remove type res))) - finally (cl-return res)))) - (setf res-range (cl-loop for (l . h) in res-range - for low = (if (numberp l) l '*) - for high = (if (numberp h) h '*) - collect `(integer ,low , high)) - res-valset (cl-remove-duplicates res-valset)) - (let ((res (append res-typeset - (when res-valset - `((member ,@res-valset))) - res-range))) - (setf (comp-func-ret-type-specifier func) - (if (> (length res) 1) - `(or ,@res) - (if (consp (car res)) - (car res) - res)))))) + (let* ((comp-func (make-comp-func)) + (res-mvar (apply #'comp-phi + (make-comp-mvar) + (cl-loop + with res = nil + for bb being the hash-value in (comp-func-blocks + func) + do (cl-loop + for insn in (comp-block-insns bb) + ;; Collect over every exit point the returned + ;; mvars and union results. + do (pcase insn + (`(return ,mvar) + (push `(,mvar . nil) res)))) + finally (cl-return res)))) + (res-valset (comp-mvar-valset res-mvar)) + (res-typeset (comp-mvar-typeset res-mvar)) + (res-range (comp-mvar-range res-mvar))) + ;; If nil is a value convert it into a `null' type specifier. + (when res-valset + (when (memq nil res-valset) + (setf res-valset (remove nil res-valset)) + (push 'null res-typeset))) + + ;; Form proper integer type specifiers. + (setf res-range (cl-loop for (l . h) in res-range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + collect `(integer ,low , high)) + res-valset (cl-remove-duplicates res-valset)) + + ;; Form the final type specifier. + (let ((res (append res-typeset + (when res-valset + `((member ,@res-valset))) + res-range))) + (setf (comp-func-ret-type-specifier func) + (if (> (length res) 1) + `(or ,@res) + (if (memq (car-safe res) '(member integer)) + res + (car res))))))) (defun comp-finalize-container (cont) "Finalize data container CONT." From c3daee78004b8bfc3459b0f763540bdf01cc96f8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 15:11:58 +0100 Subject: [PATCH 1149/1452] * Add few more type specifier tests * test/src/comp-tests.el (comp-tests-type-spec-tests): Add three tests and uncomment one. --- test/src/comp-tests.el | 61 ++++++++++++++++++++++++++++-------------- 1 file changed, 41 insertions(+), 20 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 23c4df88201..61838c670e1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -771,19 +771,19 @@ Return a list of results." (native-compile (cadr func-form)))) (defconst comp-tests-type-spec-tests - `(((defun comp-tests-ret-type-spec-0-f (x) + `(((defun comp-tests-ret-type-spec-f (x) x) - (t)) + t) - ((defun comp-tests-ret-type-spec-1-f () + ((defun comp-tests-ret-type-spec-f () 1) (integer 1 1)) - ((defun comp-tests-ret-type-spec-2-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if x 1 3)) (or (integer 1 1) (integer 3 3))) - ((defun comp-tests-ret-type-spec-3-f (x) + ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x (setf y 1) @@ -791,7 +791,7 @@ Return a list of results." y)) (integer 1 2)) - ((defun comp-tests-ret-type-spec-4-f (x) + ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x (setf y 1) @@ -799,48 +799,48 @@ Return a list of results." y)) (or (integer 1 1) (integer 3 3))) - ((defun comp-tests-ret-type-spec-5-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if x (list x) 3)) (or cons (integer 3 3))) - ((defun comp-tests-ret-type-spec-6-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if x 'foo 3)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-7-1-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (eq x 3) x 'foo)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-7-2-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (eq 3 x) x 'foo)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-8-1-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (= x 3) x 'foo)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-8-2-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (= 3 x) x 'foo)) (or (member foo) (integer 3 3))) - ;; FIXME returning ATM (or t (member foo)) - ;; ((defun comp-tests-ret-type-spec-8-3-f (x) - ;; (if (= x 3) - ;; 'foo - ;; x)) - ;; (or number (member foo))) + ;; FIXME would be nice to have (or number (member foo)) + ((defun comp-tests-ret-type-spec-8-3-f (x) + (if (= x 3) + 'foo + x)) + t) ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) @@ -852,9 +852,30 @@ Return a list of results." (comp-hint-fixnum y)) (integer ,most-negative-fixnum ,most-positive-fixnum)) - ((defun comp-tests-ret-type-spec-9-1-f (x) + ((defun comp-tests-ret-type-spec-f (x) (comp-hint-cons x)) - (cons)))) + cons) + + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (when x + (setf y 4)) + y)) + (or null (integer 4 4))) + + ((defun comp-tests-ret-type-spec-f () + (let (x + (y 3)) + (setf x y) + y)) + (integer 3 3)) + + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when x + (setf y x)) + y)) + t))) (comp-deftest ret-type-spec () "Some derived return type specifier tests." From a37cc95e21675e4f8865a9c20c8acfc158a9827a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 21:59:59 +0100 Subject: [PATCH 1150/1452] * Memoize `comp-common-supertype' * lisp/emacs-lisp/comp.el (comp-ctxt): Add `common-supertype-mem' slot. (comp-common-supertype): Memoize. --- lisp/emacs-lisp/comp.el | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 59654913977..583a3364dfa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -308,7 +308,10 @@ This is tipically for top-level forms other than defun.") :documentation "When non-nil support late load.") (union-typesets-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-union-typesets'.")) +`comp-union-typesets'.") + (common-supertype-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-common-supertype'.")) (cl-defstruct comp-args-base (min nil :type number @@ -2252,7 +2255,10 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (defun comp-common-supertype (&rest types) "Return the first common supertype of TYPES." - (cl-reduce #'comp-common-supertype-2 types)) + (or (gethash types (comp-ctxt-common-supertype-mem comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-ctxt-common-supertype-mem comp-ctxt)))) (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise." From c412d396b0e714c604b3386369b64f0c7e762fe8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 23:38:01 +0100 Subject: [PATCH 1151/1452] * lisp/emacs-lisp/comp.el (comp-mvar-value-vld-p): Fix logic. --- lisp/emacs-lisp/comp.el | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 583a3364dfa..217eec1b568 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -456,15 +456,21 @@ Interg values are handled in the `range' slot.") (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." - (or (= (length (comp-mvar-valset mvar)) 1) - (let ((r (comp-mvar-range mvar))) - (and (= (length r) 1) - (let ((low (caar r)) - (high (cdar r))) - (and - (integerp low) - (integerp high) - (= low high))))))) + (when (null (comp-mvar-typeset mvar)) + (let* ((v (comp-mvar-valset mvar)) + (r (comp-mvar-range mvar)) + (valset-len (length v)) + (range-len (length r))) + (if (and (= valset-len 1) + (= range-len 0)) + t + (when (and (= valset-len 0) + (= range-len 1)) + (let* ((low (caar r)) + (high (cdar r))) + (and (integerp low) + (integerp high) + (= low high)))))))) (defun comp-mvar-value (mvar) "Return the constant value of MVAR. From 9bb2fc1e647bb74fd37a62c0b2f35c8eb4f8eece Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 23:41:04 +0100 Subject: [PATCH 1152/1452] Add copy insn testcase * test/src/comp-tests.el (copy-insn): New testcase. * test/src/comp-test-funcs.el (comp-test-copy-insn-f): New function. --- test/src/comp-test-funcs.el | 16 ++++++++++++++++ test/src/comp-tests.el | 5 +++++ 2 files changed, 21 insertions(+) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 1b0f3056b98..bcf9fcb0fd1 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -354,6 +354,22 @@ 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))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 61838c670e1..b2f83998838 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -444,6 +444,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (= (comp-test-and-3-f t) 2)) (should (null (comp-test-and-3-f '(1 2))))) +(comp-deftest copy-insn () + (should (equal (comp-test-copy-insn-f '(1 2 3 (4 5 6))) + '(1 2 3 (4 5 6)))) + (should (null (comp-test-copy-insn-f nil)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From a467fa5c499c5808c6886d0d71640c1352498db8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 12 Nov 2020 17:27:31 +0100 Subject: [PATCH 1153/1452] Characterize functions in terms of type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): New const in place of `comp-known-ret-types' and `comp-known-ret-ranges'. (comp-constraint): New struct to separate the constraint side of an mvar. (comp-constraint-f): Analogous for functions. (comp-mvar): Rework and include `comp-constraint'. (comp-type-spec-to-constraint): New function. (comp-known-constraints-h): New const. (comp-func-ret-typeset, comp-func-ret-range): Rework. (comp-fwprop-insn): Fix. * test/src/comp-tests.el (destructure-type-spec): New testcase. --- lisp/emacs-lisp/comp.el | 143 +++++++++++++++++++++++++++++----------- test/src/comp-tests.el | 35 ++++++++++ 2 files changed, 140 insertions(+), 38 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 217eec1b568..96b2b29043a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,31 +191,17 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -(defconst comp-known-ret-types '((cons . (cons)) - (1+ . (number)) - (1- . (number)) - (+ . (number)) - (- . (number)) - (* . (number)) - (/ . (number)) - (% . (number)) - ;; Type hints - (comp-hint-cons . (cons))) +(defconst comp-known-type-specifiers + `((cons (function (t t) cons)) + (1+ (function ((or number marker)) number)) + (1- (function ((or number marker)) number)) + (+ (function (&rest (or number marker)) number)) + (- (function (&rest (or number marker)) number)) + (* (function (&rest (or number marker)) number)) + (/ (function ((or number marker) &rest (or number marker)) number)) + (% (function ((or number marker) (or number marker)) number))) "Alist used for type propagation.") -(defconst comp-known-ret-ranges - `((comp-hint-fixnum . (,most-negative-fixnum . ,most-positive-fixnum))) - "Known returned ranges.") - -;; TODO fill it. -(defconst comp-type-predicates '((cons . consp) - (float . floatp) - (integer . integerp) - (number . numberp) - (string . stringp) - (symbol . symbolp)) - "Alist type -> predicate.") - (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -438,22 +424,33 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct (comp-mvar (:constructor make--comp-mvar)) - "A meta-variable being a slot in the meta-stack." - (id nil :type (or null number) - :documentation "Unique id when in SSA form.") - (slot nil :type (or fixnum symbol) - :documentation "Slot number in the array if a number or - 'scratch' for scratch slot.") +(cl-defstruct comp-constraint + "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. Each element cannot be a subtype of any other element of this slot.") (valset '() :type list :documentation "List of possible values the mvar can assume. -Interg values are handled in the `range' slot.") +Integer values are handled in the `range' slot.") (range '() :type list :documentation "Integer interval.")) +(cl-defstruct comp-constraint-f + "Internal constraint representation for a function." + (args nil :type (or null list) + :documentation "List of `comp-constraint' for its arguments.") + (ret nil :type (or comp-constraint comp-constraint-f) + :documentation "Returned value `comp-constraint'.")) + +(cl-defstruct (comp-mvar (:constructor make--comp-mvar) + (:include comp-constraint)) + "A meta-variable being a slot in the meta-stack." + (id nil :type (or null number) + :documentation "Unique id when in SSA form.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number in the array if a number or + 'scratch' for scratch slot.")) + (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." (when (null (comp-mvar-typeset mvar)) @@ -529,6 +526,73 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) +(cl-defun comp-type-spec-to-constraint (type-specifier) + "Destructure TYPE-SPECIFIER. +Return the corresponding `comp-constraint' or `comp-constraint-f'." + (let (typeset valset range) + (cl-labels ((star-or-num (x) + (or (numberp x) (eq '* x))) + (destructure-push (x) + (pcase x + ('&optional + (cl-return-from comp-type-spec-to-constraint '&optional)) + ('&rest + (cl-return-from comp-type-spec-to-constraint '&rest)) + ('null + (push nil valset)) + ('boolean + (push t valset) + (push nil valset)) + ('fixnum + (push `(,most-negative-fixnum . ,most-positive-fixnum) + range)) + ('bignum + (push `(- . ,(1- most-negative-fixnum)) + range) + (push `(,(1+ most-positive-fixnum) . +) + range)) + ((pred symbolp) + (push x typeset)) + (`(member . ,rest) + (setf valset (append rest valset))) + ('(integer * *) + (push '(- . +) range)) + (`(integer ,(and low (pred integerp)) *) + (push `(,low . +) range)) + (`(integer * ,(and high (pred integerp))) + (push `(- . ,high) range)) + (`(integer ,(and low (pred integerp)) + ,(and high (pred integerp))) + (push `(,low . ,high) range)) + (`(float ,(pred star-or-num) ,(pred star-or-num)) + ;; No float range support :/ + (push 'float typeset)) + (`(function ,args ,ret-type-spec) + (cl-return-from + comp-type-spec-to-constraint + (make-comp-constraint-f + :args (mapcar #'comp-type-spec-to-constraint args) + :ret (comp-type-spec-to-constraint ret-type-spec)))) + (_ (error "Unsopported type specifier"))))) + (if (or (atom type-specifier) + (memq (car type-specifier) '(member integer float function))) + (destructure-push type-specifier) + (if (eq (car type-specifier) 'or) + (mapc #'destructure-push (cdr type-specifier)) + (error "Unsopported type specifier"))) + (make-comp-constraint :typeset typeset + :valset valset + :range range)))) + +(defconst comp-known-constraints-h + (let ((h (make-hash-table :test #'eq))) + (cl-loop + for (f type-spec) in comp-known-type-specifiers + for constr = (comp-type-spec-to-constraint type-spec) + do (puthash f constr h)) + h) + "Hash table function -> `comp-constraint'") + (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -550,12 +614,15 @@ To be used by all entry points." (when (memq func comp-type-hints) t)) (defun comp-func-ret-typeset (func) - "Return the typeset returned by function FUNC. " - (or (alist-get func comp-known-ret-types) '(t))) + "Return the typeset returned by function FUNC." + (if-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-typeset (comp-constraint-f-ret spec)) + '(t))) -(defsubst comp-func-ret-range (func) - "Return the range returned by function FUNC. " - (alist-get func comp-known-ret-ranges)) +(defun comp-func-ret-range (func) + "Return the range returned by function FUNC." + (when-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-range (comp-constraint-f-ret spec)))) (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." @@ -2495,7 +2562,7 @@ Return LVAL." (pcase rval (`(,(or 'call 'callref) ,f . ,args) (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) (list range) + (setf (comp-mvar-range lval) range (comp-mvar-typeset lval) nil) (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f))) @@ -2503,7 +2570,7 @@ Return LVAL." (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) (list range) + (setf (comp-mvar-range lval) range (comp-mvar-typeset lval) nil) (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b2f83998838..a293a490d95 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1000,4 +1000,39 @@ Return a list of results." (should (equal (comp-union-typesets '(integer symbol) '()) '(symbol integer))))) +(comp-deftest destructure-type-spec () + (should (equal (comp-type-spec-to-constraint 'symbol) + (make-comp-constraint :typeset '(symbol)))) + (should (equal (comp-type-spec-to-constraint '(or symbol number)) + (make-comp-constraint :typeset '(number symbol)))) + (should-error (comp-type-spec-to-constraint '(symbol number))) + (should (equal (comp-type-spec-to-constraint '(member foo bar)) + (make-comp-constraint :typeset nil :valset '(foo bar)))) + (should (equal (comp-type-spec-to-constraint '(integer 1 2)) + (make-comp-constraint :typeset nil :range '((1 . 2))))) + (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) (integer 4 5))) + (make-comp-constraint :typeset nil :range '((4 . 5) (1 . 2))))) + (should (equal (comp-type-spec-to-constraint '(integer * 2)) + (make-comp-constraint :typeset nil :range '((- . 2))))) + (should (equal (comp-type-spec-to-constraint '(integer 1 *)) + (make-comp-constraint :typeset nil :range '((1 . +))))) + (should (equal (comp-type-spec-to-constraint '(integer * *)) + (make-comp-constraint :typeset nil :range '((- . +))))) + (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) + (member foo bar))) + (make-comp-constraint :typeset nil + :valset '(foo bar) + :range '((1 . 2))))) + (should (equal (comp-type-spec-to-constraint + '(function (t t) cons)) + (make-comp-constraint-f + :args `(,(make-comp-constraint :typeset '(t)) + ,(make-comp-constraint :typeset '(t))) + :ret (make-comp-constraint :typeset '(cons))))) + (should (equal (comp-type-spec-to-constraint + '(function ((or integer symbol)) float)) + (make-comp-constraint-f + :args `(,(make-comp-constraint :typeset '(symbol integer))) + :ret (make-comp-constraint :typeset '(float)))))) + ;;; comp-tests.el ends here From aced2cf6ac50d3c62380c224c7d553f597c1f574 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Nov 2020 16:55:39 +0100 Subject: [PATCH 1154/1452] * Add a number of type specifiers for pure function * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add 60 pure function type specifiers. --- lisp/emacs-lisp/comp.el | 48 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 47 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 96b2b29043a..fa94d399eb5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,6 +191,7 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") +;; FIXME this probably should not be here but... good for now. (defconst comp-known-type-specifiers `((cons (function (t t) cons)) (1+ (function ((or number marker)) number)) @@ -199,7 +200,52 @@ Useful to hook into pass checkers.") (- (function (&rest (or number marker)) number)) (* (function (&rest (or number marker)) number)) (/ (function ((or number marker) &rest (or number marker)) number)) - (% (function ((or number marker) (or number marker)) number))) + (% (function ((or number marker) (or number marker)) number)) + (concat (function (&rest sequence) string)) + (regexp-opt (function (list) string)) + (string-to-char (function (string) integer)) + (symbol-name (function (symbol) string)) + (eq (function (t t) boolean)) + (eql (function (t t) boolean)) + (= (function ((or number marker) (or number marker)) boolean)) + (/= (function ((or number marker) (or number marker)) boolean)) + (< (function ((or number marker) &rest (or number marker)) boolean)) + (<= (function ((or number marker) &rest (or number marker)) boolean)) + (>= (function ((or number marker) &rest (or number marker)) boolean)) + (> (function ((or number marker) &rest (or number marker)) boolean)) + (min (function ((or number marker) &rest (or number marker)) number)) + (max (function ((or number marker) &rest (or number marker)) number)) + (mod (function ((or number marker) (or number marker)) + (or (integer 0 *) (float 0 *)))) + (abs (function (number) number)) + (ash (function (integer integer) integer)) + (sqrt (function (number) float)) + (logand (function (&rest (or integer marker)) integer)) + (logior (function (&rest (or integer marker)) integer)) + (lognot (function (integer) integer)) + (logxor (function (&rest (or integer marker)) integer)) + (logcount (function (integer) integer)) + (copysign (function (float float) float)) + (isnan (function (float) boolean)) + (ldexp (function (number integer) float)) + (float (function (number) float)) + (logb (function (number) integer)) + (floor (function (number &optional number) integer)) + (ceiling (function (number &optional number) integer)) + (round (function (number &optional number) integer)) + (truncate (function (number &optional number) integer)) + (ffloor (function (float) float)) + (fceiling (function (float) float)) + (fround (function (float) float)) + (ftruncate (function (float) float)) + (string= (function ((or string symbol) (or string symbol)) boolean)) + (string-equal (function ((or string symbol) (or string symbol)) boolean)) + (string< (function ((or string symbol) (or string symbol)) boolean)) + (string-lessp (function ((or string symbol) (or string symbol)) boolean)) + (string-search (function (string string) (or integer null))) + ;; Type hints + (comp-hint-fixnum (function (t) fixnum)) + (comp-hint-cons (function (t) cons))) "Alist used for type propagation.") (defconst comp-symbol-values-optimizable '(most-positive-fixnum From 3d14a74f8f35fe16823361beb03dd0957dd6f510 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Nov 2020 11:24:30 +0100 Subject: [PATCH 1155/1452] * Fix debug symbol emission * src/comp.c (Fcomp__compile_ctxt_to_file): Now that we do not rely anymore on globlal variables move logic in from 'Fcomp__init_ctxt' so comp.debug is already set correctly. --- src/comp.c | 39 +++++++++++++++++++-------------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0d464281858..e126fa1b4ed 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4215,26 +4215,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.ctxt = gcc_jit_context_acquire (); - if (comp.debug) - { - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DEBUGINFO, - 1); - } - if (comp.debug > 2) - { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); - } - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); @@ -4408,6 +4388,25 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); + + if (comp.debug) + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + if (comp.debug > 2) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + } + gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp.speed < 0 ? 0 From 22da28cf6643b6293aa0255eca5f398dad23516d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Nov 2020 16:25:56 +0100 Subject: [PATCH 1156/1452] * Split logic into comp-fwprop-call and improve it * lisp/emacs-lisp/comp.el (comp-func-ret-valset) (comp-fwprop-call): New functions. (comp-fwprop-insn): Remove code duplicaiton and call `comp-fwprop-call'. --- lisp/emacs-lisp/comp.el | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fa94d399eb5..ffd483108d3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -670,6 +670,11 @@ Return the corresponding `comp-constraint' or `comp-constraint-f'." (when-let ((spec (gethash func comp-known-constraints-h))) (comp-constraint-range (comp-constraint-f-ret spec)))) +(defun comp-func-ret-valset (func) + "Return the valset returned by function FUNC." + (when-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-valset (comp-constraint-f-ret spec)))) + (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) @@ -2601,26 +2606,29 @@ Return LVAL." (mapcar #'comp-mvar-range rhs-mvars)))) lval)) +(defun comp-fwprop-call (insn lval f args) + "Propagate on a call INSN into LVAL. +F is the function being called with arguments ARGS. +Fold the call in case." + (if-let ((range (comp-func-ret-range f))) + (setf (comp-mvar-range lval) range + (comp-mvar-typeset lval) nil) + (if-let ((valset (comp-func-ret-valset f))) + (setf (comp-mvar-valset lval) valset + (comp-mvar-typeset lval) nil) + (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f)))) + (comp-function-call-maybe-fold insn f args)) + (defun comp-fwprop-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval (`(,(or 'call 'callref) ,f . ,args) - (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) range - (comp-mvar-typeset lval) nil) - (setf (comp-mvar-typeset lval) - (comp-func-ret-typeset f))) - (comp-function-call-maybe-fold insn f args)) + (comp-fwprop-call insn lval f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) - (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) range - (comp-mvar-typeset lval) nil) - (setf (comp-mvar-typeset lval) - (comp-func-ret-typeset f))) - (comp-function-call-maybe-fold insn f args))) + (comp-fwprop-call insn lval f args))) (_ (comp-mvar-propagate lval rval)))) (`(assume ,lval ,rval ,kind) From bcecdedcb7ee02a58383de396bf05fda88654a30 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Nov 2020 16:45:50 +0100 Subject: [PATCH 1157/1452] Handle correctly quoting in *Native-compile-Log* buffer * lisp/emacs-lisp/comp.el (comp-log): Add `quoted' parameter and pass it to `comp-log-to-buffer'. (comp-log-to-buffer): Add `quoted' parameter and leverage `prin1' or `princ' accordingly. --- lisp/emacs-lisp/comp.el | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ffd483108d3..d75a0547823 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -731,7 +731,7 @@ Assume allocation class 'd-default as default." "Syntax-highlight LIMPLE IR." (setf font-lock-defaults '(comp-limple-lock-keywords))) -(cl-defun comp-log (data &optional (level 1)) +(cl-defun comp-log (data &optional (level 1) quoted) "Log DATA at LEVEL. LEVEL is a number from 1-3; if it is less than `comp-verbose', do nothing. If `noninteractive', log with `message'. Otherwise, @@ -742,15 +742,16 @@ log with `comp-log-to-buffer'." (atom (message "%s" data)) (t (dolist (elem data) (message "%s" elem)))) - (comp-log-to-buffer data)))) + (comp-log-to-buffer data quoted)))) -(cl-defun comp-log-to-buffer (data) +(cl-defun comp-log-to-buffer (data &optional quoted) "Log DATA to `comp-log-buffer-name'." - (let* ((log-buffer - (or (get-buffer comp-log-buffer-name) - (with-current-buffer (get-buffer-create comp-log-buffer-name) - (setf buffer-read-only t) - (current-buffer)))) + (let* ((print-f (if quoted #'prin1 #'princ)) + (log-buffer + (or (get-buffer comp-log-buffer-name) + (with-current-buffer (get-buffer-create comp-log-buffer-name) + (setf buffer-read-only t) + (current-buffer)))) (log-window (get-buffer-window log-buffer)) (inhibit-read-only t) at-end-p) @@ -762,9 +763,9 @@ log with `comp-log-to-buffer'." (save-excursion (goto-char (point-max)) (cl-typecase data - (atom (princ data log-buffer)) + (atom (funcall print-f data log-buffer)) (t (dolist (elem data) - (princ elem log-buffer) + (funcall print-f elem log-buffer) (insert "\n")))) (insert "\n")) (when (and at-end-p log-window) @@ -780,7 +781,7 @@ VERBOSITY is a number between 0 and 3." (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) - (comp-log (comp-block-insns bb) verbosity)))) + (comp-log (comp-block-insns bb) verbosity t)))) (defun comp-log-edges (func) "Log edges in FUNC." @@ -913,7 +914,7 @@ clashes." (gethash (aref (comp-func-byte-func func) 1) byte-to-native-lambdas-h)))) (cl-assert lap) - (comp-log lap 2) + (comp-log lap 2 t) (let ((arg-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-l-args func) (comp-decrypt-arg-list arg-list function-name) @@ -951,7 +952,7 @@ clashes." (gethash (aref byte-code 1) byte-to-native-lambdas-h)))) (cl-assert lap) - (comp-log lap 2) + (comp-log lap 2 t) (if (comp-func-l-p func) (setf (comp-func-l-args func) (comp-decrypt-arg-list (aref byte-code 0) byte-code)) @@ -1005,7 +1006,7 @@ clashes." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))) + (comp-log lap 1 t)))) (cl-defmethod comp-spill-lap-function ((filename string)) "Byte-compile FILENAME spilling data from the byte compiler." From f702426780475309bdd33ef896d28dd33484246b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Nov 2020 17:38:05 +0100 Subject: [PATCH 1158/1452] Add `comp-constraint-to-type-spec' and better handle boolean type spec * lisp/emacs-lisp/comp.el (comp-constraint-to-type-spec): New function splitting out code from comp-ret-type-spec + better handle boolean type specifier. (comp-ret-type-spec): Rework to leverage `comp-constraint-to-type-spec'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a testcase. --- lisp/emacs-lisp/comp.el | 66 ++++++++++++++++++++++++----------------- test/src/comp-tests.el | 6 +++- 2 files changed, 43 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d75a0547823..da144e4a24f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -639,6 +639,41 @@ Return the corresponding `comp-constraint' or `comp-constraint-f'." h) "Hash table function -> `comp-constraint'") +(defun comp-constraint-to-type-spec (mvar) + "Given MVAR return its type specifier." + (let ((valset (comp-mvar-valset mvar)) + (typeset (comp-mvar-typeset mvar)) + (range (comp-mvar-range mvar))) + + (when valset + (when (memq nil valset) + (if (memq t valset) + (progn + ;; t and nil are values, convert into `boolean'. + (push 'boolean typeset) + (setf valset (remove t (remove nil valset)))) + ;; Only nil is a value, convert it into a `null' type specifier. + (setf valset (remove nil valset)) + (push 'null typeset)))) + + ;; Form proper integer type specifiers. + (setf range (cl-loop for (l . h) in range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + collect `(integer ,low , high)) + valset (cl-remove-duplicates valset)) + + ;; Form the final type specifier. + (let ((res (append typeset + (when valset + `((member ,@valset))) + range))) + (if (> (length res) 1) + `(or ,@res) + (if (memq (car-safe res) '(member integer)) + res + (car res)))))) + (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -2934,34 +2969,9 @@ Set it into the `ret-type-specifier' slot." do (pcase insn (`(return ,mvar) (push `(,mvar . nil) res)))) - finally (cl-return res)))) - (res-valset (comp-mvar-valset res-mvar)) - (res-typeset (comp-mvar-typeset res-mvar)) - (res-range (comp-mvar-range res-mvar))) - ;; If nil is a value convert it into a `null' type specifier. - (when res-valset - (when (memq nil res-valset) - (setf res-valset (remove nil res-valset)) - (push 'null res-typeset))) - - ;; Form proper integer type specifiers. - (setf res-range (cl-loop for (l . h) in res-range - for low = (if (integerp l) l '*) - for high = (if (integerp h) h '*) - collect `(integer ,low , high)) - res-valset (cl-remove-duplicates res-valset)) - - ;; Form the final type specifier. - (let ((res (append res-typeset - (when res-valset - `((member ,@res-valset))) - res-range))) - (setf (comp-func-ret-type-specifier func) - (if (> (length res) 1) - `(or ,@res) - (if (memq (car-safe res) '(member integer)) - res - (car res))))))) + finally (cl-return res))))) + (setf (comp-func-ret-type-specifier func) + (comp-constraint-to-type-spec res-mvar)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a293a490d95..d377b089932 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -880,7 +880,11 @@ Return a list of results." (when x (setf y x)) y)) - t))) + t) + + ((defun comp-tests-ret-type-spec-f (x y) + (eq x y)) + boolean))) (comp-deftest ret-type-spec () "Some derived return type specifier tests." From 2f8d0fca888a42d0553b3880416780bb12f8167c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 14 Nov 2020 23:22:57 +0100 Subject: [PATCH 1159/1452] * Add more type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add more pure functions. --- lisp/emacs-lisp/comp.el | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da144e4a24f..b8f19b5f586 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -243,6 +243,35 @@ Useful to hook into pass checkers.") (string< (function ((or string symbol) (or string symbol)) boolean)) (string-lessp (function ((or string symbol) (or string symbol)) boolean)) (string-search (function (string string) (or integer null))) + (string-to-char (function (string) integer)) + (string-to-number (function (string &optional integer) number)) + (string-to-syntax (function (string) cons)) + (substring (function (string &optional integer integer) string)) + (sxhash (function (t) integer)) + (sxhash-equal (function (t) integer)) + (sxhash-eq (function (t) integer)) + (sxhash-eql (function (t) integer)) + (symbol-function (function (symbol) t)) + (symbol-name (function (symbol) string)) + (symbol-plist (function (symbol) list)) + (symbol-value (function (symbol) t)) + (string-make-unibyte (function (string) string)) + (string-make-multibyte (function (string) string)) + (string-as-multibyte (function (string) string)) + (string-as-unibyte (function (string) string)) + (string-to-multibyte (function (string) string)) + (tan (function (number) float)) + (time-convert (function (t &optional (or boolean integer)) cons)) + (truncate (function (number) integer)) + (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum + (upcase (function ((or fixnum string)) (or fixnum string))) + (user-full-name (function (&optional integer) string)) + (user-login-name (function (&optional integer) (or string null))) + (user-original-login-name (function (&optional integer) (or string null))) + (custom-variable-p (function (symbol) boolean)) + (vconcat (function (&rest sequence) vector)) + ;; TODO all window-* :x + (zerop (function (number) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons))) From 54f2e9c06d599b795af45ab872915887e7649ef2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Nov 2020 12:03:59 +0100 Subject: [PATCH 1160/1452] * Improve `comp-fwprop-call' * lisp/emacs-lisp/comp.el (comp-function-call-maybe-fold): Document return value. (comp-fwprop-call): Simplify and improve. --- lisp/emacs-lisp/comp.el | 33 ++++++++------------------------- 1 file changed, 8 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b8f19b5f586..397b0fd70b5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -723,22 +723,6 @@ Return the corresponding `comp-constraint' or `comp-constraint-f'." "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defun comp-func-ret-typeset (func) - "Return the typeset returned by function FUNC." - (if-let ((spec (gethash func comp-known-constraints-h))) - (comp-constraint-typeset (comp-constraint-f-ret spec)) - '(t))) - -(defun comp-func-ret-range (func) - "Return the range returned by function FUNC." - (when-let ((spec (gethash func comp-known-constraints-h))) - (comp-constraint-range (comp-constraint-f-ret spec)))) - -(defun comp-func-ret-valset (func) - "Return the valset returned by function FUNC." - (when-let ((spec (gethash func comp-known-constraints-h))) - (comp-constraint-valset (comp-constraint-f-ret spec)))) - (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) @@ -2604,7 +2588,8 @@ Forward propagate immediate involed in assignments." (cl-every #'comp-mvar-value-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) - "Given INSN when F is pure if all ARGS are known remove the function call." + "Given INSN when F is pure if all ARGS are known remove the function call. +Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. (comp-add-const-to-relocs value) @@ -2675,14 +2660,12 @@ Return LVAL." "Propagate on a call INSN into LVAL. F is the function being called with arguments ARGS. Fold the call in case." - (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) range - (comp-mvar-typeset lval) nil) - (if-let ((valset (comp-func-ret-valset f))) - (setf (comp-mvar-valset lval) valset - (comp-mvar-typeset lval) nil) - (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f)))) - (comp-function-call-maybe-fold insn f args)) + (unless (comp-function-call-maybe-fold insn f args) + (when-let ((constr (gethash f comp-known-constraints-h))) + (let ((constr (comp-constraint-f-ret constr))) + (setf (comp-mvar-range lval) (comp-constraint-range constr) + (comp-mvar-valset lval) (comp-constraint-valset constr) + (comp-mvar-typeset lval) (comp-constraint-typeset constr)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." From 898f929215cf644c651abf789b564fcbc50ffbdd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Nov 2020 23:31:00 +0100 Subject: [PATCH 1161/1452] Fix nativecomp cond-rw pass * lisp/emacs-lisp/comp.el (comp-mvar-symbol-p): Improve it. (comp-cond-rw-func): Fix logic for multiple predecessor on target block. * test/src/comp-tests.el (comp-test-cond-rw-1): New test. * test/src/comp-test-funcs.el (comp-test-cond-rw-1-1-f) (comp-test-cond-rw-1-2-f): New functions. --- lisp/emacs-lisp/comp.el | 25 +++++++++++++++++-------- test/src/comp-test-funcs.el | 10 ++++++++++ test/src/comp-tests.el | 4 ++++ 3 files changed, 31 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 397b0fd70b5..c84c254e585 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -571,9 +571,10 @@ Integer values are handled in the `range' slot.") (> high most-positive-fixnum)) t)))) -(defsubst comp-mvar-symbol-p (mvar) +(defun comp-mvar-symbol-p (mvar) "Return t if MVAR is certainly a symbol." - (equal (comp-mvar-typeset mvar) '(symbol))) + (or (equal (comp-mvar-typeset mvar) '(symbol)) + (cl-every #'symbolp (comp-mvar-valset mvar)))) (defsubst comp-mvar-cons-p (mvar) "Return t if MVAR is certainly a cons." @@ -1999,12 +2000,20 @@ Return the corresponding rhs slot number." ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2)) - (when-let ((target-slot1 (comp-cond-rw-target-slot - (comp-mvar-slot op1) (car insns-seq) b))) - (comp-emit-assume target-slot1 op2 bb-1 test-fn)) - (when-let ((target-slot2 (comp-cond-rw-target-slot - (comp-mvar-slot op2) (car insns-seq) b))) - (comp-emit-assume target-slot2 op1 bb-1 test-fn)) + ;; FIXME We guard the target block against having more + ;; then one predecessor. The right fix will be to add a + ;; new dedicated basic block for the assumptions so we + ;; can proceed always. + (when (= (length (comp-block-in-edges + (gethash bb-1 + (comp-func-blocks comp-func)))) + 1) + (when-let ((target-slot1 (comp-cond-rw-target-slot + (comp-mvar-slot op1) (car insns-seq) b))) + (comp-emit-assume target-slot1 op2 bb-1 test-fn)) + (when-let ((target-slot2 (comp-cond-rw-target-slot + (comp-mvar-slot op2) (car insns-seq) b))) + (comp-emit-assume target-slot2 op1 bb-1 test-fn))) (cl-return-from in-the-basic-block)))))) (defun comp-cond-rw (_) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index bcf9fcb0fd1..207b6455f73 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -370,6 +370,16 @@ (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))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d377b089932..bf3f57a85e3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -449,6 +449,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." '(1 2 3 (4 5 6)))) (should (null (comp-test-copy-insn-f nil)))) +(comp-deftest comp-test-cond-rw-1 () + "Check cond-rw does not break target blocks with multiple predecessor." + (should (null (comp-test-cond-rw-1-2-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From cee6401c130bea0de727392e344d6073eed3297e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Mon, 16 Nov 2020 03:50:10 +0100 Subject: [PATCH 1162/1452] Various doc fixes for comp.el and comp.c * lisp/emacs-lisp/comp.el: Remove redundant :group args. (comp-async-cu-done-hook, comp-async-all-done-hook) (comp-async-env-modifier-form, comp-dry-run) (comp-ensure-native-compiler, comp-func-ret-typeset) (comp-func-ret-range, comp-limple-lock-keywords) (comp-make-curr-block): * src/comp.c (Fcomp_el_to_eln_filename, Fcomp__init_ctxt) (Fcomp_native_driver_options_effective_p) (Fcomp__compile_ctxt_to_file, Fcomp_libgccjit_version) (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr, Fnative_elisp_load, syms_of_comp): Doc fixes. --- lisp/emacs-lisp/comp.el | 55 +++++++++++++++++------------------------ src/comp.c | 50 ++++++++++++++++++------------------- 2 files changed, 46 insertions(+), 59 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c84c254e585..cc5922c61c6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -23,6 +23,7 @@ ;; along with GNU Emacs. If not, see . ;;; Commentary: + ;; This code is an attempt to make the pig fly. ;; Or, to put it another way to make a 911 out of a turbocharged VW Bug. @@ -73,27 +74,23 @@ This intended for debugging the compiler itself. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. - 3 max verbosity." - :type 'number - :group 'comp) + :type 'number) (defcustom comp-always-compile nil "Unconditionally (re-)compile all files." - :type 'boolean - :group 'comp) + :type 'boolean) (defcustom comp-deferred-compilation-black-list '() "List of regexps to exclude files from deferred native compilation. Skip if any is matching." - :type 'list - :group 'comp) + :type 'list) (defcustom comp-bootstrap-black-list '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." - :type 'list - :group 'comp) + :type 'list) (defcustom comp-never-optimize-functions '(;; The following two are mandatory for Emacs to be working @@ -101,39 +98,33 @@ Skip if any is matching." ;; REMOVE. macroexpand rename-buffer) "Primitive functions for which we do not perform trampoline optimization." - :type 'list - :group 'comp) + :type 'list) (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'number - :group 'comp) + :type 'number) +;; FIXME: This an abnormal hook, and should be renamed to something +;; like `comp-async-cu-done-function'. (defcustom comp-async-cu-done-hook nil - "This hook is run whenever an asyncronous native compilation -finishes compiling a single compilation unit. + "Hook run after asynchronously compiling a single compilation unit. The argument FILE passed to the function is the filename used as compilation input." - :type 'hook - :group 'comp) + :type 'hook) (defcustom comp-async-all-done-hook nil - "This hook is run whenever the asyncronous native compilation -finishes compiling all input files." - :type 'hook - :group 'comp) + "Hook run after asynchronously compiling all input files." + :type 'hook) (defcustom comp-async-env-modifier-form nil - "Form to be evaluated by each asyncronous compilation worker -before compilation. Usable to modify the compiler environment." - :type 'list - :group 'comp) + "Form evaluated before compilation by each asyncronous compilation worker. +Usable to modify the compiler environment." + :type 'list) (defcustom comp-async-report-warnings-errors t "Report warnings and errors from native asynchronous compilation." - :type 'boolean - :group 'comp) + :type 'boolean) (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. @@ -142,11 +133,10 @@ affecting the assembler and linker are likely to be useful. Passing these options is only available in libgccjit version 9 and above." - :type 'list - :group 'comp) + :type 'list) (defvar comp-dry-run nil - "When non-nil run everything but the C back-end.") + "If non-nil, run everything but the C back-end.") (defconst comp-valid-source-re (rx ".el" (? ".gz") eos) "Regexp to match filename of valid input source files.") @@ -594,7 +584,7 @@ In use by the backend." (defun comp-ensure-native-compiler () "Make sure Emacs has native compiler support and libgccjit is loadable. -Raise an error otherwise. +Signal an error otherwise. To be used by all entry points." (cond ((null (featurep 'nativecomp)) @@ -774,7 +764,7 @@ Assume allocation class 'd-default as default." (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) (1 font-lock-keyword-face))) - "Highlights used by comp-limple-mode.") + "Highlights used by `comp-limple-mode'.") (define-derived-mode comp-limple-mode fundamental-mode "LIMPLE" "Syntax-highlight LIMPLE IR." @@ -1260,8 +1250,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. ENTRY-SP is the sp value when entering. -The block is added to the current function. -The block is returned." +Add block to the current function and return it." (let ((bb (make--comp-block-lap addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-pc comp-pass) addr diff --git a/src/comp.c b/src/comp.c index e126fa1b4ed..5b0f58b1a4a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4031,7 +4031,7 @@ make_directory_wrapper_1 (Lisp_Object ignore) DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Given a source FILENAME return the corresponding .eln filename. + doc: /* Return the corresponding .eln filename for source FILENAME. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { @@ -4173,7 +4173,8 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, - doc: /* Initialize the native compiler context. Return t on success. */) + doc: /* Initialize the native compiler context. +Return t on success. */) (void) { load_gccjit_if_necessary (true); @@ -4331,8 +4332,7 @@ DEFUN ("comp-native-driver-options-effective-p", Fcomp_native_driver_options_effective_p, Scomp_native_driver_options_effective_p, 0, 0, 0, - doc: /* Return t if `comp-native-driver-options' is - effective nil otherwise. */) + doc: /* Return t if `comp-native-driver-options' is effective. */) (void) { #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ @@ -4378,7 +4378,7 @@ restore_sigmask (void) DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, - doc: /* Compile as native code the current context to file FILENAME. */) + doc: /* Compile the current context as native code to file FILENAME. */) (Lisp_Object filename) { load_gccjit_if_necessary (true); @@ -4491,8 +4491,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, Scomp_libgccjit_version, 0, 0, 0, - doc: /* Return the libgccjit version in use in the form -(MAJOR MINOR PATCHLEVEL) or nil if unknown (pre GCC10). */) + doc: /* Return libgccjit version in use. + +The return value has the form (MAJOR MINOR PATCHLEVEL) or nil if +unknown (before GCC version 10). */) (void) { #if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) @@ -4974,8 +4976,8 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, 7, 7, 0, - doc: /* This gets called by top_level_run during load phase to register - anonymous lambdas. */) + doc: /* Register anonymous lambda. +This gets called by top_level_run during the load phase. */) (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, Lisp_Object comp_u) @@ -5002,8 +5004,8 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 7, 7, 0, - doc: /* This gets called by top_level_run during load phase to register - each exported subr. */) + doc: /* Register exported subr. +This gets called by top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, Lisp_Object comp_u) @@ -5028,8 +5030,8 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, Scomp__late_register_subr, 7, 7, 0, - doc: /* This gets called by late_top_level_run during load - phase to register each exported subr. */) + doc: /* Register exported subr. +This gets called by late_top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, Lisp_Object comp_u) @@ -5056,8 +5058,7 @@ file_in_eln_sys_dir (Lisp_Object filename) /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. - LATE_LOAD has to be non-nil when loading for deferred - compilation. */) +LATE_LOAD has to be non-nil when loading for deferred compilation. */) (Lisp_Object filename, Lisp_Object late_load) { CHECK_STRING (filename); @@ -5102,8 +5103,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, DEFUN ("native-comp-available-p", Fnative_comp_available_p, Snative_comp_available_p, 0, 0, 0, - doc: /* Returns t if native compilation of Lisp files is available in -this instance of Emacs, nil otherwise. */) + doc: /* Return non-nil if native compilation support is built-in. */) (void) { #ifdef HAVE_NATIVE_COMP @@ -5120,11 +5120,10 @@ syms_of_comp (void) #ifdef HAVE_NATIVE_COMP /* Compiler control customizes. */ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, - doc: /* If non-nil compile asyncronously all .elc files -being loaded. + doc: /* If non-nil compile loaded .elc files asynchronously. -Once compilation happened each function definition is updated to the -native compiled one. */); +After compilation, each function definition is updated to the native +compiled one. */); comp_deferred_compilation = true; DEFSYM (Qcomp_speed, "comp-speed"); @@ -5275,8 +5274,8 @@ native compiled one. */); Vcomp_native_version_dir = Qnil; DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, - doc: /* Hash table symbol-name -> function-value. For - internal use during */); + doc: /* Hash table symbol-name -> function-value. +For internal use. */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h, @@ -5296,9 +5295,8 @@ The last directory of this list is assumed to be the system one. */); Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, - doc: /* When non-nil enable trampoline synthesis - triggerd by `fset' making primitives - redefinable effectivelly. */); + doc: /* If non-nil, enable trampoline synthesis triggered by `fset'. +This makes primitives redefinable effectively. */); DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> installed trampoline. From 007a5a677573ab628426a0605eb38f8e68fe1953 Mon Sep 17 00:00:00 2001 From: Jonas Bernoulli Date: Wed, 18 Nov 2020 14:08:42 +0100 Subject: [PATCH 1163/1452] [WIP] Add and improve section headings --- lisp/allout.el | 9 +++++---- lisp/icomplete.el | 9 +++++---- lisp/net/eudc.el | 8 ++++++-- 3 files changed, 16 insertions(+), 10 deletions(-) diff --git a/lisp/allout.el b/lisp/allout.el index b56071de59e..07049a05d7c 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -2529,10 +2529,10 @@ We skip anomalous low-level topics, a la `allout-aberrant-container-p'." ;;;_ - Subtree Charting ;;;_ " These routines either produce or assess charts, which are -;;; nested lists of the locations of topics within a subtree. -;;; -;;; Charts enable efficient subtree navigation by providing a reusable basis -;;; for elaborate, compound assessment and adjustment of a subtree. +;; nested lists of the locations of topics within a subtree. +;; +;; Charts enable efficient subtree navigation by providing a reusable basis +;; for elaborate, compound assessment and adjustment of a subtree. ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth) (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth) @@ -6514,6 +6514,7 @@ If BEG is bigger than END we return 0." ;; - and closes the last topic (this local-variables section). ;;Local variables: ;;allout-layout: (0 : -1 -1 0) +;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; allout.el ends here diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 4e546807b7f..f84ef784343 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -237,8 +237,8 @@ Last entry becomes the first and can be selected with (push (car last) comps) (completion--cache-all-sorted-completions beg end comps)))) -;;; Helpers for `fido-mode' (or `ido-mode' emulation) -;;; +;;;_* Helpers for `fido-mode' (or `ido-mode' emulation) + (defun icomplete-fido-kill () "Kill line or current completion, like `ido-mode'. If killing to the end of line make sense, call `kill-line', @@ -782,7 +782,7 @@ matches exist." "}") (concat determ " [Matched]")))))) -;;; Iswitchb compatibility +;;;_* Iswitchb compatibility ;; We moved Iswitchb to `obsolete' in 24.4, but autoloads in files in ;; `obsolete' aren't obeyed (since that would encourage people to keep using @@ -798,9 +798,10 @@ matches exist." ;;;_* Provide (provide 'icomplete) -;;_* Local emacs vars. +;;;_* Local emacs vars. ;;Local variables: ;;allout-layout: (-2 :) +;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; icomplete.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 08cab4f0470..226bf7e0871 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1150,7 +1150,9 @@ queries the server for the existing fields and displays a corresponding form." (cons "Directory Servers" (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) -;;; Load time initializations : +;;}}} + +;;{{{ Load time initializations ;; Load the options file (if (and (not noninteractive) @@ -1207,5 +1209,7 @@ This does nothing except loading eudc by autoload side-effect." ;;}}} (provide 'eudc) - +;; Local Variables: +;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|{{{\\|###autoload\\)\\|(" +;; End: ;;; eudc.el ends here From c36b4eed2d76f0e804d27d35dd6281f858639f94 Mon Sep 17 00:00:00 2001 From: Jonas Bernoulli Date: Wed, 18 Nov 2020 15:18:07 +0100 Subject: [PATCH 1164/1452] [TODO] Remove noisy anti-noise feature --- lisp/emacs-lisp/warnings.el | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index f525ea433ad..6cd7022e12e 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -292,17 +292,6 @@ entirely by setting `warning-suppress-types' or (insert (format (nth 1 level-info) (format warning-type-format typename)) message) - ;; Don't output the buttons when doing batch compilation - ;; and similar. - (unless (or noninteractive (eq type 'bytecomp)) - (insert " ") - (insert-button "Disable showing" - 'type 'warning-suppress-warning - 'warning-type type) - (insert " ") - (insert-button "Disable logging" - 'type 'warning-suppress-log-warning - 'warning-type type)) (funcall newline) (when (and warning-fill-prefix (not (string-match "\n" message))) (let ((fill-prefix warning-fill-prefix) From df17e102a07a2839cfabf6a90e9dd09a562300b0 Mon Sep 17 00:00:00 2001 From: Jonas Bernoulli Date: Wed, 18 Nov 2020 18:13:27 +0100 Subject: [PATCH 1165/1452] Revert "[TODO] Remove noisy anti-noise feature" This reverts commit c36b4eed2d76f0e804d27d35dd6281f858639f94. --- lisp/emacs-lisp/warnings.el | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 6cd7022e12e..f525ea433ad 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -292,6 +292,17 @@ entirely by setting `warning-suppress-types' or (insert (format (nth 1 level-info) (format warning-type-format typename)) message) + ;; Don't output the buttons when doing batch compilation + ;; and similar. + (unless (or noninteractive (eq type 'bytecomp)) + (insert " ") + (insert-button "Disable showing" + 'type 'warning-suppress-warning + 'warning-type type) + (insert " ") + (insert-button "Disable logging" + 'type 'warning-suppress-log-warning + 'warning-type type)) (funcall newline) (when (and warning-fill-prefix (not (string-match "\n" message))) (let ((fill-prefix warning-fill-prefix) From 4c453196a1fbb55e887c24c546632d346147959b Mon Sep 17 00:00:00 2001 From: Jonas Bernoulli Date: Wed, 18 Nov 2020 18:13:31 +0100 Subject: [PATCH 1166/1452] Revert "[WIP] Add and improve section headings" This reverts commit 007a5a677573ab628426a0605eb38f8e68fe1953. --- lisp/allout.el | 9 ++++----- lisp/icomplete.el | 9 ++++----- lisp/net/eudc.el | 8 ++------ 3 files changed, 10 insertions(+), 16 deletions(-) diff --git a/lisp/allout.el b/lisp/allout.el index 07049a05d7c..b56071de59e 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -2529,10 +2529,10 @@ We skip anomalous low-level topics, a la `allout-aberrant-container-p'." ;;;_ - Subtree Charting ;;;_ " These routines either produce or assess charts, which are -;; nested lists of the locations of topics within a subtree. -;; -;; Charts enable efficient subtree navigation by providing a reusable basis -;; for elaborate, compound assessment and adjustment of a subtree. +;;; nested lists of the locations of topics within a subtree. +;;; +;;; Charts enable efficient subtree navigation by providing a reusable basis +;;; for elaborate, compound assessment and adjustment of a subtree. ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth) (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth) @@ -6514,7 +6514,6 @@ If BEG is bigger than END we return 0." ;; - and closes the last topic (this local-variables section). ;;Local variables: ;;allout-layout: (0 : -1 -1 0) -;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; allout.el ends here diff --git a/lisp/icomplete.el b/lisp/icomplete.el index f84ef784343..4e546807b7f 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -237,8 +237,8 @@ Last entry becomes the first and can be selected with (push (car last) comps) (completion--cache-all-sorted-completions beg end comps)))) -;;;_* Helpers for `fido-mode' (or `ido-mode' emulation) - +;;; Helpers for `fido-mode' (or `ido-mode' emulation) +;;; (defun icomplete-fido-kill () "Kill line or current completion, like `ido-mode'. If killing to the end of line make sense, call `kill-line', @@ -782,7 +782,7 @@ matches exist." "}") (concat determ " [Matched]")))))) -;;;_* Iswitchb compatibility +;;; Iswitchb compatibility ;; We moved Iswitchb to `obsolete' in 24.4, but autoloads in files in ;; `obsolete' aren't obeyed (since that would encourage people to keep using @@ -798,10 +798,9 @@ matches exist." ;;;_* Provide (provide 'icomplete) -;;;_* Local emacs vars. +;;_* Local emacs vars. ;;Local variables: ;;allout-layout: (-2 :) -;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; icomplete.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 226bf7e0871..08cab4f0470 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1150,9 +1150,7 @@ queries the server for the existing fields and displays a corresponding form." (cons "Directory Servers" (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) -;;}}} - -;;{{{ Load time initializations +;;; Load time initializations : ;; Load the options file (if (and (not noninteractive) @@ -1209,7 +1207,5 @@ This does nothing except loading eudc by autoload side-effect." ;;}}} (provide 'eudc) -;; Local Variables: -;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|{{{\\|###autoload\\)\\|(" -;; End: + ;;; eudc.el ends here From 3ae309bd59c608b4262209e225b963a8f73450e6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Nov 2020 17:50:03 +0100 Subject: [PATCH 1167/1452] * Fix eln file hasing for symlink paths (bug#44701) * src/comp.c (Fcomp_el_to_eln_filename): Call `file-truename' in place of `expand-file-name' when available. --- src/comp.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 5b0f58b1a4a..292f0e7e707 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4037,7 +4037,15 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); - filename = Fexpand_file_name (filename, Qnil); + /* Use `file-truename' or fall back to `expand-file-name' when the + first is not available (bug#44701). + + `file-truename' is not available only for a short phases of the + bootstrap before file.el is loaded, given we do not symlink + inside the build directory this should work. */ + filename = NILP (Ffboundp (intern_c_string ("file-truename"))) + ? Fexpand_file_name (filename, Qnil) + : CALL1I (file-truename, filename); if (NILP (Ffile_exists_p (filename))) xsignal1 (Qfile_missing, filename); From a55415af7ea8ddc09dfda32ccb866c6556bb71c1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Nov 2020 00:59:00 +0100 Subject: [PATCH 1168/1452] Add 'EMACSNATIVELOADPATH' env variable support (bug#44726) * lisp/startup.el (normal-top-level): Read 'EMACSNATIVELOADPATH' and add entries too `comp-eln-load-path'. * lisp/mail/emacsbug.el (report-emacs-bug): Dump also 'EMACSNATIVELOADPATH'. --- lisp/mail/emacsbug.el | 2 +- lisp/startup.el | 10 +++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index d524b26f1b9..4af8780d980 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -313,7 +313,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)) diff --git a/lisp/startup.el b/lisp/startup.el index 89b1d59ce0a..2beeaa195d0 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -534,9 +534,13 @@ 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 (boundp 'comp-eln-load-path) - (setq comp-eln-load-path (cons (concat user-emacs-directory "eln-cache/") - comp-eln-load-path))) + (when (featurep 'nativecomp) + (let ((path-env (getenv "EMACSNATIVELOADPATH"))) + (when path-env + (dolist (path (split-string path-env ":")) + (unless (string= "" path) + (push path comp-eln-load-path))))) + (push (concat user-emacs-directory "eln-cache/") 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 From cf436db285bd27dae35fecfa9038c9ce48953853 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 20 Nov 2020 20:34:32 +0100 Subject: [PATCH 1169/1452] ; Fix trivial typos --- lisp/emacs-lisp/bytecomp.el | 2 +- lisp/emacs-lisp/comp.el | 24 ++++++++++++------------ src/comp.c | 12 ++++++------ src/comp.h | 2 +- src/pdumper.c | 2 +- test/src/comp-tests.el | 4 ++-- 6 files changed, 23 insertions(+), 23 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5508a60c444..6d2bff103e7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -602,7 +602,7 @@ Each element is (INDEX . VALUE)") "To spill default qualities from the compiled file.") (defvar byte-native-for-bootstrap nil "Non nil while compiling for bootstrap." - ;; During boostrap we produce both the .eln and the .elc together. + ;; 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. ) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cc5922c61c6..633ededebe4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -118,7 +118,7 @@ compilation input." :type 'hook) (defcustom comp-async-env-modifier-form nil - "Form evaluated before compilation by each asyncronous compilation worker. + "Form evaluated before compilation by each asynchronous compilation worker. Usable to modify the compiler environment." :type 'list) @@ -352,7 +352,7 @@ Needed to replace immediate byte-compiled lambdas with the compiled reference.") :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container :documentation "Relocated data that cannot be moved into pure space. -This is tipically for top-level forms other than defun.") +This is typically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean @@ -389,7 +389,7 @@ To be used when ncall-conv is nil.")) :documentation "List of instructions.") (closed nil :type boolean :documentation "t if closed.") - ;; All the followings are for SSA and CGF analysis. + ;; All the following are for SSA and CGF analysis. ;; Keep in sync with `comp-clean-ssa'!! (in-edges () :type list :documentation "List of incoming edges.") @@ -461,7 +461,7 @@ CFG is mutated by a pass.") (blocks (make-hash-table) :type hash-table :documentation "Basic block name -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table - :documentation "LAP lable -> LIMPLE basic block name.") + :documentation "LAP label -> LIMPLE basic block name.") (edges-h (make-hash-table) :type hash-table :documentation "Hash edge-num -> edge connecting basic two blocks.") (block-cnt-gen (funcall #'comp-gen-counter) :type function @@ -749,7 +749,7 @@ Assume allocation class 'd-default as default." comp-curr-allocation-class)))) -;;; Log rountines. +;;; Log routines. (defconst comp-limple-lock-keywords `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) @@ -873,7 +873,7 @@ instruction." Add PREFIX in front of it. If FIRST is not nil, pick the first available name ignoring compilation context and potential name clashes." - ;; Unfortunatelly not all symbol names are valid as C function names... + ;; Unfortunately not all symbol names are valid as C function names... ;; Nassi's algorithm here: (let* ((orig-name (if (symbolp name) (symbol-name name) name)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) @@ -2008,7 +2008,7 @@ Return the corresponding rhs slot number." (defun comp-cond-rw (_) "Rewrite conditional branches adding appropriate 'assume' insns. This is introducing and placing 'assume' insns in use by fwprop -to propagate conditional branch test informations on target basic +to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 1) @@ -2051,7 +2051,7 @@ blocks." f)))) (defun comp-pure-infer-func (f) - "If all funtions called by F are pure then F is pure too." + "If all functions called by F are pure then F is pure too." (when (and (cl-every (lambda (x) (or (comp-function-pure-p x) (eq x (comp-func-name f)))) @@ -2094,7 +2094,7 @@ blocks." mvar)) (defun comp-clean-ssa (f) - "Clean-up SSA for funtion F." + "Clean-up SSA for function F." (setf (comp-func-edges-h f) (make-hash-table)) (cl-loop for b being each hash-value of (comp-func-blocks f) @@ -2367,7 +2367,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (finalize-phi args b))))) (defun comp-ssa () - "Port all functions into mininal SSA form." + "Port all functions into minimal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) (ssa-status (comp-func-ssa-status f))) @@ -3139,7 +3139,7 @@ Prepare every function for final compilation and drive the C back-end." x) -;; Primitive funciton advice machinery +;; Primitive function advice machinery (defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." @@ -3445,7 +3445,7 @@ load once finished compiling." ;;;###autoload (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. -This is the syncronous entry-point for the Emacs Lisp native +This is the synchronous entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol, a form or the filename of an Emacs Lisp source file. diff --git a/src/comp.c b/src/comp.c index 292f0e7e707..6ddfad528b4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1517,7 +1517,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) emit_comment ("XFIXNUM"); gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); - /* FIXME: Implementation dependent (both RSHIFT are arithmetics). */ + /* FIXME: Implementation dependent (both RSHIFT are arithmetic). */ if (!USE_LSB_TAG) { @@ -3780,7 +3780,7 @@ define_maybe_gc_or_quit (void) /* 9 translates into checking for GC or quit every 512 calls to 'maybe_gc_quit'. This is the smallest value I could find with no performance impact running elisp-banechmarks and the same - used by the byte intepreter (see 'exec_byte_code'). */ + used by the byte interpreter (see 'exec_byte_code'). */ maybe_do_it_block, pass_block); @@ -4067,7 +4067,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) included in the hashing algorithm. As at any point in time no more then one file can exist with the - same filename, should be possibile to clean up all + same filename, should be possible to clean up all filename-path_hash-* except the most recent one (or the new one being recompiled). @@ -4617,7 +4617,7 @@ register_native_comp_unit (Lisp_Object comp_u) loaded the compiler and its dependencies. */ static Lisp_Object delayed_sources; -/* Queue an asyncronous compilation for the source file defining +/* Queue an asynchronous compilation for the source file defining FUNCTION_NAME and perform a late load. NOTE: ideally would be nice to move its call simply into Fload but @@ -4671,7 +4671,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, } /* This is to have deferred compilaiton able to compile comp - dependecies breaking circularity. */ + dependencies breaking circularity. */ if (!NILP (Ffeaturep (Qcomp, Qnil))) { /* Comp already loaded. */ @@ -5297,7 +5297,7 @@ If a directory is non absolute is assumed to be relative to `invocation-directory'. The last directory of this list is assumed to be the system one. */); - /* Temporary value in use for boostrap. We can't do better as + /* Temporary value in use for bootstrap. We can't do better as `invocation-directory' is still unset, will be fixed up during dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); diff --git a/src/comp.h b/src/comp.h index 077250ea869..f7d17f398c7 100644 --- a/src/comp.h +++ b/src/comp.h @@ -42,7 +42,7 @@ struct Lisp_Native_Comp_Unit Lisp_Object lambda_gc_guard_h; /* Hash c_name -> d_reloc_imp index. */ Lisp_Object lambda_c_name_idx_h; - /* Hash doc-idx -> function documentaiton. */ + /* Hash doc-idx -> function documentation. */ Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; diff --git a/src/pdumper.c b/src/pdumper.c index c253fc53c47..e0f8f5577ed 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -326,7 +326,7 @@ dump_fingerprint (char const *label, /* To be used if some order in the relocation process has to be enforced. */ enum reloc_phase { - /* First to run. Place here every relocation with no dependecy. */ + /* 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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index bf3f57a85e3..fffc72015b8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -393,7 +393,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () - "Test effectiveness of primitve advicing." + "Test effectiveness of primitive advicing." (let (comp-test-primitive-advice (f (lambda (&rest args) (setq comp-test-primitive-advice args)))) @@ -406,7 +406,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (defvar comp-test-primitive-redefine-args) (comp-deftest primitive-redefine () - "Test effectiveness of primitve redefinition." + "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) ((symbol-function #'-) (lambda (&rest args) From a79365acaff843a144eacc620bfe6992051f84d4 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 19 Nov 2020 22:10:20 +0100 Subject: [PATCH 1170/1452] compile-async: Don't error out on deferred compilation after load * lisp/emacs-lisp/comp.el (native-compile-async): Update comp-files-queue when deferred compilation is requested. (Bug#44676) --- lisp/emacs-lisp/comp.el | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 633ededebe4..095bd63a10f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3511,14 +3511,12 @@ LOAD can be nil t or 'late." (list "Path not a file nor directory" path))))) (dolist (file files) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - ;; When no load is specified (plain async compilation) we - ;; consider valid the one previously queued, otherwise we - ;; check for coherence (bug#40602). - (cl-assert (or (null load) - (eq load (cdr entry))) - nil "Trying to queue %s with LOAD %s but this is already \ -queued with LOAD %" - file load (cdr entry)) + ;; Most likely the byte-compiler has requested a deferred + ;; compilation, so update `comp-files-queue' to reflect that. + (unless (or (null load) + (eq load (cdr entry))) + (cl-substitute (cons file load) (car entry) comp-files-queue + :key #'car :test #'string=)) ;; Make sure we are not already compiling `file' (bug#40838). (unless (or (gethash file comp-async-compilations) ;; Also exclude files from deferred compilation if From 050de01d948fa2c07d9e8fbd73c683fdb615ff32 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 19 Nov 2020 22:09:37 +0100 Subject: [PATCH 1171/1452] Support native compilation of packages on install * lisp/emacs-lisp/package.el (package-unpack) (package--native-compile): Native compile packages on install, if the feature is available. (Bug#44676) (package-native-compile): New defcustom. --- etc/NEWS | 4 ++++ lisp/emacs-lisp/package.el | 17 +++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 7aa54882508..803185f0665 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -838,6 +838,10 @@ key binding / u package-menu-filter-upgradable / / package-menu-filter-clear +*** Option to automatically native compile packages on installation. +Customize the user option `package-native-compile' to enable automatic +native compilation of packages on installation. + --- *** Column widths in 'list-packages' display can now be customized. See the new user options 'package-name-column-width', diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index a381ca01f33..9264a811ced 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -389,6 +389,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 @@ -968,6 +974,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))) @@ -1052,6 +1060,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. From c60355582a3ed19b4cc7e04b3b2031e461ccf7f1 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 19 Nov 2020 22:11:17 +0100 Subject: [PATCH 1172/1452] * lisp/emacs-lisp/comp.el (native-compile-async): Doc fix. --- lisp/emacs-lisp/comp.el | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 095bd63a10f..2f1e8965c1b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3489,13 +3489,28 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (defun native-compile-async (paths &optional recursively load) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. -`comp-async-jobs-number' specifies the number of (commands) to -run simultaneously. If RECURSIVELY, recurse into subdirectories -of given directories. -LOAD can be nil t or 'late." + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The variable `comp-async-jobs-number' specifies the number +of (commands) to run simultaneously. + +LOAD can also be the symbol `late'. This is used internally if +the byte code has already been loaded when this function is +called. It means that we requests the special kind of load, +necessary in that situation, called \"late\" loading. + +During a \"late\" load instead of executing all top level forms +of the original files, only function definitions are +loaded (paying attention to have these effective only if the +bytecode definition was not changed in the meanwhile)." (comp-ensure-native-compiler) (unless (member load '(nil t late)) - (error "LOAD must be nil t or 'late")) + (error "LOAD must be nil, t or 'late")) (unless (listp paths) (setf paths (list paths))) (let (files) From 6781cd670d1487bbf0364d80de68ca9733342769 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 19 Nov 2020 22:18:50 +0100 Subject: [PATCH 1173/1452] Make load argument of native-compile-async internal * lisp/emacs-lisp/comp.el (native--compile-async): New defun extracted from native-compile-async. (native-compile-async): Remove load argument and use above new defun. * src/comp.c (maybe_defer_native_compilation): Use above new defun. (Bug#44676) --- lisp/emacs-lisp/comp.el | 20 ++++++++++++++++++-- src/comp.c | 6 +++--- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f1e8965c1b..567ff00b9c4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3485,8 +3485,7 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (`(,tempfile . ,target-file) (rename-file tempfile target-file t)))))) -;;;###autoload -(defun native-compile-async (paths &optional recursively load) +(defun native--compile-async (paths &optional recursively load) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. @@ -3553,6 +3552,23 @@ bytecode definition was not changed in the meanwhile)." (when (zerop (comp-async-runnings)) (comp-run-async-workers)))) +;;;###autoload +(defun native-compile-async (paths &optional recursively load) + "Compile PATHS asynchronously. +PATHS is one path or a list of paths to files or directories. + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The variable `comp-async-jobs-number' specifies the number +of (commands) to run simultaneously." + ;; Normalize: we only want to pass t or nil, never e.g. `late'. + (let ((load (not (not load)))) + (native--compile-async paths recursively load))) + (provide 'comp) ;;; comp.el ends here diff --git a/src/comp.c b/src/comp.c index 6ddfad528b4..99560cc13a1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4677,13 +4677,13 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Comp already loaded. */ if (!NILP (delayed_sources)) { - CALLN (Ffuncall, intern_c_string ("native-compile-async"), + CALLN (Ffuncall, intern_c_string ("native--compile-async"), delayed_sources, Qnil, Qlate); delayed_sources = Qnil; } Fputhash (function_name, definition, Vcomp_deferred_pending_h); - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); + CALLN (Ffuncall, intern_c_string ("native--compile-async"), + src, Qnil, Qlate); } else { From 6104ab0f35e10c4d61c8e8774aa246e6630c8ac0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Nov 2020 20:25:00 +0100 Subject: [PATCH 1174/1452] * Rename two native compiler customize * lisp/emacs-lisp/comp.el (comp-deferred-compilation-deny-list): Rename from `comp-deferred-compilation-black-list'. * lisp/emacs-lisp/comp.el (native--compile-async): Update to use `comp-deferred-compilation-deny-list'. (comp-bootstrap-deny-list): Rename. (batch-native-compile): Update to use `comp-bootstrap-deny-list'. --- lisp/emacs-lisp/comp.el | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 567ff00b9c4..29a97a7196e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -80,13 +80,13 @@ This intended for debugging the compiler itself. "Unconditionally (re-)compile all files." :type 'boolean) -(defcustom comp-deferred-compilation-black-list +(defcustom comp-deferred-compilation-deny-list '() "List of regexps to exclude files from deferred native compilation. Skip if any is matching." :type 'list) -(defcustom comp-bootstrap-black-list +(defcustom comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." @@ -3464,7 +3464,7 @@ Ultra cheap impersonation of `batch-byte-compile'." (cl-loop for file in command-line-args-left if (or (null byte-native-for-bootstrap) (cl-notany (lambda (re) (string-match re file)) - comp-bootstrap-black-list)) + comp-bootstrap-deny-list)) do (comp--native-compile file) else do (byte-compile-file file))) @@ -3535,10 +3535,10 @@ bytecode definition was not changed in the meanwhile)." (unless (or (gethash file comp-async-compilations) ;; Also exclude files from deferred compilation if ;; any of the regexps in - ;; `comp-deferred-compilation-black-list' matches. + ;; `comp-deferred-compilation-deny-list' matches. (and (eq load 'late) (cl-some (lambda (re) (string-match re file)) - comp-deferred-compilation-black-list))) + comp-deferred-compilation-deny-list))) (let* ((out-filename (comp-el-to-eln-filename file)) (out-dir (file-name-directory out-filename))) (unless (file-exists-p out-dir) From 7a8370ed0f1b1d62657e385789ee2f81c5607ec5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Nov 2020 20:26:00 +0100 Subject: [PATCH 1175/1452] * Add SELECTOR parameter to `native-compile-async' (bug#44813) * lisp/emacs-lisp/comp.el (native-compile-async-skip-p): New function ripping out logic from `native--compile-async' and accounting for SELECTOR. (native--compile-async): Add SELECTOR parameter, make use of `native-compile-async-skip-p' and move it with other private functions. (native-compile-async): Add SELECTOR parameter. --- lisp/emacs-lisp/comp.el | 163 +++++++++++++++++++++++----------------- 1 file changed, 94 insertions(+), 69 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 29a97a7196e..5313bfba996 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3439,6 +3439,92 @@ load once finished compiling." ;; So we return the compiled function. (native-elisp-load data)))) +(defun native-compile-async-skip-p (file load selector) + "Return non-nil when FILE compilation should be skipped. + +LOAD and SELECTOR work as described in `native--compile-async'." + ;; Make sure we are not already compiling `file' (bug#40838). + (or (gethash file comp-async-compilations) + (cond + ((null selector) nil) + ((functionp selector) (not (funcall selector file))) + ((stringp selector) (not (string-match-p selector file))) + (t (error "SELECTOR must be a function a regexp or nil"))) + ;; Also exclude files from deferred compilation if + ;; any of the regexps in + ;; `comp-deferred-compilation-deny-list' matches. + (and (eq load 'late) + (cl-some (lambda (re) + (string-match-p re file)) + comp-deferred-compilation-deny-list)))) + +(defun native--compile-async (paths &optional recursively load selector) + "Compile PATHS asynchronously. +PATHS is one path or a list of paths to files or directories. + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The optional argument SELECTOR has the following valid values: + +nil -- Select all files. +a string -- A regular expression selecting files with matching names. +a function -- A function selecting files with matching names. + +The variable `comp-async-jobs-number' specifies the number +of (commands) to run simultaneously. + +LOAD can also be the symbol `late'. This is used internally if +the byte code has already been loaded when this function is +called. It means that we requests the special kind of load, +necessary in that situation, called \"late\" loading. + +During a \"late\" load instead of executing all top level forms +of the original files, only function definitions are +loaded (paying attention to have these effective only if the +bytecode definition was not changed in the meanwhile)." + (comp-ensure-native-compiler) + (unless (member load '(nil t late)) + (error "LOAD must be nil, t or 'late")) + (unless (listp paths) + (setf paths (list paths))) + (let (files) + (dolist (path paths) + (cond ((file-directory-p path) + (dolist (file (if recursively + (directory-files-recursively + path comp-valid-source-re) + (directory-files path t comp-valid-source-re))) + (push file files))) + ((file-exists-p path) (push path files)) + (t (signal 'native-compiler-error + (list "Path not a file nor directory" path))))) + (dolist (file files) + (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) + ;; Most likely the byte-compiler has requested a deferred + ;; compilation, so update `comp-files-queue' to reflect that. + (unless (or (null load) + (eq load (cdr entry))) + (cl-substitute (cons file load) (car entry) comp-files-queue + :key #'car :test #'string=)) + + (unless (native-compile-async-skip-p file load selector) + (let* ((out-filename (comp-el-to-eln-filename file)) + (out-dir (file-name-directory out-filename))) + (unless (file-exists-p out-dir) + (make-directory out-dir t)) + (if (file-writable-p out-filename) + (setf comp-files-queue + (append comp-files-queue `((,file . ,load)))) + (display-warning 'comp + (format "No write access for %s skipping." + out-filename))))))) + (when (zerop (comp-async-runnings)) + (comp-run-async-workers)))) + ;;; Compiler entry points. @@ -3485,75 +3571,8 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (`(,tempfile . ,target-file) (rename-file tempfile target-file t)))))) -(defun native--compile-async (paths &optional recursively load) - "Compile PATHS asynchronously. -PATHS is one path or a list of paths to files or directories. - -If optional argument RECURSIVELY is non-nil, recurse into -subdirectories of given directories. - -If optional argument LOAD is non-nil, request to load the file -after compiling. - -The variable `comp-async-jobs-number' specifies the number -of (commands) to run simultaneously. - -LOAD can also be the symbol `late'. This is used internally if -the byte code has already been loaded when this function is -called. It means that we requests the special kind of load, -necessary in that situation, called \"late\" loading. - -During a \"late\" load instead of executing all top level forms -of the original files, only function definitions are -loaded (paying attention to have these effective only if the -bytecode definition was not changed in the meanwhile)." - (comp-ensure-native-compiler) - (unless (member load '(nil t late)) - (error "LOAD must be nil, t or 'late")) - (unless (listp paths) - (setf paths (list paths))) - (let (files) - (dolist (path paths) - (cond ((file-directory-p path) - (dolist (file (if recursively - (directory-files-recursively - path comp-valid-source-re) - (directory-files path t comp-valid-source-re))) - (push file files))) - ((file-exists-p path) (push path files)) - (t (signal 'native-compiler-error - (list "Path not a file nor directory" path))))) - (dolist (file files) - (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - ;; Most likely the byte-compiler has requested a deferred - ;; compilation, so update `comp-files-queue' to reflect that. - (unless (or (null load) - (eq load (cdr entry))) - (cl-substitute (cons file load) (car entry) comp-files-queue - :key #'car :test #'string=)) - ;; Make sure we are not already compiling `file' (bug#40838). - (unless (or (gethash file comp-async-compilations) - ;; Also exclude files from deferred compilation if - ;; any of the regexps in - ;; `comp-deferred-compilation-deny-list' matches. - (and (eq load 'late) - (cl-some (lambda (re) (string-match re file)) - comp-deferred-compilation-deny-list))) - (let* ((out-filename (comp-el-to-eln-filename file)) - (out-dir (file-name-directory out-filename))) - (unless (file-exists-p out-dir) - (make-directory out-dir t)) - (if (file-writable-p out-filename) - (setf comp-files-queue - (append comp-files-queue `((,file . ,load)))) - (display-warning 'comp - (format "No write access for %s skipping." - out-filename))))))) - (when (zerop (comp-async-runnings)) - (comp-run-async-workers)))) - ;;;###autoload -(defun native-compile-async (paths &optional recursively load) +(defun native-compile-async (paths &optional recursively load selector) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. @@ -3563,11 +3582,17 @@ subdirectories of given directories. If optional argument LOAD is non-nil, request to load the file after compiling. +The optional argument SELECTOR has the following valid values: + +nil -- Select all files. +a string -- A regular expression selecting files with matching names. +a function -- A function selecting files with matching names. + The variable `comp-async-jobs-number' specifies the number of (commands) to run simultaneously." ;; Normalize: we only want to pass t or nil, never e.g. `late'. (let ((load (not (not load)))) - (native--compile-async paths recursively load))) + (native--compile-async paths recursively load selector))) (provide 'comp) From 23c082638e77219b51e14797a0edae27ae59a9d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Nov 2020 23:51:17 +0100 Subject: [PATCH 1176/1452] Add comp-cstr.el and comp-cstr-tests.el As the constraint logic of the compiler is not trivial and largely independent from the rest of the code move it into comp-cstr.el to ease separation and maintainability. This commit improve the conversion type specifier -> constraint for generality. Lastly this should help with bootstrap time as comp.el compilation unit is slimmed down. * lisp/emacs-lisp/comp-cstr.el: New file. (comp--typeof-types, comp--all-builtin-types): Move from comp.el. (comp-cstr, comp-cstr-f): Same + rename. (comp-cstr-ctxt): New struct. (comp-supertypes, comp-common-supertype-2) (comp-common-supertype, comp-subtype-p, comp-union-typesets) (comp-range-1+, comp-range-1-, comp-range-<, comp-range-union) (comp-range-intersection): Move from comp.el. (comp-cstr-union-no-range, comp-cstr-union): Move from comp.el and rename. (comp-cstr-union-make): New function. (comp-type-spec-to-cstr, comp-cstr-to-type-spec): Move from comp.el, rename it and rework it. * lisp/emacs-lisp/comp.el (comp-known-func-cstr-h): Rework. (comp-ctxt): Remove two fields and include `comp-cstr-ctxt'. (comp-mvar, comp-fwprop-call): Update for `comp-cstr' being renamed. (comp-fwprop-insn): Use `comp-cstr-union-no-range' or `comp-cstr-union'. (comp-ret-type-spec): Use `comp-cstr-union' and rework. * test/lisp/emacs-lisp/comp-cstr-tests.el: New file. (comp-cstr-test-ts, comp-cstr-typespec-test): New functions. (comp-cstr-typespec-tests-alist): New defconst to generate tests on. (comp-cstr-generate-tests): New macro. * test/src/comp-tests.el (comp-tests-type-spec-tests): Update. (ret-type-spec): Initialize constraint context. --- lisp/Makefile.in | 1 + lisp/emacs-lisp/comp-cstr.el | 363 ++++++++++++++++++++++++ lisp/emacs-lisp/comp.el | 349 +++-------------------- test/lisp/emacs-lisp/comp-cstr-tests.el | 68 +++++ test/src/comp-tests.el | 7 +- 5 files changed, 470 insertions(+), 318 deletions(-) create mode 100644 lisp/emacs-lisp/comp-cstr.el create mode 100644 test/lisp/emacs-lisp/comp-cstr-tests.el diff --git a/lisp/Makefile.in b/lisp/Makefile.in index d6bb4cf5570..5fec921b072 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -114,6 +114,7 @@ COMPILE_FIRST = \ $(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 diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el new file mode 100644 index 00000000000..fcbb32fab2e --- /dev/null +++ b/lisp/emacs-lisp/comp-cstr.el @@ -0,0 +1,363 @@ +;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*- + +;; Author: Andrea Corallo + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Keywords: lisp +;; Package: emacs + +;; 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 . + +;;; Commentary: + +;; Constraint library in use by the native compiler. + +;; In LIMPLE each non immediate value is represented by a `comp-mvar'. +;; The part concerning the set of all values the `comp-mvar' can +;; assume is described into its constraint `comp-cstr'. Each +;; constraint consists in a triplet: type-set, value-set, range-set. +;; This file provide set operations between constraints (union +;; intersection and negation) plus routines to convert from and to a +;; CL like type specifier. + +;;; Code: + +(require 'cl-lib) + +(defconst comp--typeof-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) + ;; TODO can we just add t in `cl--typeof-types'? + "Like `cl--typeof-types' but with t as common supertype.") + +(defconst comp--all-builtin-types + (append cl--all-builtin-types '(t)) + "Likewise like `cl--all-builtin-types' but with t as common supertype.") + +(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr + (type &aux (typeset (list type)))) + (:constructor comp-value-to-cstr + (value &aux + (valset (list value)) + (typeset ()))) + (:constructor comp-irange-to-cstr + (irange &aux + (range (list irange)) + (typeset ())))) + "Internal representation of a type/value constraint." + (typeset '(t) :type list + :documentation "List of possible types the mvar can assume. +Each element cannot be a subtype of any other element of this slot.") + (valset () :type list + :documentation "List of possible values the mvar can assume. +Integer values are handled in the `range' slot.") + (range () :type list + :documentation "Integer interval.")) + +(cl-defstruct comp-cstr-f + "Internal constraint representation for a function." + (args () :type list + :documentation "List of `comp-cstr' for its arguments.") + (ret nil :type (or comp-cstr comp-cstr-f) + :documentation "Returned value.")) + +(cl-defstruct comp-cstr-ctxt + (union-typesets-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-union-typesets'.") + ;; TODO we should be able to just cons hash this. + (common-supertype-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-common-supertype'.")) + + +;;; Type handling. + +(defun comp-supertypes (type) + "Return a list of pairs (supertype . hierarchy-level) for TYPE." + (cl-loop + named outer + with found = nil + for l in comp--typeof-types + do (cl-loop + for x in l + for i from (length l) downto 0 + when (eq type x) + do (setf found t) + when found + collect `(,x . ,i) into res + finally (when found + (cl-return-from outer res))))) + +(defun comp-common-supertype-2 (type1 type2) + "Return the first common supertype of TYPE1 TYPE2." + (when-let ((types (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car))) + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) x y)) + types)))) + +(defun comp-common-supertype (&rest types) + "Return the first common supertype of TYPES." + (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-cstr-ctxt-common-supertype-mem comp-ctxt)))) + +(defsubst comp-subtype-p (type1 type2) + "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." + (eq (comp-common-supertype-2 type1 type2) type2)) + +(defun comp-union-typesets (&rest typesets) + "Union types present into TYPESETS." + (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt)) + (puthash typesets + (cl-loop + with types = (apply #'append typesets) + with res = '() + for lane in comp--typeof-types + do (cl-loop + with last = nil + for x in lane + when (memq x types) + do (setf last x) + finally (when last + (push last res))) + ;; TODO sort. + finally (cl-return (cl-remove-duplicates res))) + (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) + + +;;; Integer range handling + +(defsubst comp-range-1+ (x) + (if (symbolp x) + x + (1+ x))) + +(defsubst comp-range-1- (x) + (if (symbolp x) + x + (1- x))) + +(defsubst comp-range-< (x y) + (cond + ((eq x '+) nil) + ((eq x '-) t) + ((eq y '+) t) + ((eq y '-) nil) + (t (< x y)))) + +(defun comp-range-union (&rest ranges) + "Combine integer intervals RANGES by union set operation." + (cl-loop + with all-ranges = (apply #'append ranges) + with lows = (mapcar (lambda (x) + (cons (comp-range-1- (car x)) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (when (zerop nest) + (setf low i)) + (cl-incf nest) + else + do + (when (= nest 1) + (push `(,(comp-range-1+ low) . ,i) res)) + (cl-decf nest) + finally (cl-return (reverse res)))) + +(defun comp-range-intersection (&rest ranges) + "Combine integer intervals RANGES by intersecting." + (cl-loop + with all-ranges = (apply #'append ranges) + with n-ranges = (length ranges) + with lows = (mapcar (lambda (x) + (cons (car x) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + initially (when (cl-some #'null ranges) + ;; Intersecting with a null range always results in a + ;; null range. + (cl-return '())) + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (cl-incf nest) + (when (= nest n-ranges) + (setf low i)) + else + do + (when (= nest n-ranges) + (push `(,low . ,i) + res)) + (cl-decf nest) + finally (cl-return (reverse res)))) + + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "As `comp-cstr-union' but escluding the irange component." + (let ((values (mapcar #'comp-cstr-valset srcs))) + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (comp-cstr-valset dst) + (cl-loop + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v)) + + dst)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-no-range dst srcs) + ;; Range propagation + (setf (comp-cstr-range dst) + (when (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-cstr-typeset dst)) + ;; TODO memoize? + (apply #'comp-range-union + (mapcar #'comp-cstr-range srcs)))) + dst) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(defun comp-type-spec-to-cstr (type-spec &optional fn) + "Convert a type specifier TYPE-SPEC into a `comp-cstr'. +FN non-nil indicates we are parsing a function lambda list." + (cl-flet ((star-or-num (x) + (or (numberp x) (eq '* x)))) + (pcase type-spec + ((and (or '&optional '&rest) x) + (if fn + x + (error "Invalid `%s` in type specifier" x))) + ('fixnum + (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + ('boolean + (comp-type-spec-to-cstr '(member t nil))) + ('null (comp-value-to-cstr nil)) + ((pred atom) + (comp-type-to-cstr type-spec)) + (`(or . ,rest) + (apply #'comp-cstr-union-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(and . ,rest) + (cl-assert nil) + ;; TODO + ;; (apply #'comp-cstr-intersect-make + ;; (mapcar #'comp-type-spec-to-cstr rest)) + ) + (`(not ,cstr) + (cl-assert nil) + ;; TODO + ;; (comp-cstr-negate-make (comp-type-spec-to-cstr cstr)) + ) + (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) + (comp-irange-to-cstr `(,l . ,h))) + (`(integer * ,(and (pred integerp) h)) + (comp-irange-to-cstr `(- . ,h))) + (`(integer ,(and (pred integerp) l) *) + (comp-irange-to-cstr `(,l . +))) + (`(float ,(pred star-or-num) ,(pred star-or-num)) + ;; No float range support :/ + (comp-type-to-cstr 'float)) + (`(member . ,rest) + (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (`(function ,args ,ret) + (make-comp-cstr-f + :args (mapcar (lambda (x) + (comp-type-spec-to-cstr x t)) + args) + :ret (comp-type-spec-to-cstr ret))) + (_ (error "Invalid type specifier"))))) + +(defun comp-cstr-to-type-spec (cstr) + "Given CSTR return its type specifier." + (let ((valset (comp-cstr-valset cstr)) + (typeset (comp-cstr-typeset cstr)) + (range (comp-cstr-range cstr))) + + (when valset + (when (memq nil valset) + (if (memq t valset) + (progn + ;; t and nil are values, convert into `boolean'. + (push 'boolean typeset) + (setf valset (remove t (remove nil valset)))) + ;; Only nil is a value, convert it into a `null' type specifier. + (setf valset (remove nil valset)) + (push 'null typeset)))) + + ;; Form proper integer type specifiers. + (setf range (cl-loop for (l . h) in range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + collect `(integer ,low , high)) + valset (cl-remove-duplicates valset)) + + ;; Form the final type specifier. + (let* ((types-ints (append typeset range)) + (res (cond + ((and types-ints valset) + `((member ,@valset) ,@types-ints)) + (types-ints types-ints) + (valset `(member ,@valset)) + (t + ;; Empty type specifier + nil)))) + (pcase res + (`(,(or 'integer 'member) . ,_rest) res) + ((pred atom) res) + (`(,_first . ,rest) + (if rest + `(or ,@res) + (car res))))))) + +(provide 'comp-cstr) + +;;; comp-cstr.el ends here diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5313bfba996..498aae183a5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,6 +38,7 @@ (require 'rx) (require 'subr-x) (require 'warnings) +(require 'comp-cstr) (defgroup comp nil "Emacs Lisp native compiler." @@ -267,6 +268,16 @@ Useful to hook into pass checkers.") (comp-hint-cons (function (t) cons))) "Alist used for type propagation.") +(defconst comp-known-func-cstr-h + (cl-loop + with comp-ctxt = (make-comp-cstr-ctxt) + with h = (make-hash-table :test #'eq) + for (f type-spec) in comp-known-type-specifiers + for cstr = (comp-type-spec-to-cstr type-spec) + do (puthash f cstr h) + finally (cl-return h)) + "Hash table function -> `comp-constraint'") + (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -326,7 +337,7 @@ Useful to hook into pass checkers.") (idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into the previous field.")) -(cl-defstruct comp-ctxt +(cl-defstruct (comp-ctxt (:include comp-cstr-ctxt)) "Lisp side of the compiler context." (output nil :type string :documentation "Target output file-name for the compilation.") @@ -356,13 +367,7 @@ This is typically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean - :documentation "When non-nil support late load.") - (union-typesets-mem (make-hash-table :test #'equal) :type hash-table - :documentation "Serve memoization for -`comp-union-typesets'.") - (common-supertype-mem (make-hash-table :test #'equal) :type hash-table - :documentation "Serve memoization for -`comp-common-supertype'.")) + :documentation "When non-nil support late load.")) (cl-defstruct comp-args-base (min nil :type number @@ -489,26 +494,8 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct comp-constraint - "Internal representation of a type/value constraint." - (typeset '(t) :type list - :documentation "List of possible types the mvar can assume. -Each element cannot be a subtype of any other element of this slot.") - (valset '() :type list - :documentation "List of possible values the mvar can assume. -Integer values are handled in the `range' slot.") - (range '() :type list - :documentation "Integer interval.")) - -(cl-defstruct comp-constraint-f - "Internal constraint representation for a function." - (args nil :type (or null list) - :documentation "List of `comp-constraint' for its arguments.") - (ret nil :type (or comp-constraint comp-constraint-f) - :documentation "Returned value `comp-constraint'.")) - (cl-defstruct (comp-mvar (:constructor make--comp-mvar) - (:include comp-constraint)) + (:include comp-cstr)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) :documentation "Unique id when in SSA form.") @@ -592,108 +579,6 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) -(cl-defun comp-type-spec-to-constraint (type-specifier) - "Destructure TYPE-SPECIFIER. -Return the corresponding `comp-constraint' or `comp-constraint-f'." - (let (typeset valset range) - (cl-labels ((star-or-num (x) - (or (numberp x) (eq '* x))) - (destructure-push (x) - (pcase x - ('&optional - (cl-return-from comp-type-spec-to-constraint '&optional)) - ('&rest - (cl-return-from comp-type-spec-to-constraint '&rest)) - ('null - (push nil valset)) - ('boolean - (push t valset) - (push nil valset)) - ('fixnum - (push `(,most-negative-fixnum . ,most-positive-fixnum) - range)) - ('bignum - (push `(- . ,(1- most-negative-fixnum)) - range) - (push `(,(1+ most-positive-fixnum) . +) - range)) - ((pred symbolp) - (push x typeset)) - (`(member . ,rest) - (setf valset (append rest valset))) - ('(integer * *) - (push '(- . +) range)) - (`(integer ,(and low (pred integerp)) *) - (push `(,low . +) range)) - (`(integer * ,(and high (pred integerp))) - (push `(- . ,high) range)) - (`(integer ,(and low (pred integerp)) - ,(and high (pred integerp))) - (push `(,low . ,high) range)) - (`(float ,(pred star-or-num) ,(pred star-or-num)) - ;; No float range support :/ - (push 'float typeset)) - (`(function ,args ,ret-type-spec) - (cl-return-from - comp-type-spec-to-constraint - (make-comp-constraint-f - :args (mapcar #'comp-type-spec-to-constraint args) - :ret (comp-type-spec-to-constraint ret-type-spec)))) - (_ (error "Unsopported type specifier"))))) - (if (or (atom type-specifier) - (memq (car type-specifier) '(member integer float function))) - (destructure-push type-specifier) - (if (eq (car type-specifier) 'or) - (mapc #'destructure-push (cdr type-specifier)) - (error "Unsopported type specifier"))) - (make-comp-constraint :typeset typeset - :valset valset - :range range)))) - -(defconst comp-known-constraints-h - (let ((h (make-hash-table :test #'eq))) - (cl-loop - for (f type-spec) in comp-known-type-specifiers - for constr = (comp-type-spec-to-constraint type-spec) - do (puthash f constr h)) - h) - "Hash table function -> `comp-constraint'") - -(defun comp-constraint-to-type-spec (mvar) - "Given MVAR return its type specifier." - (let ((valset (comp-mvar-valset mvar)) - (typeset (comp-mvar-typeset mvar)) - (range (comp-mvar-range mvar))) - - (when valset - (when (memq nil valset) - (if (memq t valset) - (progn - ;; t and nil are values, convert into `boolean'. - (push 'boolean typeset) - (setf valset (remove t (remove nil valset)))) - ;; Only nil is a value, convert it into a `null' type specifier. - (setf valset (remove nil valset)) - (push 'null typeset)))) - - ;; Form proper integer type specifiers. - (setf range (cl-loop for (l . h) in range - for low = (if (integerp l) l '*) - for high = (if (integerp h) h '*) - collect `(integer ,low , high)) - valset (cl-remove-duplicates valset)) - - ;; Form the final type specifier. - (let ((res (append typeset - (when valset - `((member ,@valset))) - range))) - (if (> (length res) 1) - `(or ,@res) - (if (memq (car-safe res) '(member integer)) - res - (car res)))))) - (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -2392,143 +2277,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defconst comp--typeof-types (mapcar (lambda (x) - (append x '(t))) - cl--typeof-types) - ;; TODO can we just add t in `cl--typeof-types'? - "Like `cl--typeof-types' but with t as common supertype.") - -(defun comp-supertypes (type) - "Return a list of pairs (supertype . hierarchy-level) for TYPE." - (cl-loop - named outer - with found = nil - for l in comp--typeof-types - do (cl-loop - for x in l - for i from (length l) downto 0 - when (eq type x) - do (setf found t) - when found - collect `(,x . ,i) into res - finally (when found - (cl-return-from outer res))))) - -(defun comp-common-supertype-2 (type1 type2) - "Return the first common supertype of TYPE1 TYPE2." - (when-let ((types (cl-intersection - (comp-supertypes type1) - (comp-supertypes type2) - :key #'car))) - (car (cl-reduce (lambda (x y) - (if (> (cdr x) (cdr y)) x y)) - types)))) - -(defun comp-common-supertype (&rest types) - "Return the first common supertype of TYPES." - (or (gethash types (comp-ctxt-common-supertype-mem comp-ctxt)) - (puthash types - (cl-reduce #'comp-common-supertype-2 types) - (comp-ctxt-common-supertype-mem comp-ctxt)))) - -(defsubst comp-subtype-p (type1 type2) - "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise." - (eq (comp-common-supertype-2 type1 type2) type2)) - -(defun comp-union-typesets (&rest typesets) - "Union types present into TYPESETS." - (or (gethash typesets (comp-ctxt-union-typesets-mem comp-ctxt)) - (puthash typesets - (cl-loop - with types = (apply #'append typesets) - with res = '() - for lane in comp--typeof-types - do (cl-loop - with last = nil - for x in lane - when (memq x types) - do (setf last x) - finally (when last - (push last res))) - finally (cl-return (cl-remove-duplicates res))) - (comp-ctxt-union-typesets-mem comp-ctxt)))) - -(defsubst comp-range-1+ (x) - (if (symbolp x) - x - (1+ x))) - -(defsubst comp-range-1- (x) - (if (symbolp x) - x - (1- x))) - -(defsubst comp-range-< (x y) - (cond - ((eq x '+) nil) - ((eq x '-) t) - ((eq y '+) t) - ((eq y '-) nil) - (t (< x y)))) - -(defun comp-range-union (&rest ranges) - "Combine integer intervals RANGES by union operation." - (cl-loop - with all-ranges = (apply #'append ranges) - with lows = (mapcar (lambda (x) - (cons (comp-range-1- (car x)) 'l)) - all-ranges) - with highs = (mapcar (lambda (x) - (cons (cdr x) 'h)) - all-ranges) - with nest = 0 - with low = nil - with res = () - for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) - if (eq x 'l) - do - (when (zerop nest) - (setf low i)) - (cl-incf nest) - else - do - (when (= nest 1) - (push `(,(comp-range-1+ low) . ,i) res)) - (cl-decf nest) - finally (cl-return (reverse res)))) - -(defun comp-range-intersection (&rest ranges) - "Combine integer intervals RANGES by intersecting." - (cl-loop - with all-ranges = (apply #'append ranges) - with n-ranges = (length ranges) - with lows = (mapcar (lambda (x) - (cons (car x) 'l)) - all-ranges) - with highs = (mapcar (lambda (x) - (cons (cdr x) 'h)) - all-ranges) - with nest = 0 - with low = nil - with res = () - initially (when (cl-some #'null ranges) - ;; Intersecting with a null range always results in a - ;; null range. - (cl-return '())) - for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) - if (eq x 'l) - do - (cl-incf nest) - (when (= nest n-ranges) - (setf low i)) - else - do - (when (= nest n-ranges) - (push `(,low . ,i) - res)) - (cl-decf nest) - finally (cl-return (reverse res)))) - (defun comp-copy-insn (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. @@ -2615,55 +2363,16 @@ Return non-nil if the function is folded successfully." (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) (rewrite-insn-as-setimm insn value))))))) -(defun comp-phi (lval &rest rvals) - "Phi function propagating RVALS into LVAL. -Return LVAL." - (let* ((rhs-mvars (mapcar #'car rvals)) - (values (mapcar #'comp-mvar-valset rhs-mvars)) - (from-latch (cl-some - (lambda (x) - (comp-latch-p - (gethash (cdr x) - (comp-func-blocks comp-func)))) - rvals))) - - ;; Type propagation. - (setf (comp-mvar-typeset lval) - (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rhs-mvars))) - - ;; Value propagation. - (setf (comp-mvar-valset lval) - (cl-loop - for v in (cl-remove-duplicates (apply #'append values) - :test #'equal) - ;; We propagate only values those types are not already - ;; into typeset. - when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) - (comp-mvar-typeset lval)) - collect v)) - - ;; Range propagation - (setf (comp-mvar-range lval) - (when (and (not from-latch) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (comp-mvar-typeset lval))) - ;; TODO memoize? - (apply #'comp-range-union - (mapcar #'comp-mvar-range rhs-mvars)))) - lval)) - (defun comp-fwprop-call (insn lval f args) "Propagate on a call INSN into LVAL. F is the function being called with arguments ARGS. Fold the call in case." (unless (comp-function-call-maybe-fold insn f args) - (when-let ((constr (gethash f comp-known-constraints-h))) - (let ((constr (comp-constraint-f-ret constr))) - (setf (comp-mvar-range lval) (comp-constraint-range constr) - (comp-mvar-valset lval) (comp-constraint-valset constr) - (comp-mvar-typeset lval) (comp-constraint-typeset constr)))))) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (let ((cstr (comp-cstr-f-ret cstr-f))) + (setf (comp-mvar-range lval) (comp-cstr-range cstr) + (comp-mvar-valset lval) (comp-cstr-valset cstr) + (comp-mvar-typeset lval) (comp-cstr-typeset cstr)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." @@ -2695,7 +2404,17 @@ Fold the call in case." (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) - (apply #'comp-phi lval rest)))) + (let* ((from-latch (cl-some + (lambda (x) + (comp-latch-p + (gethash (cdr x) + (comp-func-blocks comp-func)))) + rest)) + (prop-fn (if from-latch + #'comp-cstr-union-no-range + #'comp-cstr-union)) + (rvals (mapcar #'car rest))) + (apply prop-fn lval rvals))))) (defun comp-fwprop* () "Propagate for set* and phi operands. @@ -2966,8 +2685,8 @@ These are substituted with a normal 'set' op." "Compute type specifier for `comp-func' FUNC. Set it into the `ret-type-specifier' slot." (let* ((comp-func (make-comp-func)) - (res-mvar (apply #'comp-phi - (make-comp-mvar) + (res-mvar (apply #'comp-cstr-union + (make-comp-cstr) (cl-loop with res = nil for bb being the hash-value in (comp-func-blocks @@ -2978,10 +2697,10 @@ Set it into the `ret-type-specifier' slot." ;; mvars and union results. do (pcase insn (`(return ,mvar) - (push `(,mvar . nil) res)))) + (push mvar res)))) finally (cl-return res))))) (setf (comp-func-ret-type-specifier func) - (comp-constraint-to-type-spec res-mvar)))) + (comp-cstr-to-type-spec res-mvar)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el new file mode 100644 index 00000000000..74419ff01e4 --- /dev/null +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -0,0 +1,68 @@ +;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; 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 . + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/comp-cstr.el + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'comp-cstr) + +(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 + `((symbol . symbol) + ((or string array) . array) + ;; ((and string array) . string) + ((or symbol number) . (or symbol number)) + ((or cons atom) . (or cons atom)) ;; SBCL return T + ;; ((and cons atom) . (or cons atom)) + ((member foo) . (member foo)) + ((member foo bar) . (member foo bar)) + ((or (member foo) (member bar)) . (member foo bar)) + ;; ((and (member foo) (member bar)) . symbol) + ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) + ;; ((and (member foo) symbol) . (member foo)) + ((or (member foo) number) . (or (member foo) number))) + "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 0 + 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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fffc72015b8..dd642b6a66e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -855,10 +855,10 @@ Return a list of results." (if (= x y) x 'foo)) - (or number (member foo))) + (or (member foo) number)) ((defun comp-tests-ret-type-spec-9-1-f (x) - (comp-hint-fixnum y)) + (comp-hint-fixnum x)) (integer ,most-negative-fixnum ,most-positive-fixnum)) ((defun comp-tests-ret-type-spec-f (x) @@ -892,7 +892,8 @@ Return a list of results." (comp-deftest ret-type-spec () "Some derived return type specifier tests." - (cl-loop for (func-form type-spec) in comp-tests-type-spec-tests + (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) + for (func-form type-spec) in comp-tests-type-spec-tests do (comp-tests-check-ret-type-spec func-form type-spec))) (defun comp-tests-pure-checker-1 (_) From 949b49cf771e8f38b23adb3fa4f9d7a9a5e290da Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Nov 2020 22:41:39 +0100 Subject: [PATCH 1177/1452] Move some tests from comp-tests.el to comp-cstr-tests.el * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add tests covering what was in: `range-simple-union', `union-types', `destructure-type-spec'. * test/src/comp-tests.el (range-simple-intersection, union-types) (destructure-type-spec): Remove tests. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 20 ++++++-- test/src/comp-tests.el | 61 +------------------------ 2 files changed, 17 insertions(+), 64 deletions(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 74419ff01e4..38a5e291311 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -42,17 +42,29 @@ (defconst comp-cstr-typespec-tests-alist `((symbol . symbol) ((or string array) . array) - ;; ((and string array) . string) ((or symbol number) . (or symbol number)) ((or cons atom) . (or cons atom)) ;; SBCL return T + ((or integer number) . number) + ((or (or integer symbol) number) . (or symbol number)) + ((or (or integer symbol) (or number list)) . (or list symbol number)) + ((or (or integer number) nil) . number) + ;; ((and string array) . string) ;; ((and cons atom) . (or cons atom)) + ;; ((and (member foo) (member bar)) . symbol) + ;; ((and (member foo) symbol) . (member foo)) ((member foo) . (member foo)) ((member foo bar) . (member foo bar)) ((or (member foo) (member bar)) . (member foo bar)) - ;; ((and (member foo) (member bar)) . symbol) ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) - ;; ((and (member foo) symbol) . (member foo)) - ((or (member foo) number) . (or (member foo) number))) + ((or (member foo) number) . (or (member foo) number)) + ((integer 1 2) . (integer 1 2)) + ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) + ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) + ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) + ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) + ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) + ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) + ((or (integer -1 2) (integer * 4)) . (integer * 4))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dd642b6a66e..88c7b8c0d81 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -970,20 +970,7 @@ Return a list of results." ;; Range propagation tests. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(comp-deftest range-simple-union () - (should (equal (comp-range-union '((-1 . 0)) '((3 . 4))) - '((-1 . 0) (3 . 4)))) - (should (equal (comp-range-union '((-1 . 2)) '((3 . 4))) - '((-1 . 4)))) - (should (equal (comp-range-union '((-1 . 3)) '((3 . 4))) - '((-1 . 4)))) - (should (equal (comp-range-union '((-1 . 4)) '((3 . 4))) - '((-1 . 4)))) - (should (equal (comp-range-union '((-1 . 5)) '((3 . 4))) - '((-1 . 5)))) - (should (equal (comp-range-union '((-1 . 0)) '()) - '((-1 . 0))))) - +;; FIXME to be removed when movable into comp-cstr-tests.el (comp-deftest range-simple-intersection () (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) '())) @@ -998,50 +985,4 @@ Return a list of results." (should (equal (comp-range-intersection '((-1 . 0)) '()) '()))) -(comp-deftest union-types () - (let ((comp-ctxt (make-comp-ctxt))) - (should (equal (comp-union-typesets '(integer) '(number)) - '(number))) - (should (equal (comp-union-typesets '(integer symbol) '(number)) - '(symbol number))) - (should (equal (comp-union-typesets '(integer symbol) '(number list)) - '(list symbol number))) - (should (equal (comp-union-typesets '(integer symbol) '()) - '(symbol integer))))) - -(comp-deftest destructure-type-spec () - (should (equal (comp-type-spec-to-constraint 'symbol) - (make-comp-constraint :typeset '(symbol)))) - (should (equal (comp-type-spec-to-constraint '(or symbol number)) - (make-comp-constraint :typeset '(number symbol)))) - (should-error (comp-type-spec-to-constraint '(symbol number))) - (should (equal (comp-type-spec-to-constraint '(member foo bar)) - (make-comp-constraint :typeset nil :valset '(foo bar)))) - (should (equal (comp-type-spec-to-constraint '(integer 1 2)) - (make-comp-constraint :typeset nil :range '((1 . 2))))) - (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) (integer 4 5))) - (make-comp-constraint :typeset nil :range '((4 . 5) (1 . 2))))) - (should (equal (comp-type-spec-to-constraint '(integer * 2)) - (make-comp-constraint :typeset nil :range '((- . 2))))) - (should (equal (comp-type-spec-to-constraint '(integer 1 *)) - (make-comp-constraint :typeset nil :range '((1 . +))))) - (should (equal (comp-type-spec-to-constraint '(integer * *)) - (make-comp-constraint :typeset nil :range '((- . +))))) - (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) - (member foo bar))) - (make-comp-constraint :typeset nil - :valset '(foo bar) - :range '((1 . 2))))) - (should (equal (comp-type-spec-to-constraint - '(function (t t) cons)) - (make-comp-constraint-f - :args `(,(make-comp-constraint :typeset '(t)) - ,(make-comp-constraint :typeset '(t))) - :ret (make-comp-constraint :typeset '(cons))))) - (should (equal (comp-type-spec-to-constraint - '(function ((or integer symbol)) float)) - (make-comp-constraint-f - :args `(,(make-comp-constraint :typeset '(symbol integer))) - :ret (make-comp-constraint :typeset '(float)))))) - ;;; comp-tests.el ends here From e2ff5d9605624baeae0fa500b00078b9f3e42e07 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Nov 2020 18:31:53 +0100 Subject: [PATCH 1178/1452] * Synthesize as const primitive function pointers and its container struct. * src/comp.c (declare_imported_func): Make const function pointer to primitive funcions. (emit_ctxt_code): Make struct 'comp.func_relocs' const. --- src/comp.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 99560cc13a1..12ff985d230 100644 --- a/src/comp.c +++ b/src/comp.c @@ -967,12 +967,13 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = - gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - ret_type, - nargs, - types, - 0); + gcc_jit_type_get_const ( + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + types, + 0)); gcc_jit_field *field = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -2866,7 +2867,9 @@ emit_ctxt_code (void) comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), + gcc_jit_type_get_pointer ( + gcc_jit_type_get_const ( + gcc_jit_struct_as_type (f_reloc_struct))), FUNC_LINK_TABLE_SYM); xfree (fields); From 2e0256e0a02edad129e0af1ea97b9e263c5d83fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Nov 2020 21:30:03 +0100 Subject: [PATCH 1179/1452] Add intersection support into comp-cstr.el --- lisp/emacs-lisp/comp-cstr.el | 80 ++++++++++++++++++++++--- test/lisp/emacs-lisp/comp-cstr-tests.el | 23 +++++-- test/src/comp-tests.el | 20 ------- 3 files changed, 91 insertions(+), 32 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index fcbb32fab2e..40fa48ee8e1 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -143,6 +143,19 @@ Integer values are handled in the `range' slot.") finally (cl-return (cl-remove-duplicates res))) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) +(defun comp-intersect-typesets (&rest typesets) + "Intersect types present into TYPESETS." + (when-let ((ty (apply #'append typesets))) + (if (> (length ty) 1) + (cl-reduce + (lambda (x y) + (let ((st (comp-common-supertype-2 x y))) + (cond + ((eq st x) (list y)) + ((eq st y) (list x))))) + ty) + ty))) + ;;; Integer range handling @@ -252,7 +265,7 @@ Integer values are handled in the `range' slot.") "Combine SRCS by union set operation setting the result in DST. DST is returned." (apply #'comp-cstr-union-no-range dst srcs) - ;; Range propagation + ;; Range propagation. (setf (comp-cstr-range dst) (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) @@ -266,6 +279,59 @@ DST is returned." "Combine SRCS by union set operation and return a new constraint." (apply #'comp-cstr-union (make-comp-cstr) srcs)) +;; TODO memoize +(cl-defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + + ;; Value propagation. + (setf (comp-cstr-valset dst) + ;; TODO sort. + (let ((values (cl-loop for src in srcs + for v = (comp-cstr-valset src) + when v + collect v))) + (when values + (cl-reduce (lambda (x y) + (cl-intersection x y :test #'equal)) + values)))) + + ;; Range propagation. + (when (cl-some #'identity (mapcar #'comp-cstr-range srcs)) + (if (comp-cstr-valset dst) + (progn + (setf (comp-cstr-valset dst) nil + (comp-cstr-range dst) nil + (comp-cstr-typeset dst) nil) + (cl-return-from comp-cstr-intersection dst)) + ;; TODO memoize? + (setf (comp-cstr-range dst) + (apply #'comp-range-intersection + (mapcar #'comp-cstr-range srcs))))) + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (if (or (comp-cstr-range dst) (comp-cstr-valset dst)) + (cl-loop + with type-val = (cl-remove-duplicates + (append (mapcar #'type-of + (comp-cstr-valset dst)) + (when (comp-cstr-range dst) + '(integer)))) + for type in (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs)) + when (and type (not (member type type-val))) + do (setf (comp-cstr-valset dst) nil + (comp-cstr-range dst) nil) + (cl-return nil)) + (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs)))) + dst) + +(defun comp-cstr-intersection-make (&rest srcs) + "Combine SRCS by intersection set operation and return a new constraint." + (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) + (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." @@ -287,11 +353,8 @@ FN non-nil indicates we are parsing a function lambda list." (apply #'comp-cstr-union-make (mapcar #'comp-type-spec-to-cstr rest))) (`(and . ,rest) - (cl-assert nil) - ;; TODO - ;; (apply #'comp-cstr-intersect-make - ;; (mapcar #'comp-type-spec-to-cstr rest)) - ) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) (`(not ,cstr) (cl-assert nil) ;; TODO @@ -351,7 +414,10 @@ FN non-nil indicates we are parsing a function lambda list." ;; Empty type specifier nil)))) (pcase res - (`(,(or 'integer 'member) . ,_rest) res) + (`(,(or 'integer 'member) . ,rest) + (if rest + res + (car res))) ((pred atom) res) (`(,_first . ,rest) (if rest diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 38a5e291311..c98ff80cd72 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -48,15 +48,13 @@ ((or (or integer symbol) number) . (or symbol number)) ((or (or integer symbol) (or number list)) . (or list symbol number)) ((or (or integer number) nil) . number) - ;; ((and string array) . string) - ;; ((and cons atom) . (or cons atom)) - ;; ((and (member foo) (member bar)) . symbol) - ;; ((and (member foo) symbol) . (member foo)) ((member foo) . (member foo)) ((member foo bar) . (member foo bar)) ((or (member foo) (member bar)) . (member foo bar)) ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) ((or (member foo) number) . (or (member foo) number)) + ((or (integer 1 3) number) . number) + (integer . integer) ((integer 1 2) . (integer 1 2)) ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) @@ -64,7 +62,22 @@ ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) - ((or (integer -1 2) (integer * 4)) . (integer * 4))) + ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ((and string array) . string) + ((and cons atom) . nil) + ((and (member foo) (member foo bar baz)) . (member foo)) + ((and (member foo) (member bar)) . nil) + ((and (member foo) symbol) . (member foo)) + ((and (member foo) string) . nil) + ((and (member foo) (integer 1 2)) . nil) + ((and (member 1 2) (member 3 2)) . (member 2)) + ((and number (integer 1 2)) . number) + ((and integer (integer 1 2)) . integer) + ((and (integer -1 0) (integer 3 5)) . nil) + ((and (integer -1 2) (integer 3 5)) . nil) + ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ((and (integer -1 5) nil) . nil)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 88c7b8c0d81..dd97ccd5bd1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -965,24 +965,4 @@ Return a list of results." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Range propagation tests. ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; FIXME to be removed when movable into comp-cstr-tests.el -(comp-deftest range-simple-intersection () - (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) - '())) - (should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4))) - '())) - (should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4))) - '((3 . 3)))) - (should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4))) - '((3 . 4)))) - (should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4))) - '((3 . 4)))) - (should (equal (comp-range-intersection '((-1 . 0)) '()) - '()))) - ;;; comp-tests.el ends here From 21104e6808a4496afb8163d92c6fb4d59e3010b7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 30 Nov 2020 23:46:48 +0100 Subject: [PATCH 1180/1452] Fix `comp-mvar-symbol-p' and `comp-mvar-cons-p' (bug#44968) * lisp/emacs-lisp/comp.el (comp-mvar-symbol-p): As all slots into a `comp-cstr' are in or fix this logic. (comp-mvar-cons-p): Likewise. * test/src/comp-tests.el (bug-44968): New testcase. * test/src/comp-test-funcs.el (comp-test-44968-f): New test function. --- lisp/emacs-lisp/comp.el | 12 +++++++++--- test/src/comp-test-funcs.el | 10 ++++++++++ test/src/comp-tests.el | 4 ++++ 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 498aae183a5..13f9beb5f96 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -550,12 +550,18 @@ CFG is mutated by a pass.") (defun comp-mvar-symbol-p (mvar) "Return t if MVAR is certainly a symbol." - (or (equal (comp-mvar-typeset mvar) '(symbol)) - (cl-every #'symbolp (comp-mvar-valset mvar)))) + (and (null (comp-mvar-range mvar)) + (or (and (null (comp-mvar-valset mvar)) + (equal (comp-mvar-typeset mvar) '(symbol))) + (and (or (null (comp-mvar-typeset mvar)) + (equal (comp-mvar-typeset mvar) '(symbol))) + (cl-every #'symbolp (comp-mvar-valset mvar)))))) (defsubst comp-mvar-cons-p (mvar) "Return t if MVAR is certainly a cons." - (equal (comp-mvar-typeset mvar) '(cons))) + (and (null (comp-mvar-valset mvar)) + (null (comp-mvar-range mvar)) + (equal (comp-mvar-typeset mvar) '(cons)))) (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 207b6455f73..5fa427be190 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -380,6 +380,16 @@ 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))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dd97ccd5bd1..c2af52e4cab 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -391,6 +391,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) "Nel mezzo del yyy"))) +(comp-deftest bug-44968 () + "" + (comp-test-44968-f "/tmp/test/foo" "/tmp")) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." From 981240078cddbd26b35a65e5311350196542b42b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 3 Dec 2020 17:13:39 +0100 Subject: [PATCH 1181/1452] * Reduce (half) the number of loads emitted for calling into C code As after each function call GCC clobbers the pointer to the function relocation table. This commit modify the code generation to create a local copy of it for each function. This reduces the average number of loads for each function call into C from two to one. * src/comp.c (comp_t): Add 'func_relocs_ptr_type' and 'func_relocs_local' fields. (emit_call): Use the local func_relocs pointer when possible. (emit_ctxt_code): Fill 'comp.func_relocs_ptr_type'. (compile_function): Declare 'func_relocs_ptr_local'. (compile_function): Assign 'func_relocs_ptr_local' from the global value in each function prologue. --- src/comp.c | 46 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 36 insertions(+), 10 deletions(-) diff --git a/src/comp.c b/src/comp.c index 12ff985d230..590e3307414 100644 --- a/src/comp.c +++ b/src/comp.c @@ -580,8 +580,11 @@ typedef struct { gcc_jit_rvalue *data_relocs_impure; /* Same as before but content does not survive load phase. */ gcc_jit_rvalue *data_relocs_ephemeral; - /* Synthesized struct holding func relocs. */ + /* Global structure holding function relocations. */ gcc_jit_lvalue *func_relocs; + gcc_jit_type *func_relocs_ptr_type; + /* Pointer to this structure local to each function. */ + gcc_jit_lvalue *func_relocs_local; gcc_jit_function *memcpy; Lisp_Object d_default_idx; Lisp_Object d_impure_idx; @@ -1013,9 +1016,17 @@ emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs, } else { + /* Inline functions so far don't have a local variable for + function reloc table so we fall back to the global one. Even + if this is not aesthetic calling into C from open-code is + always a fallback and therefore not be performance critical. + To fix this could think do the inline our-self without + relying on GCC. */ gcc_jit_lvalue *f_ptr = gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (comp.func_relocs), + gcc_jit_lvalue_as_rvalue (comp.func_relocs_local + ? comp.func_relocs_local + : comp.func_relocs), NULL, (gcc_jit_field *) xmint_pointer (gcc_func)); @@ -2862,15 +2873,16 @@ emit_ctxt_code (void) NULL, "freloc_link_table", n_frelocs, fields); + comp.func_relocs_ptr_type = + gcc_jit_type_get_pointer ( + gcc_jit_struct_as_type (f_reloc_struct)); + comp.func_relocs = - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer ( - gcc_jit_type_get_const ( - gcc_jit_struct_as_type (f_reloc_struct))), - FUNC_LINK_TABLE_SYM); + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.func_relocs_ptr_type, + FUNC_LINK_TABLE_SYM); xfree (fields); } @@ -3931,6 +3943,12 @@ compile_function (Lisp_Object func) comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); + comp.func_relocs_local = + gcc_jit_function_new_local (comp.func, + NULL, + comp.func_relocs_ptr_type, + "freloc"); + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); if (comp.func_has_non_local || !comp.func_speed) { @@ -3985,6 +4003,12 @@ compile_function (Lisp_Object func) declare_block (HASH_KEY (ht, i)); } + gcc_jit_block_add_assignment (retrive_block (Qentry), + NULL, + comp.func_relocs_local, + gcc_jit_lvalue_as_rvalue (comp.func_relocs)); + + for (ptrdiff_t i = 0; i < ht->count; i++) { Lisp_Object block_name = HASH_KEY (ht, i); @@ -4397,6 +4421,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CHECK_STRING (filename); Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + comp.func_relocs_local = NULL; + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); From dcfd367d282ab37f00373a424fd193022a8f4bf6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 4 Dec 2020 22:05:20 +0100 Subject: [PATCH 1182/1452] * Fix `load-history' causing a number of spurious compiler warnings * src/comp.c (Fcomp__register_subr): Fix missing entry into `load-history' indicating that the loaded function was already an autoload. --- src/comp.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/comp.c b/src/comp.c index 590e3307414..1842aeb8393 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5051,6 +5051,9 @@ This gets called by top_level_run during the load phase. */) make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); + if (AUTOLOADP (XSYMBOL (name)->u.s.function)) + /* Remember that the function was already an autoload. */ + LOADHIST_ATTACH (Fcons (Qt, name)); LOADHIST_ATTACH (Fcons (Qdefun, name)); { /* Handle automatic advice activation (bug#42038). From 39bdb3f6f54cdba80f1efbecab4bbb08428e7cc8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 4 Dec 2020 22:31:36 +0100 Subject: [PATCH 1183/1452] Vanilla build warning clean-up * lisp/emacs-lisp/disass.el (native-comp-unit-file) (subr-native-comp-unit): Declare function. * lisp/progmodes/elisp-mode.el (native-compile): Likewise. * lisp/emacs-lisp/package.el (comp-el-to-eln-filename): Likewise. * lisp/startup.el (normal-top-level): Silence warning. * src/data.c (syms_of_data): 'Ssubr_native_lambda_list' is always defined. * src/pdumper.c (dump_cold_native_subr): Move under ifdefs. (dump_drain_cold_data): Add ifdefs. --- lisp/emacs-lisp/disass.el | 3 ++- lisp/emacs-lisp/package.el | 1 + lisp/progmodes/elisp-mode.el | 1 + lisp/startup.el | 1 + src/data.c | 2 +- src/pdumper.c | 4 ++++ 6 files changed, 10 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 7e7db7b441d..7fb370f5df5 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -75,7 +75,8 @@ redefine OBJECT if it is a symbol." (disassemble-internal object indent nil))) nil) - +(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) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0ee2e58d528..e980f8841e0 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2221,6 +2221,7 @@ If some packages are not installed propose to install them." (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 diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index dac3aaf2a53..13bba7f77a8 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -203,6 +203,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (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. diff --git a/lisp/startup.el b/lisp/startup.el index 2beeaa195d0..f9de7fa94f6 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -535,6 +535,7 @@ It is the default value of the variable `top-level'." (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) (when (featurep 'nativecomp) + (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env (dolist (path (split-string path-env ":")) diff --git a/src/data.c b/src/data.c index 1435cb03779..fea39867c99 100644 --- a/src/data.c +++ b/src/data.c @@ -4055,8 +4055,8 @@ syms_of_data (void) defsubr (&Ssubr_arity); defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); -#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_lambda_list); +#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); diff --git a/src/pdumper.c b/src/pdumper.c index 1a7aee6343a..b3abbd66f0c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3405,6 +3405,7 @@ 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) { @@ -3425,6 +3426,7 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) 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) @@ -3469,9 +3471,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 (); } From eb8d15547bfc0821232af12c1ce193e40cdf16c0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 4 Dec 2020 22:45:59 +0100 Subject: [PATCH 1184/1452] * Do not compile `comp-cstr.el` in vanilla builds * lisp/Makefile.in (compile-targets): Filter out 'comp-cstr.elc' in vanilla builds. --- lisp/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 5fec921b072..c6a1799e368 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -342,7 +342,7 @@ compile-first: $(COMPILE_FIRST) # 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.elc,$(TARGETS)) +compile-targets: $(filter-out ./emacs-lisp/comp-cstr.elc,$(filter-out ./emacs-lisp/comp.elc,$(TARGETS))) else compile-targets: $(TARGETS) endif From 9b85ae6aa5d73649c0a48d5168d4de52ee83ac28 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 2 Dec 2020 21:44:00 +0100 Subject: [PATCH 1185/1452] Initial constraint negation support * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Add `neg' slot. (comp-range-negation, comp-cstr-negation) (comp-cstr-negation-make): New functions. (comp-type-spec-to-cstr): Enable `not` in type specifiers. (comp-cstr-to-type-spec): Update logic to handle negation. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. --- lisp/emacs-lisp/comp-cstr.el | 65 ++++++++++++++++++------- test/lisp/emacs-lisp/comp-cstr-tests.el | 3 +- 2 files changed, 50 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 40fa48ee8e1..dcf835bb7b1 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -66,7 +66,9 @@ Each element cannot be a subtype of any other element of this slot.") :documentation "List of possible values the mvar can assume. Integer values are handled in the `range' slot.") (range () :type list - :documentation "Integer interval.")) + :documentation "Integer interval.") + (neg nil :type boolean + :documentation "Non-nil if the constraint is negated")) (cl-defstruct comp-cstr-f "Internal constraint representation for a function." @@ -235,6 +237,20 @@ Integer values are handled in the `range' slot.") (cl-decf nest) finally (cl-return (reverse res)))) +(defun comp-range-negation (range) + "Negate range RANGE." + (cl-loop + with res = () + with last-h = '- + for (l . h) in range + unless (eq l '-) + do (push `(,(comp-range-1+ last-h) . ,(1- l)) res) + do (setf last-h h) + finally + (unless (eq '+ last-h) + (push `(,(1+ last-h) . +) res)) + (cl-return (reverse res)))) + ;;; Entry points. @@ -332,6 +348,19 @@ DST is returned." "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) +(defun comp-cstr-negation (dst src) + "Negate SRC setting the result in DST. +DST is returned." + (setf (comp-cstr-typeset dst) (comp-cstr-typeset src) + (comp-cstr-valset dst) (comp-cstr-valset src) + (comp-cstr-range dst) (comp-cstr-range src) + (comp-cstr-neg dst) (not (comp-cstr-neg src))) + dst) + +(defun comp-cstr-negation-make (src) + "Negate SRC and return a new constraint." + (comp-cstr-negation (make-comp-cstr) src)) + (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." @@ -356,10 +385,7 @@ FN non-nil indicates we are parsing a function lambda list." (apply #'comp-cstr-intersection-make (mapcar #'comp-type-spec-to-cstr rest))) (`(not ,cstr) - (cl-assert nil) - ;; TODO - ;; (comp-cstr-negate-make (comp-type-spec-to-cstr cstr)) - ) + (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) (comp-irange-to-cstr `(,l . ,h))) (`(integer * ,(and (pred integerp) h)) @@ -383,7 +409,8 @@ FN non-nil indicates we are parsing a function lambda list." "Given CSTR return its type specifier." (let ((valset (comp-cstr-valset cstr)) (typeset (comp-cstr-typeset cstr)) - (range (comp-cstr-range cstr))) + (range (comp-cstr-range cstr)) + (negated (comp-cstr-neg cstr))) (when valset (when (memq nil valset) @@ -412,17 +439,21 @@ FN non-nil indicates we are parsing a function lambda list." (valset `(member ,@valset)) (t ;; Empty type specifier - nil)))) - (pcase res - (`(,(or 'integer 'member) . ,rest) - (if rest - res - (car res))) - ((pred atom) res) - (`(,_first . ,rest) - (if rest - `(or ,@res) - (car res))))))) + nil))) + (final + (pcase res + (`(,(or 'integer 'member) . ,rest) + (if rest + res + (car res))) + ((pred atom) res) + (`(,_first . ,rest) + (if rest + `(or ,@res) + (car res)))))) + (if negated + `(not ,final) + final)))) (provide 'comp-cstr) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index c98ff80cd72..541533601b1 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -77,7 +77,8 @@ ((and (integer -1 2) (integer 3 5)) . nil) ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) - ((and (integer -1 5) nil) . nil)) + ((and (integer -1 5) nil) . nil) + ((not symbol) . (not symbol))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From 1fb249f6db1ae87ee3ddd221ab9c8d152951efe7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 2 Dec 2020 22:45:00 +0100 Subject: [PATCH 1186/1452] * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-no-range): Cosmetic. --- lisp/emacs-lisp/comp-cstr.el | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index dcf835bb7b1..6397bccdae5 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -256,26 +256,26 @@ Integer values are handled in the `range' slot.") (defun comp-cstr-union-no-range (dst &rest srcs) "As `comp-cstr-union' but escluding the irange component." - (let ((values (mapcar #'comp-cstr-valset srcs))) - ;; Type propagation. - (setf (comp-cstr-typeset dst) - (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) - ;; Value propagation. - (setf (comp-cstr-valset dst) - (cl-loop - ;; TODO sort. - for v in (cl-remove-duplicates (apply #'append values) - :test #'equal) - ;; We propagate only values those types are not already - ;; into typeset. - when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) - (comp-cstr-typeset dst)) - collect v)) + ;; Value propagation. + (setf (comp-cstr-valset dst) + (cl-loop + with values = (mapcar #'comp-cstr-valset srcs) + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v)) - dst)) + dst) (defun comp-cstr-union (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. From 7c1d90a41df8792f7311f0ec5a33c613f08ac4ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 2 Dec 2020 22:47:00 +0100 Subject: [PATCH 1187/1452] Initial support for union of negated constraints * lisp/emacs-lisp/comp-cstr.el (comp-range-negation): New function. (comp-cstr-union-homogeneous-no-range): Rename from `comp-cstr-union-no-range'. (comp-cstr-union-homogeneous): Rename from `comp-cstr-union'. (comp-cstr-union-1): New function. (comp-cstr-union-no-range, comp-cstr-union): Rewrite in function of `comp-cstr-union-1'. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a bunch of tests. --- lisp/emacs-lisp/comp-cstr.el | 133 +++++++++++++++++++++--- test/lisp/emacs-lisp/comp-cstr-tests.el | 9 +- 2 files changed, 126 insertions(+), 16 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6397bccdae5..a1809967075 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -239,23 +239,26 @@ Integer values are handled in the `range' slot.") (defun comp-range-negation (range) "Negate range RANGE." - (cl-loop - with res = () - with last-h = '- - for (l . h) in range - unless (eq l '-) + (if (null range) + '((- . +)) + (cl-loop + with res = () + with last-h = '- + for (l . h) in range + unless (eq l '-) do (push `(,(comp-range-1+ last-h) . ,(1- l)) res) - do (setf last-h h) - finally - (unless (eq '+ last-h) - (push `(,(1+ last-h) . +) res)) - (cl-return (reverse res)))) + do (setf last-h h) + finally + (unless (eq '+ last-h) + (push `(,(1+ last-h) . +) res)) + (cl-return (reverse res))))) -;;; Entry points. +;;; Union specific code. -(defun comp-cstr-union-no-range (dst &rest srcs) - "As `comp-cstr-union' but escluding the irange component." +(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs) + "As `comp-cstr-union' but escluding the irange component. +All SRCS constraints must be homogeneously negated or non-negated." ;; Type propagation. (setf (comp-cstr-typeset dst) @@ -277,10 +280,11 @@ Integer values are handled in the `range' slot.") dst) -(defun comp-cstr-union (dst &rest srcs) +(defun comp-cstr-union-homogeneous (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. +All SRCS constraints must be homogeneously negated or non-negated. DST is returned." - (apply #'comp-cstr-union-no-range dst srcs) + (apply #'comp-cstr-union-homogeneous-no-range dst srcs) ;; Range propagation. (setf (comp-cstr-range dst) (when (cl-notany (lambda (x) @@ -291,6 +295,105 @@ DST is returned." (mapcar #'comp-cstr-range srcs)))) dst) +(cl-defun comp-cstr-union-1 (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +DST is returned." + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (cl-loop + for cstr in srcs + unless (comp-cstr-neg cstr) + count t into n-pos + else + count t into n-neg + finally + (when (or (zerop n-pos) (zerop n-neg)) + (apply #'comp-cstr-union-homogeneous dst srcs) + (cl-return-from comp-cstr-union-1 dst))) + + ;; Some are negated and some are not + (cl-loop + for cstr in srcs + if (comp-cstr-neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally + (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) + + ;; Type propagation. + (when (and (comp-cstr-typeset pos) + ;; When some pos type is not a subtype of any neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (comp-subtype-p x y))) + (comp-cstr-typeset neg))) + (comp-cstr-typeset pos))) + ;; This is a conservative choice, ATM we can't represent such a + ;; disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' list them all. This probably wouldn't + ;; work for the future when we'll support also non-builtin + ;; types. + (setf (comp-cstr-typeset dst) '(t) + (comp-cstr-valset dst) () + (comp-cstr-range dst) () + (comp-cstr-neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + + ;; Value propagation. + (setf (comp-cstr-valset neg) + (cl-nset-difference (comp-cstr-valset neg) (comp-cstr-valset pos))) + + ;; Range propagation + (when (and range + (or (comp-cstr-range pos) + (comp-cstr-range neg)) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-cstr-typeset pos))) + (if (or (comp-cstr-valset neg) + (comp-cstr-typeset neg)) + (setf (comp-cstr-range neg) + (comp-range-union (comp-range-negation (comp-cstr-range pos)) + (comp-cstr-range neg))) + ;; When possibile do not return a negated cstr. + (setf (comp-cstr-typeset dst) () + (comp-cstr-valset dst) () + (comp-cstr-range dst) (comp-range-union + (comp-range-negation (comp-cstr-range neg)) + (comp-cstr-range pos)) + (comp-cstr-neg dst) nil) + (cl-return-from comp-cstr-union-1 dst))) + + (if (and (null (comp-cstr-typeset neg)) + (null (comp-cstr-valset neg)) + (null (comp-cstr-range neg))) + (setf (comp-cstr-typeset dst) '(t) + (comp-cstr-valset dst) () + (comp-cstr-range dst) () + (comp-cstr-neg dst) nil) + (setf (comp-cstr-typeset dst) (comp-cstr-typeset neg) + (comp-cstr-valset dst) (comp-cstr-valset neg) + (comp-cstr-range dst) (comp-cstr-range neg) + (comp-cstr-neg dst) t)))) + dst) + + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + (defun comp-cstr-union-make (&rest srcs) "Combine SRCS by union set operation and return a new constraint." (apply #'comp-cstr-union (make-comp-cstr) srcs)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 541533601b1..5c119c6ba3e 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -78,7 +78,14 @@ ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) ((and (integer -1 5) nil) . nil) - ((not symbol) . (not symbol))) + ((not symbol) . (not symbol)) + ((or (member foo) (not (member foo bar))) . (not (member bar))) + ((or (member foo bar) (not (member foo))) . t) + ;; Intentionally conservative, see `comp-cstr-union'. + ((or symbol (not sequence)) . t) + ((or vector (not sequence)) . (not sequence)) + ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From cbbdb4e1993ffa0f9e467d8c2a6f86403bb6d675 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 2 Dec 2020 23:48:00 +0100 Subject: [PATCH 1188/1452] * Add `with-comp-cstr-accessors' macro. * lisp/emacs-lisp/comp-cstr.el (with-comp-cstr-accessors): New macro. (comp-cstr-union-1): Make use of `with-comp-cstr-accessors'. --- lisp/emacs-lisp/comp-cstr.el | 165 +++++++++++++++++++---------------- 1 file changed, 90 insertions(+), 75 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index a1809967075..96aa67ec9d7 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -86,6 +86,20 @@ Integer values are handled in the `range' slot.") :documentation "Serve memoization for `comp-common-supertype'.")) +(defmacro with-comp-cstr-accessors (&rest body) + "Define some quick accessor to reduce code vergosity in BODY." + (declare (debug (form body)) + (indent defun)) + `(cl-macrolet ((typeset (&rest x) + `(comp-cstr-typeset ,@x)) + (valset (&rest x) + `(comp-cstr-valset ,@x)) + (range (&rest x) + `(comp-cstr-range ,@x)) + (neg (&rest x) + `(comp-cstr-neg ,@x))) + ,@body)) + ;;; Type handling. @@ -299,86 +313,87 @@ DST is returned." "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. DST is returned." - ;; Check first if we are in the simple case of all input non-negate - ;; or negated so we don't have to cons. - (cl-loop - for cstr in srcs - unless (comp-cstr-neg cstr) - count t into n-pos - else - count t into n-neg - finally - (when (or (zerop n-pos) (zerop n-neg)) - (apply #'comp-cstr-union-homogeneous dst srcs) - (cl-return-from comp-cstr-union-1 dst))) + (with-comp-cstr-accessors + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (cl-loop + for cstr in srcs + unless (neg cstr) + count t into n-pos + else + count t into n-neg + finally + (when (or (zerop n-pos) (zerop n-neg)) + (apply #'comp-cstr-union-homogeneous dst srcs) + (cl-return-from comp-cstr-union-1 dst))) - ;; Some are negated and some are not - (cl-loop - for cstr in srcs - if (comp-cstr-neg cstr) - collect cstr into negatives - else - collect cstr into positives - finally - (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) - (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) + ;; Some are negated and some are not + (cl-loop + for cstr in srcs + if (neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally + (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) - ;; Type propagation. - (when (and (comp-cstr-typeset pos) - ;; When some pos type is not a subtype of any neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (not (comp-subtype-p x y))) - (comp-cstr-typeset neg))) - (comp-cstr-typeset pos))) - ;; This is a conservative choice, ATM we can't represent such a - ;; disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' list them all. This probably wouldn't - ;; work for the future when we'll support also non-builtin - ;; types. - (setf (comp-cstr-typeset dst) '(t) - (comp-cstr-valset dst) () - (comp-cstr-range dst) () - (comp-cstr-neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + ;; Type propagation. + (when (and (typeset pos) + ;; When some pos type is not a subtype of any neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (comp-subtype-p x y))) + (typeset neg))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such a + ;; disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' list them all. This probably wouldn't + ;; work for the future when we'll support also non-builtin + ;; types. + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) - ;; Value propagation. - (setf (comp-cstr-valset neg) - (cl-nset-difference (comp-cstr-valset neg) (comp-cstr-valset pos))) + ;; Value propagation. + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))) - ;; Range propagation - (when (and range - (or (comp-cstr-range pos) - (comp-cstr-range neg)) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (comp-cstr-typeset pos))) - (if (or (comp-cstr-valset neg) - (comp-cstr-typeset neg)) - (setf (comp-cstr-range neg) - (comp-range-union (comp-range-negation (comp-cstr-range pos)) - (comp-cstr-range neg))) - ;; When possibile do not return a negated cstr. - (setf (comp-cstr-typeset dst) () - (comp-cstr-valset dst) () - (comp-cstr-range dst) (comp-range-union - (comp-range-negation (comp-cstr-range neg)) - (comp-cstr-range pos)) - (comp-cstr-neg dst) nil) - (cl-return-from comp-cstr-union-1 dst))) + ;; Range propagation + (when (and range + (or (range pos) + (range neg)) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (typeset pos))) + (if (or (valset neg) + (typeset neg)) + (setf (range neg) + (comp-range-union (comp-range-negation (range pos)) + (range neg))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) () + (valset dst) () + (range dst) (comp-range-union + (comp-range-negation (range neg)) + (range pos)) + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst))) - (if (and (null (comp-cstr-typeset neg)) - (null (comp-cstr-valset neg)) - (null (comp-cstr-range neg))) - (setf (comp-cstr-typeset dst) '(t) - (comp-cstr-valset dst) () - (comp-cstr-range dst) () - (comp-cstr-neg dst) nil) - (setf (comp-cstr-typeset dst) (comp-cstr-typeset neg) - (comp-cstr-valset dst) (comp-cstr-valset neg) - (comp-cstr-range dst) (comp-cstr-range neg) - (comp-cstr-neg dst) t)))) - dst) + (if (and (null (typeset neg)) + (null (valset neg)) + (null (range neg))) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t)))) + dst)) ;;; Entry points. From 726e40fb7c0eb50e6afe831997da445c32872eed Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 2 Dec 2020 23:49:00 +0100 Subject: [PATCH 1189/1452] Fix union of homogeneously negated input constraints * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1): Fix logic. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a couple of tests. --- lisp/emacs-lisp/comp-cstr.el | 2 ++ test/lisp/emacs-lisp/comp-cstr-tests.el | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 96aa67ec9d7..3aad3dc2c24 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -325,6 +325,8 @@ DST is returned." finally (when (or (zerop n-pos) (zerop n-neg)) (apply #'comp-cstr-union-homogeneous dst srcs) + (when (zerop n-pos) + (setf (neg dst) t)) (cl-return-from comp-cstr-union-1 dst))) ;; Some are negated and some are not diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 5c119c6ba3e..0b10b7f80a1 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -85,7 +85,9 @@ ((or symbol (not sequence)) . t) ((or vector (not sequence)) . (not sequence)) ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) - ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *))) + ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or symbol (not (member foo))) . (not (member foo))) + ((or (not symbol) (not (member foo))) . (not symbol))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From f923de6853a4958f1e50afef683f95ea5fcd31a1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Dec 2020 17:59:00 +0100 Subject: [PATCH 1190/1452] * Fix `comp-cstr-to-type-spec' * lisp/emacs-lisp/comp-cstr.el (comp-star-or-num-p): New predicate. (comp-type-spec-to-cstr): Make use of. (comp-cstr-to-type-spec): Output correctly type specifiers as (not (or integer ... --- lisp/emacs-lisp/comp-cstr.el | 85 +++++++++++++++++++----------------- 1 file changed, 44 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3aad3dc2c24..5a45294ed80 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -175,6 +175,9 @@ Integer values are handled in the `range' slot.") ;;; Integer range handling +(defsubst comp-star-or-num-p (x) + (or (numberp x) (eq '* x))) + (defsubst comp-range-1+ (x) (if (symbolp x) x @@ -484,46 +487,44 @@ DST is returned." (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." - (cl-flet ((star-or-num (x) - (or (numberp x) (eq '* x)))) - (pcase type-spec - ((and (or '&optional '&rest) x) - (if fn - x - (error "Invalid `%s` in type specifier" x))) - ('fixnum - (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) - ('boolean - (comp-type-spec-to-cstr '(member t nil))) - ('null (comp-value-to-cstr nil)) - ((pred atom) - (comp-type-to-cstr type-spec)) - (`(or . ,rest) - (apply #'comp-cstr-union-make - (mapcar #'comp-type-spec-to-cstr rest))) - (`(and . ,rest) - (apply #'comp-cstr-intersection-make - (mapcar #'comp-type-spec-to-cstr rest))) - (`(not ,cstr) - (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) - (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) - (comp-irange-to-cstr `(,l . ,h))) - (`(integer * ,(and (pred integerp) h)) - (comp-irange-to-cstr `(- . ,h))) - (`(integer ,(and (pred integerp) l) *) - (comp-irange-to-cstr `(,l . +))) - (`(float ,(pred star-or-num) ,(pred star-or-num)) - ;; No float range support :/ - (comp-type-to-cstr 'float)) - (`(member . ,rest) - (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) - (`(function ,args ,ret) - (make-comp-cstr-f - :args (mapcar (lambda (x) - (comp-type-spec-to-cstr x t)) - args) - :ret (comp-type-spec-to-cstr ret))) - (_ (error "Invalid type specifier"))))) + (pcase type-spec + ((and (or '&optional '&rest) x) + (if fn + x + (error "Invalid `%s` in type specifier" x))) + ('fixnum + (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + ('boolean + (comp-type-spec-to-cstr '(member t nil))) + ('null (comp-value-to-cstr nil)) + ((pred atom) + (comp-type-to-cstr type-spec)) + (`(or . ,rest) + (apply #'comp-cstr-union-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(and . ,rest) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(not ,cstr) + (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) + (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) + (comp-irange-to-cstr `(,l . ,h))) + (`(integer * ,(and (pred integerp) h)) + (comp-irange-to-cstr `(- . ,h))) + (`(integer ,(and (pred integerp) l) *) + (comp-irange-to-cstr `(,l . +))) + (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p)) + ;; No float range support :/ + (comp-type-to-cstr 'float)) + (`(member . ,rest) + (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (`(function ,args ,ret) + (make-comp-cstr-f + :args (mapcar (lambda (x) + (comp-type-spec-to-cstr x t)) + args) + :ret (comp-type-spec-to-cstr ret))) + (_ (error "Invalid type specifier")))) (defun comp-cstr-to-type-spec (cstr) "Given CSTR return its type specifier." @@ -562,7 +563,9 @@ FN non-nil indicates we are parsing a function lambda list." nil))) (final (pcase res - (`(,(or 'integer 'member) . ,rest) + ((or `(member . ,rest) + `(integer ,(pred comp-star-or-num-p) + ,(pred comp-star-or-num-p))) (if rest res (car res))) From 2eb41ec137839d06a856e1f910dfa5d2fa97e451 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 2 Dec 2020 23:51:19 +0100 Subject: [PATCH 1191/1452] More improvements to `comp-cstr-union-1' for mixed positive/negative cases * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1): Better handle mixed positive/negated cases. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a number of tests. --- lisp/emacs-lisp/comp-cstr.el | 88 +++++++++++++++---------- test/lisp/emacs-lisp/comp-cstr-tests.el | 15 ++++- 2 files changed, 67 insertions(+), 36 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5a45294ed80..c0e6a57f4dc 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -340,22 +340,27 @@ DST is returned." else collect cstr into positives finally - (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) - (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We use neg as result as *most* of times this will be + ;; negated. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) ;; Type propagation. (when (and (typeset pos) - ;; When some pos type is not a subtype of any neg ones. + ;; When every pos type is not a subtype of some neg ones. (cl-every (lambda (x) (cl-some (lambda (y) - (not (comp-subtype-p x y))) + (not (and (not (eq x y)) + (comp-subtype-p x y)))) (typeset neg))) (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such a - ;; disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' list them all. This probably wouldn't - ;; work for the future when we'll support also non-builtin - ;; types. + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. (setf (typeset dst) '(t) (valset dst) () (range dst) () @@ -363,41 +368,56 @@ DST is returned." (cl-return-from comp-cstr-union-1 dst)) ;; Value propagation. - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))) + (cond + ((and (valset pos) (valset neg) + (equal (cl-union (valset pos) (valset neg)) (valset pos))) + ;; Pos is a superset of neg. + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) ;; Range propagation - (when (and range - (or (range pos) - (range neg)) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (typeset pos))) - (if (or (valset neg) - (typeset neg)) - (setf (range neg) - (comp-range-union (comp-range-negation (range pos)) - (range neg))) - ;; When possibile do not return a negated cstr. - (setf (typeset dst) () - (valset dst) () - (range dst) (comp-range-union - (comp-range-negation (range neg)) - (range pos)) - (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst))) + (if (and range + (or (range pos) + (range neg)) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (typeset pos))) + (if (or (valset neg) + (typeset neg)) + (setf (range neg) + (if (memq 'integer (typeset neg)) + (comp-range-negation (range pos)) + (comp-range-negation + (comp-range-union (range pos) + (comp-range-negation (range neg)))))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (comp-range-union + (comp-range-negation (range neg)) + (range pos)) + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + (setf (range neg) ())) (if (and (null (typeset neg)) (null (valset neg)) (null (range neg))) - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) (neg dst) nil) (setf (typeset dst) (typeset neg) (valset dst) (valset neg) (range dst) (range neg) - (neg dst) t)))) + (neg dst) (neg neg))))) dst)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 0b10b7f80a1..bc772fcb0d2 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -83,11 +83,22 @@ ((or (member foo bar) (not (member foo))) . t) ;; Intentionally conservative, see `comp-cstr-union'. ((or symbol (not sequence)) . t) + ((or symbol (not symbol)) . t) + ;; Conservative. + ((or symbol (not sequence)) . t) ((or vector (not sequence)) . (not sequence)) ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) - ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 *))) + ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) ((or symbol (not (member foo))) . (not (member foo))) - ((or (not symbol) (not (member foo))) . (not symbol))) + ((or (not symbol) (not (member foo))) . (not symbol)) + ;; Conservative. + ((or (not (member foo)) string) . (not (member foo))) + ;; Conservative. + ((or (member foo) (not string)) . (not string)) + ((or (not (integer 1 2)) integer) . integer) + ((or (not (integer 1 2)) (not integer)) . (not integer)) + ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *))))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From 09ec39e35213f92ce297dfed7a42af56b5e2b693 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Dec 2020 19:36:00 +0100 Subject: [PATCH 1192/1452] * Memoize `comp-cstr-union-1' * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Do not synthesize the copier. (comp-cstr-ctxt): Add `union-1-mem-no-range' `union-1-mem-range' slots. (comp-cstr-copy): New function. (comp-cstr-union-1-no-mem): Rename from `comp-cstr-union-1'. (comp-cstr-union-1): New function. --- lisp/emacs-lisp/comp-cstr.el | 49 ++++++++++++++++++++++++++++++------ 1 file changed, 42 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c0e6a57f4dc..bb63ff3e961 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -57,7 +57,8 @@ (:constructor comp-irange-to-cstr (irange &aux (range (list irange)) - (typeset ())))) + (typeset ()))) + (:copier nil)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -84,7 +85,13 @@ Integer values are handled in the `range' slot.") ;; TODO we should be able to just cons hash this. (common-supertype-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-common-supertype'.")) +`comp-common-supertype'.") + (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-cstr-union-1'.") + (union-1-mem-range (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-cstr-union-1'.")) (defmacro with-comp-cstr-accessors (&rest body) "Define some quick accessor to reduce code vergosity in BODY." @@ -100,6 +107,14 @@ Integer values are handled in the `range' slot.") `(comp-cstr-neg ,@x))) ,@body)) +(defun comp-cstr-copy (cstr) + "Return a deep copy of CSTR." + (with-comp-cstr-accessors + (make-comp-cstr :typeset (copy-tree (typeset cstr)) + :valset (copy-tree (valset cstr)) + :range (copy-tree (range cstr)) + :neg (copy-tree (neg cstr))))) + ;;; Type handling. @@ -312,9 +327,10 @@ DST is returned." (mapcar #'comp-cstr-range srcs)))) dst) -(cl-defun comp-cstr-union-1 (range dst &rest srcs) +(cl-defun comp-cstr-union-1-no-mem (range dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. +Non memoized version of `comp-cstr-union-1'. DST is returned." (with-comp-cstr-accessors ;; Check first if we are in the simple case of all input non-negate @@ -330,7 +346,7 @@ DST is returned." (apply #'comp-cstr-union-homogeneous dst srcs) (when (zerop n-pos) (setf (neg dst) t)) - (cl-return-from comp-cstr-union-1 dst))) + (cl-return-from comp-cstr-union-1-no-mem dst))) ;; Some are negated and some are not (cl-loop @@ -365,7 +381,7 @@ DST is returned." (valset dst) () (range dst) () (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Value propagation. (cond @@ -376,7 +392,7 @@ DST is returned." (valset dst) () (range dst) () (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + (cl-return-from comp-cstr-union-1-no-mem dst)) (t ;; pos is a subset or eq to neg (setf (valset neg) @@ -404,7 +420,7 @@ DST is returned." (comp-range-negation (range neg)) (range pos)) (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + (cl-return-from comp-cstr-union-1-no-mem dst)) (setf (range neg) ())) (if (and (null (typeset neg)) @@ -420,6 +436,25 @@ DST is returned." (neg dst) (neg neg))))) dst)) +(defun comp-cstr-union-1 (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +DST is returned." + (let ((mem-h (if range + (comp-cstr-ctxt-union-1-mem-range comp-ctxt) + (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))) + (with-comp-cstr-accessors + (if-let ((mem-res (gethash srcs mem-h))) + (progn + (setf (typeset dst) (typeset mem-res) + (valset dst) (valset mem-res) + (range dst) (range mem-res) + (neg dst) (neg mem-res)) + mem-res) + (let ((res (apply #'comp-cstr-union-1-no-mem range dst srcs))) + (puthash srcs (comp-cstr-copy res) mem-h) + res))))) + ;;; Entry points. From ac40a60696322cd92f37fcddda97ae9c00226bf8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 5 Dec 2020 23:42:25 +0100 Subject: [PATCH 1193/1452] Couple of `comp-cstr-union-1-no-mem' improvements for mixed neg pos union * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Generalize disjoint pos types vs neg values conditions. (comp-cstr-union-1-no-mem): Do not propagate ranges when we are already returning integer as generic type. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add corresponding tests. --- lisp/emacs-lisp/comp-cstr.el | 32 ++++++++++++++++++------- test/lisp/emacs-lisp/comp-cstr-tests.el | 7 ++++-- 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index bb63ff3e961..d4e47cf302f 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -383,6 +383,23 @@ DST is returned." (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + ;; Value propagation. (cond ((and (valset pos) (valset neg) @@ -401,12 +418,8 @@ DST is returned." ;; Range propagation (if (and range (or (range pos) - (range neg)) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (typeset pos))) - (if (or (valset neg) - (typeset neg)) + (range neg))) + (if (or (valset neg) (typeset neg)) (setf (range neg) (if (memq 'integer (typeset neg)) (comp-range-negation (range pos)) @@ -416,9 +429,10 @@ DST is returned." ;; When possibile do not return a negated cstr. (setf (typeset dst) (typeset pos) (valset dst) (valset pos) - (range dst) (comp-range-union - (comp-range-negation (range neg)) - (range pos)) + (range dst) (unless (memq 'integer (typeset dst)) + (comp-range-union + (comp-range-negation (range neg)) + (range pos))) (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) (setf (range neg) ())) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index bc772fcb0d2..6e1d0d463e1 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -81,7 +81,7 @@ ((not symbol) . (not symbol)) ((or (member foo) (not (member foo bar))) . (not (member bar))) ((or (member foo bar) (not (member foo))) . t) - ;; Intentionally conservative, see `comp-cstr-union'. + ;; Intentionally conservative, see `comp-cstr-union-1-no-mem'. ((or symbol (not sequence)) . t) ((or symbol (not symbol)) . t) ;; Conservative. @@ -98,7 +98,10 @@ ((or (member foo) (not string)) . (not string)) ((or (not (integer 1 2)) integer) . integer) ((or (not (integer 1 2)) (not integer)) . (not integer)) - ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *))))) + ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *)))) + ((or number (not (integer 1 2))) . t) + ((or atom (not (integer 1 2))) . t) + ((or atom (not (member foo))) . t)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From 27f666e111a34d64de81a214024e1e30928b416e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Dec 2020 18:01:28 +0100 Subject: [PATCH 1194/1452] * Unify common fallback exit point in `comp-cstr-union-1-no-mem'. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Define a local function `give-up' as a common fall-back exit point. --- lisp/emacs-lisp/comp-cstr.el | 208 +++++++++++++++++------------------ 1 file changed, 101 insertions(+), 107 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d4e47cf302f..892a8d349d9 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -333,121 +333,115 @@ Do range propagation when RANGE is non-nil. Non memoized version of `comp-cstr-union-1'. DST is returned." (with-comp-cstr-accessors - ;; Check first if we are in the simple case of all input non-negate - ;; or negated so we don't have to cons. - (cl-loop - for cstr in srcs - unless (neg cstr) - count t into n-pos - else - count t into n-neg - finally - (when (or (zerop n-pos) (zerop n-neg)) - (apply #'comp-cstr-union-homogeneous dst srcs) - (when (zerop n-pos) - (setf (neg dst) t)) - (cl-return-from comp-cstr-union-1-no-mem dst))) + (cl-flet ((give-up () + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) - ;; Some are negated and some are not - (cl-loop - for cstr in srcs - if (neg cstr) - collect cstr into negatives - else - collect cstr into positives - finally - (let* ((pos (apply #'comp-cstr-union-homogeneous - (make-comp-cstr) positives)) - ;; We use neg as result as *most* of times this will be - ;; negated. - (neg (apply #'comp-cstr-union-homogeneous - (make-comp-cstr :neg t) negatives))) + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (cl-loop + for cstr in srcs + unless (neg cstr) + count t into n-pos + else + count t into n-neg + finally + (when (or (zerop n-pos) (zerop n-neg)) + (apply #'comp-cstr-union-homogeneous dst srcs) + (when (zerop n-pos) + (setf (neg dst) t)) + (cl-return-from comp-cstr-union-1-no-mem dst))) - ;; Type propagation. - (when (and (typeset pos) - ;; When every pos type is not a subtype of some neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (not (and (not (eq x y)) - (comp-subtype-p x y)))) - (typeset neg))) - (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such - ;; a disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' or adopt something like - ;; `intersection-type' `union-type' in SBCL. Keep it - ;; "simple" for now. - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) + ;; Some are negated and some are not + (cl-loop + for cstr in srcs + if (neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We use neg as result as *most* of times this will be + ;; negated. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is not a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (and (not (eq x y)) + (comp-subtype-p x y)))) + (typeset neg))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) - ;; Verify disjoint condition between positive types and - ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) - (when (range neg) - '(integer))))) - (when (cl-some (lambda (x) - (cl-some (lambda (y) - (and (not (eq y x)) - (comp-subtype-p y x))) - neg-value-types)) - (typeset pos)) - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst))) + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) - ;; Value propagation. - (cond - ((and (valset pos) (valset neg) - (equal (cl-union (valset pos) (valset neg)) (valset pos))) - ;; Pos is a superset of neg. - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (t - ;; pos is a subset or eq to neg - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))))) + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (cl-union (valset pos) (valset neg)) (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) - ;; Range propagation - (if (and range - (or (range pos) - (range neg))) - (if (or (valset neg) (typeset neg)) - (setf (range neg) - (if (memq 'integer (typeset neg)) - (comp-range-negation (range pos)) - (comp-range-negation - (comp-range-union (range pos) - (comp-range-negation (range neg)))))) - ;; When possibile do not return a negated cstr. + ;; Range propagation + (if (and range + (or (range pos) + (range neg))) + (if (or (valset neg) (typeset neg)) + (setf (range neg) + (if (memq 'integer (typeset neg)) + (comp-range-negation (range pos)) + (comp-range-negation + (comp-range-union (range pos) + (comp-range-negation (range neg)))))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (unless (memq 'integer (typeset dst)) + (comp-range-union + (comp-range-negation (range neg)) + (range pos))) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + (setf (range neg) ())) + + (if (and (null (typeset neg)) + (null (valset neg)) + (null (range neg))) (setf (typeset dst) (typeset pos) (valset dst) (valset pos) - (range dst) (unless (memq 'integer (typeset dst)) - (comp-range-union - (comp-range-negation (range neg)) - (range pos))) + (range dst) (range pos) (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (setf (range neg) ())) - - (if (and (null (typeset neg)) - (null (valset neg)) - (null (range neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg))))) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg)))))) dst)) (defun comp-cstr-union-1 (range dst &rest srcs) From be907b0ba82c2a65e0468d50653cae8a7cf5f16b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 7 Dec 2020 12:22:48 +0100 Subject: [PATCH 1195/1452] * Spawn a sub-process for running GCC also in batch mode (bug#45056) * lisp/emacs-lisp/comp.el (comp-async-compilation): New variable. (comp-final): Always run the C side of the compilation as a sub-process unless during bootstrap or async compilation. (comp-run-async-workers): Set `comp-async-compilation'. --- lisp/emacs-lisp/comp.el | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 13f9beb5f96..339fff7aa17 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2805,11 +2805,18 @@ Prepare every function for final compilation and drive the C back-end." (and (comp--release-ctxt) compile-result)))) +(defvar comp-async-compilation nil + "Non-nil while executing an asyncronous native compilation.") + (defun comp-final (_) "Final pass driving the C back-end for code emission." (maphash #'comp-ret-type-spec (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run - (if noninteractive + ;; Always run the C side of the compilation as a sub-process + ;; unless during bootstrap or async compilation (bug#45056). GCC + ;; leaks memory but also interfere with the ability of Emacs to + ;; detect when a sub-process completes (TODO understand why). + (if (or byte-native-for-bootstrap comp-async-compilation) (comp-final1) ;; Call comp-final1 in a child process. (let* ((output (comp-ctxt-output comp-ctxt)) @@ -3073,6 +3080,7 @@ display a message." (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose + comp-async-compilation t comp-eln-load-path ',comp-eln-load-path comp-native-driver-options ',comp-native-driver-options From c39fad909cf9720626d310618cfdeae2ccf330ba Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 12 Dec 2020 16:26:17 +0100 Subject: [PATCH 1196/1452] * test/src/comp-tests.el (comp-tests-bootstrap): Temp fix bootstrap test. --- test/src/comp-tests.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c2af52e4cab..e73fc652d62 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -56,8 +56,9 @@ "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." :tags '(:expensive-test :nativecomp) - (let* ((comp-src (concat comp-test-directory - "../../lisp/emacs-lisp/comp.el")) + (let* ((byte-native-for-bootstrap t) ; FIXME HACK + (comp-src (concat comp-test-directory + "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) (comp2-src (make-temp-file "stage2-" nil ".el")) ;; Can't use debug symbols. From 73b5e40750afa19299435f980a959fea57f9641b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 7 Dec 2020 21:33:11 +0100 Subject: [PATCH 1197/1452] * Code rework add `comp-cstrs-homogeneous' * lisp/emacs-lisp/comp-cstr.el (comp-cstrs-homogeneous): New function. (comp-cstr-union-1-no-mem): Make use of. --- lisp/emacs-lisp/comp-cstr.el | 31 +++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 892a8d349d9..9182fc3f221 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -115,6 +115,21 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (copy-tree (neg cstr))))) +(defun comp-cstrs-homogeneous (cstrs) + "Check if constraints CSTRS are all homogeneously negated or non-negated. +Return `pos' if they are all positive, `neg' if they are all +negated or nil othewise." + (cl-loop + for cstr in cstrs + unless (comp-cstr-neg cstr) + count t into n-pos + else + count t into n-neg + finally + (cond + ((zerop n-neg) (cl-return 'pos)) + ((zerop n-pos) (cl-return 'neg))))) + ;;; Type handling. @@ -342,18 +357,10 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. - (cl-loop - for cstr in srcs - unless (neg cstr) - count t into n-pos - else - count t into n-neg - finally - (when (or (zerop n-pos) (zerop n-neg)) - (apply #'comp-cstr-union-homogeneous dst srcs) - (when (zerop n-pos) - (setf (neg dst) t)) - (cl-return-from comp-cstr-union-1-no-mem dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-union-homogeneous dst srcs) + (setf (neg dst) (eq res 'neg)) + (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not (cl-loop From 725c7e1416872f199bf544486fc20243a5ada2db Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 7 Dec 2020 21:41:49 +0100 Subject: [PATCH 1198/1452] * Enumerate type specifier tests to ease debugging * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Enumerate tests. Acked-by: Andrea Corallo --- test/lisp/emacs-lisp/comp-cstr-tests.el | 66 ++++++++++++++++++++++--- 1 file changed, 60 insertions(+), 6 deletions(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 6e1d0d463e1..0c1d27e4d17 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -40,67 +40,121 @@ ',expected-type-spec)))) (defconst comp-cstr-typespec-tests-alist - `((symbol . symbol) + `(;; 1 + (symbol . symbol) + ;; 2 ((or string array) . array) + ;; 3 ((or symbol number) . (or symbol number)) + ;; 4 ((or cons atom) . (or cons atom)) ;; SBCL return T + ;; 5 ((or integer number) . number) + ;; 6 ((or (or integer symbol) number) . (or symbol number)) + ;; 7 ((or (or integer symbol) (or number list)) . (or list symbol number)) + ;; 8 ((or (or integer number) nil) . number) + ;; 9 ((member foo) . (member foo)) + ;; 10 ((member foo bar) . (member foo bar)) + ;; 11 ((or (member foo) (member bar)) . (member foo bar)) + ;; 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)) . (member 2)) + ;; 32 ((and number (integer 1 2)) . number) + ;; 33 ((and integer (integer 1 2)) . integer) + ;; 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) - ;; Intentionally conservative, see `comp-cstr-union-1-no-mem'. + ;; 42 Intentionally conservative, see `comp-cstr-union-1-no-mem'. ((or symbol (not sequence)) . t) + ;; 43 ((or symbol (not symbol)) . t) - ;; Conservative. + ;; 44 Conservative. ((or symbol (not sequence)) . t) + ;; 45 ((or vector (not sequence)) . (not sequence)) + ;; 46 ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ;; 47 ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 *))) + ;; 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)) - ;; Conservative. + ;; 51 Conservative. ((or (not (member foo)) string) . (not (member foo))) - ;; Conservative. + ;; 52 Conservative. ((or (member foo) (not string)) . (not string)) + ;; 53 ((or (not (integer 1 2)) integer) . integer) + ;; 54 ((or (not (integer 1 2)) (not integer)) . (not integer)) + ;; 55 ((or (integer 1 2) (not integer)) . (not (or integer (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)) "Alist type specifier -> expected type specifier.") @@ -108,7 +162,7 @@ "Generate all tests from `comp-cstr-typespec-tests-alist'." `(progn ,@(cl-loop - for i from 0 + for i from 1 for (ts . exp-ts) in comp-cstr-typespec-tests-alist append (list (comp-cstr-typespec-test i ts exp-ts))))) From a6295d31501a539f3071678e8229a014a037438e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 10 Dec 2020 18:25:51 +0100 Subject: [PATCH 1199/1452] * Add `comp-split-pos-neg' function * lisp/emacs-lisp/comp-cstr.el (comp-split-pos-neg): New function. (comp-cstr-union-1-no-mem): Update to call `comp-split-pos-neg'. --- lisp/emacs-lisp/comp-cstr.el | 169 ++++++++++++++++++----------------- 1 file changed, 87 insertions(+), 82 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 9182fc3f221..7a55b884773 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -130,6 +130,17 @@ negated or nil othewise." ((zerop n-neg) (cl-return 'pos)) ((zerop n-pos) (cl-return 'neg))))) +(defun comp-split-pos-neg (cstrs) + "Split constraints CSTRS into non-negated and negated. +Return them as multiple value." + (cl-loop + for cstr in cstrs + if (comp-cstr-neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally (cl-return (cl-values positives negatives)))) + ;;; Type handling. @@ -363,92 +374,86 @@ DST is returned." (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not - (cl-loop - for cstr in srcs - if (neg cstr) - collect cstr into negatives - else - collect cstr into positives - finally - (let* ((pos (apply #'comp-cstr-union-homogeneous - (make-comp-cstr) positives)) - ;; We use neg as result as *most* of times this will be - ;; negated. - (neg (apply #'comp-cstr-union-homogeneous - (make-comp-cstr :neg t) negatives))) - ;; Type propagation. - (when (and (typeset pos) - ;; When every pos type is not a subtype of some neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (not (and (not (eq x y)) - (comp-subtype-p x y)))) - (typeset neg))) - (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such - ;; a disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' or adopt something like - ;; `intersection-type' `union-type' in SBCL. Keep it - ;; "simple" for now. - (give-up)) + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We use neg as result as *most* of times this will be + ;; negated. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is not a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (and (not (eq x y)) + (comp-subtype-p x y)))) + (typeset neg))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) - ;; Verify disjoint condition between positive types and - ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) - (when (range neg) - '(integer))))) - (when (cl-some (lambda (x) - (cl-some (lambda (y) - (and (not (eq y x)) - (comp-subtype-p y x))) - neg-value-types)) - (typeset pos)) - (give-up))) + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) - ;; Value propagation. - (cond - ((and (valset pos) (valset neg) - (equal (cl-union (valset pos) (valset neg)) (valset pos))) - ;; Pos is a superset of neg. - (give-up)) - (t - ;; pos is a subset or eq to neg - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))))) + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (cl-union (valset pos) (valset neg)) (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) - ;; Range propagation - (if (and range - (or (range pos) - (range neg))) - (if (or (valset neg) (typeset neg)) - (setf (range neg) - (if (memq 'integer (typeset neg)) - (comp-range-negation (range pos)) - (comp-range-negation - (comp-range-union (range pos) - (comp-range-negation (range neg)))))) - ;; When possibile do not return a negated cstr. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (unless (memq 'integer (typeset dst)) - (comp-range-union - (comp-range-negation (range neg)) - (range pos))) - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (setf (range neg) ())) + ;; Range propagation + (if (and range + (or (range pos) + (range neg))) + (if (or (valset neg) (typeset neg)) + (setf (range neg) + (if (memq 'integer (typeset neg)) + (comp-range-negation (range pos)) + (comp-range-negation + (comp-range-union (range pos) + (comp-range-negation (range neg)))))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (unless (memq 'integer (typeset dst)) + (comp-range-union + (comp-range-negation (range neg)) + (range pos))) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + (setf (range neg) ())) - (if (and (null (typeset neg)) - (null (valset neg)) - (null (range neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg)))))) + (if (and (null (typeset neg)) + (null (valset neg)) + (null (range neg))) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg)))))) dst)) (defun comp-cstr-union-1 (range dst &rest srcs) From 62869453961ec677323ed034465833304686a534 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 12 Dec 2020 10:50:32 +0000 Subject: [PATCH 1200/1452] Normalize cstrs for cache hint effectiveness and test stability * lisp/emacs-lisp/comp-cstr.el (comp-normalize-valset) (comp-union-valsets, comp-intersection-valsets) (comp-normalize-typeset): New functions. (comp-union-typesets, comp-intersect-typesets) (comp-cstr-union-homogeneous-no-range, comp-cstr-union-1-no-mem): Update to return normalized results. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Normalize expected type specifiers. --- lisp/emacs-lisp/comp-cstr.el | 57 ++++++++++++++++++------- test/lisp/emacs-lisp/comp-cstr-tests.el | 12 +++--- 2 files changed, 48 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 7a55b884773..6991c9305f3 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -141,9 +141,34 @@ Return them as multiple value." collect cstr into positives finally (cl-return (cl-values positives negatives)))) + +;;; Value handling. + +(defun comp-normalize-valset (valset) + "Sort VALSET and return it." + (cl-sort valset (lambda (x y) + ;; We might want to use `sxhash-eql' for speed but + ;; this is safer to keep tests stable. + (< (sxhash-equal x) + (sxhash-equal y))))) + +(defun comp-union-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-union valsets))) + +(defun comp-intersection-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-intersection valsets))) + ;;; Type handling. +(defun comp-normalize-typeset (typeset) + "Sort TYPESET and return it." + (cl-sort typeset (lambda (x y) + (string-lessp (symbol-name x) + (symbol-name y))))) + (defun comp-supertypes (type) "Return a list of pairs (supertype . hierarchy-level) for TYPE." (cl-loop @@ -196,8 +221,8 @@ Return them as multiple value." do (setf last x) finally (when last (push last res))) - ;; TODO sort. - finally (cl-return (cl-remove-duplicates res))) + finally (cl-return (comp-normalize-typeset + (cl-remove-duplicates res)))) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) (defun comp-intersect-typesets (&rest typesets) @@ -211,7 +236,7 @@ Return them as multiple value." ((eq st x) (list y)) ((eq st y) (list x))))) ty) - ty))) + (comp-normalize-typeset ty)))) ;;; Integer range handling @@ -324,17 +349,18 @@ All SRCS constraints must be homogeneously negated or non-negated." ;; Value propagation. (setf (comp-cstr-valset dst) - (cl-loop - with values = (mapcar #'comp-cstr-valset srcs) - ;; TODO sort. - for v in (cl-remove-duplicates (apply #'append values) - :test #'equal) - ;; We propagate only values those types are not already - ;; into typeset. - when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) - (comp-cstr-typeset dst)) - collect v)) + (comp-normalize-valset + (cl-loop + with values = (mapcar #'comp-cstr-valset srcs) + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v))) dst) @@ -413,7 +439,8 @@ DST is returned." ;; Value propagation. (cond ((and (valset pos) (valset neg) - (equal (cl-union (valset pos) (valset neg)) (valset pos))) + (equal (comp-union-valsets (valset pos) (valset neg)) + (valset pos))) ;; Pos is a superset of neg. (give-up)) (t diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 0c1d27e4d17..392669fba02 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -45,23 +45,23 @@ ;; 2 ((or string array) . array) ;; 3 - ((or symbol number) . (or symbol number)) + ((or symbol number) . (or number symbol)) ;; 4 - ((or cons atom) . (or cons atom)) ;; SBCL return T + ((or cons atom) . (or atom cons)) ;; SBCL return T ;; 5 ((or integer number) . number) ;; 6 - ((or (or integer symbol) number) . (or symbol number)) + ((or (or integer symbol) number) . (or number symbol)) ;; 7 - ((or (or integer symbol) (or number list)) . (or list symbol number)) + ((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 foo bar)) + ((member foo bar) . (member bar foo)) ;; 11 - ((or (member foo) (member bar)) . (member foo bar)) + ((or (member foo) (member bar)) . (member bar foo)) ;; 12 ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) ;; 13 From 0ded37fdadc96e7607e2a13e0fd0990e13f3b0b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 8 Dec 2020 21:24:14 +0100 Subject: [PATCH 1201/1452] * Add initial negated non-negegated intersection support * lisp/emacs-lisp/comp-cstr.el (comp-range-intersection): Cosmetic. (comp-cstr-intersection-homogeneous): Rename from `comp-cstr-intersection'. (comp-cstr-intersection): New function. --- lisp/emacs-lisp/comp-cstr.el | 114 +++++++++++++++++++----- test/lisp/emacs-lisp/comp-cstr-tests.el | 24 ++++- 2 files changed, 116 insertions(+), 22 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6991c9305f3..ba93ee948d8 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -302,11 +302,11 @@ Return them as multiple value." with nest = 0 with low = nil with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) initially (when (cl-some #'null ranges) ;; Intersecting with a null range always results in a ;; null range. (cl-return '())) - for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) if (eq x 'l) do (cl-incf nest) @@ -502,27 +502,9 @@ DST is returned." (puthash srcs (comp-cstr-copy res) mem-h) res))))) - -;;; Entry points. - -(defun comp-cstr-union-no-range (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -Do not propagate the range component. -DST is returned." - (apply #'comp-cstr-union-1 nil dst srcs)) - -(defun comp-cstr-union (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -DST is returned." - (apply #'comp-cstr-union-1 t dst srcs)) - -(defun comp-cstr-union-make (&rest srcs) - "Combine SRCS by union set operation and return a new constraint." - (apply #'comp-cstr-union (make-comp-cstr) srcs)) - -;; TODO memoize -(cl-defun comp-cstr-intersection (dst &rest srcs) +(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. +All SRCS constraints must be homogeneously negated or non-negated. DST is returned." ;; Value propagation. @@ -569,6 +551,96 @@ DST is returned." (mapcar #'comp-cstr-typeset srcs)))) dst) + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(cl-defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (cl-flet ((return-empty () + (setf (typeset dst) () + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-intersection dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-intersection-homogeneous dst srcs) + (setf (neg dst) (eq res 'neg)) + (cl-return-from comp-cstr-intersection dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr :neg t) negatives))) + + ;; In case pos is not relevant return directly the content + ;; of neg. + (when (equal (typeset pos) '(t)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t) + (cl-return-from comp-cstr-intersection dst)) + + (when (cl-some + (lambda (ty) + (memq ty (typeset neg))) + (typeset pos)) + (return-empty)) + + ;; Some negated types are subtypes of some non-negated one. + ;; Transform the corresponding set of types from neg to pos. + (cl-loop + for neg-type in (typeset neg) + do (cl-loop + for pos-type in (copy-sequence (typeset pos)) + when (and (not (eq neg-type pos-type)) + (comp-subtype-p neg-type pos-type)) + do (cl-loop + with found + for (type . _) in (comp-supertypes neg-type) + when found + collect type into res + when (eq type pos-type) + do (setf (typeset pos) (cl-union (typeset pos) res)) + ;; (delq neg-type (typeset neg)) + (cl-return) + when (eq type neg-type) + do (setf found t)))) + + (setf (range pos) + (if (memq 'integer (typeset pos)) + (progn + (setf (typeset pos) (delq 'integer (typeset pos))) + (comp-range-negation (range neg))) + (comp-range-intersection (range pos) + (comp-range-negation (range neg))))) + + ;; Return a non negated form. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil))) + dst))) + (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 392669fba02..bd141e13ad5 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -155,7 +155,29 @@ ;; 57 ((or atom (not (integer 1 2))) . t) ;; 58 - ((or atom (not (member foo))) . t)) + ((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)))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From 5ca371b5011879ad0a3fa8e0c8fae6c3ef8356b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 12 Dec 2020 20:43:04 +0100 Subject: [PATCH 1202/1452] * Memoize `comp-cstr-intersection' * lisp/emacs-lisp/comp-cstr.el (comp-cstr-ctxt): Add new slot `intersection-mem'. (comp-cstr-intersection-homogeneous): Fix non local exit target. (comp-cstr-intersection-no-mem): Rename from `comp-cstr-intersection'. (comp-cstr-intersection): New function. --- lisp/emacs-lisp/comp-cstr.el | 68 +++++++++++++++++++++++------------- 1 file changed, 44 insertions(+), 24 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index ba93ee948d8..6bacd24176d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -91,7 +91,10 @@ Integer values are handled in the `range' slot.") `comp-cstr-union-1'.") (union-1-mem-range (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-cstr-union-1'.")) +`comp-cstr-union-1'.") + (intersection-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`intersection-mem'.")) (defmacro with-comp-cstr-accessors (&rest body) "Define some quick accessor to reduce code vergosity in BODY." @@ -526,7 +529,7 @@ DST is returned." (setf (comp-cstr-valset dst) nil (comp-cstr-range dst) nil (comp-cstr-typeset dst) nil) - (cl-return-from comp-cstr-intersection dst)) + (cl-return-from comp-cstr-intersection-homogeneous dst)) ;; TODO memoize? (setf (comp-cstr-range dst) (apply #'comp-range-intersection @@ -551,26 +554,9 @@ DST is returned." (mapcar #'comp-cstr-typeset srcs)))) dst) - -;;; Entry points. - -(defun comp-cstr-union-no-range (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -Do not propagate the range component. -DST is returned." - (apply #'comp-cstr-union-1 nil dst srcs)) - -(defun comp-cstr-union (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -DST is returned." - (apply #'comp-cstr-union-1 t dst srcs)) - -(defun comp-cstr-union-make (&rest srcs) - "Combine SRCS by union set operation and return a new constraint." - (apply #'comp-cstr-union (make-comp-cstr) srcs)) - -(cl-defun comp-cstr-intersection (dst &rest srcs) +(cl-defun comp-cstr-intersection-no-mem (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. +Non memoized version of `comp-cstr-intersection-no-mem'. DST is returned." (with-comp-cstr-accessors (cl-flet ((return-empty () @@ -578,11 +564,11 @@ DST is returned." (valset dst) () (range dst) () (neg dst) nil) - (cl-return-from comp-cstr-intersection dst))) + (cl-return-from comp-cstr-intersection-no-mem dst))) (when-let ((res (comp-cstrs-homogeneous srcs))) (apply #'comp-cstr-intersection-homogeneous dst srcs) (setf (neg dst) (eq res 'neg)) - (cl-return-from comp-cstr-intersection dst)) + (cl-return-from comp-cstr-intersection-no-mem dst)) ;; Some are negated and some are not (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) @@ -598,7 +584,7 @@ DST is returned." (valset dst) (valset neg) (range dst) (range neg) (neg dst) t) - (cl-return-from comp-cstr-intersection dst)) + (cl-return-from comp-cstr-intersection-no-mem dst)) (when (cl-some (lambda (ty) @@ -641,6 +627,40 @@ DST is returned." (neg dst) nil))) dst))) + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + (let ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))) + (with-comp-cstr-accessors + (if-let ((mem-res (gethash srcs mem-h))) + (progn + (setf (typeset dst) (typeset mem-res) + (valset dst) (valset mem-res) + (range dst) (range mem-res) + (neg dst) (neg mem-res)) + mem-res) + (let ((res (apply #'comp-cstr-intersection-no-mem dst srcs))) + (puthash srcs (comp-cstr-copy res) mem-h) + res))))) + (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) From 258eaddef8979d8ec6decb1ff4b11cab4be05e8b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 12 Dec 2020 20:56:32 +0100 Subject: [PATCH 1203/1452] * Rename comp-cond-rw -> comp-cond-cstr * lisp/emacs-lisp/comp.el (comp-passes) (comp-cond-cstr-target-slot, comp-cond-cstr-func) (comp-cond-cstr): Rename pass from cond-rw to cond-cstr. --- lisp/emacs-lisp/comp.el | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 339fff7aa17..b9a511ab863 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,7 +164,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-fwprop comp-call-optim comp-ipa-pure - comp-cond-rw + comp-cond-cstr comp-fwprop comp-dead-code comp-tco @@ -1849,7 +1849,7 @@ BB-NAME." (comp-block-insns (gethash bb-name (comp-func-blocks comp-func)))) (setf (comp-func-ssa-status comp-func) 'dirty)) -(defun comp-cond-rw-target-slot (slot-num exit-insn bb) +(defun comp-cond-cstr-target-slot (slot-num exit-insn bb) "Search for the last assignment of SLOT-NUM in BB. Keep on searching till EXIT-INSN is encountered. Return the corresponding rhs slot number." @@ -1867,8 +1867,8 @@ Return the corresponding rhs slot number." (setf res rhs))) finally (cl-assert nil)))) -(defun comp-cond-rw-func () - "`comp-cond-rw' worker function for each selected function." +(defun comp-cond-cstr-func () + "`comp-cond-cstr' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1888,15 +1888,15 @@ Return the corresponding rhs slot number." (gethash bb-1 (comp-func-blocks comp-func)))) 1) - (when-let ((target-slot1 (comp-cond-rw-target-slot + (when-let ((target-slot1 (comp-cond-cstr-target-slot (comp-mvar-slot op1) (car insns-seq) b))) (comp-emit-assume target-slot1 op2 bb-1 test-fn)) - (when-let ((target-slot2 (comp-cond-rw-target-slot + (when-let ((target-slot2 (comp-cond-cstr-target-slot (comp-mvar-slot op2) (car insns-seq) b))) (comp-emit-assume target-slot2 op1 bb-1 test-fn))) (cl-return-from in-the-basic-block)))))) -(defun comp-cond-rw (_) +(defun comp-cond-cstr (_) "Rewrite conditional branches adding appropriate 'assume' insns. This is introducing and placing 'assume' insns in use by fwprop to propagate conditional branch test information on target basic @@ -1909,7 +1909,7 @@ blocks." (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-cond-rw-func) + (comp-cond-cstr-func) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) From 682bd303470d4a0fcd2690aff6aa58fb720a8d41 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 12 Dec 2020 22:20:28 +0100 Subject: [PATCH 1204/1452] * Allow for adding constraints targetting blocks with multiple predecessors This commit remove the limitaiton we had not being able to add constraints derived from conditional branches to basic blocks with multiple predecessors. When this condition is verified we add a new dedicated basic block to hold the constraints. * lisp/emacs-lisp/comp.el (comp-block, comp-edge): Better slot type specifiers. (comp-block-cstr): New struct specializing `comp-block'. (make-comp-edge): New function. (comp-func): Better test function + doc for `blocks' slot. (comp-limple-lock-keywords): Update possible basic block names. (comp-emit-assume): Recive directly the block instead of its name. (comp-add-new-block-beetween): New function. (comp-cond-cstr-target-block): Logic update and use `comp-add-new-block-beetween'. (comp-cond-cstr-func): Make use of the latter. (comp-compute-edges): Make use of `make-comp-edge'. --- lisp/emacs-lisp/comp.el | 195 ++++++++++++++++++++++++---------------- 1 file changed, 116 insertions(+), 79 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b9a511ab863..2cff362cb9e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -313,6 +313,9 @@ Useful to hook into pass checkers.") return) "All limple operators.") +(defvar comp-func nil + "Bound to the current function by most passes.") + (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" 'native-compiler-error) @@ -400,13 +403,13 @@ To be used when ncall-conv is nil.")) :documentation "List of incoming edges.") (out-edges () :type list :documentation "List of out-coming edges.") - (dom nil :type comp-block + (dom nil :type (or null comp-block) :documentation "Immediate dominator.") - (df (make-hash-table) :type hash-table + (df (make-hash-table) :type (or null hash-table) :documentation "Dominance frontier set. Block-name -> block") - (post-num nil :type number + (post-num nil :type (or null number) :documentation "Post order number.") - (final-frame nil :type vector + (final-frame nil :type (or null vector) :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) @@ -426,14 +429,26 @@ into it.") (:include comp-block)) "A basic block for a latch loop.") +(cl-defstruct (comp-block-cstr (:copier nil) + (:include comp-block)) + "A basic block holding only constraints.") + (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." - (src nil :type comp-block) - (dst nil :type comp-block) + (src nil :type (or null comp-block)) + (dst nil :type (or null comp-block)) (number nil :type number :documentation "The index number corresponding to this edge in the edge hash.")) +(defun make-comp-edge (&rest args) + "Create a `comp-edge' with basic blocks SRC and DST." + (let ((n (funcall (comp-func-edge-cnt-gen comp-func)))) + (puthash + n + (apply #'make--comp-edge :number n args) + (comp-func-edges-h comp-func)))) + (defun comp-block-preds (basic-block) "Given BASIC-BLOCK return the list of its predecessors." (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) @@ -463,8 +478,8 @@ into it.") Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") (frame-size nil :type number) - (blocks (make-hash-table) :type hash-table - :documentation "Basic block name -> basic block.") + (blocks (make-hash-table :test #'eq) :type hash-table + :documentation "Basic block symbol -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "LAP label -> LIMPLE basic block name.") (edges-h (make-hash-table) :type hash-table @@ -570,9 +585,6 @@ In use by the backend." (cons (comp-mvar-cons-p mvar)) (fixnum (comp-mvar-fixnum-p mvar)))) -;; Special vars used by some passes -(defvar comp-func) - (defun comp-ensure-native-compiler () @@ -650,7 +662,7 @@ Assume allocation class 'd-default as default." (1 font-lock-variable-name-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num) (? "_latch"))))) + (1+ num) (? (or "_latch" "_cstrs")))))) (1 font-lock-constant-face)) (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) @@ -1841,12 +1853,11 @@ into the C code forwarding the compilation unit." ;;; conditional branches rewrite pass specific code. -(defun comp-emit-assume (target-slot rhs bb-name kind) +(defun comp-emit-assume (target-slot rhs bb kind) "Emit an assume of kind KIND for TARGET-SLOT being RHS. -The assume is emitted at the beginning of the block named -BB-NAME." +The assume is emitted at the beginning of the block BB." (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind) - (comp-block-insns (gethash bb-name (comp-func-blocks comp-func)))) + (comp-block-insns bb)) (setf (comp-func-ssa-status comp-func) 'dirty)) (defun comp-cond-cstr-target-slot (slot-num exit-insn bb) @@ -1867,34 +1878,67 @@ Return the corresponding rhs slot number." (setf res rhs))) finally (cl-assert nil)))) +(defun comp-add-new-block-beetween (bb-symbol bb-a bb-b) + "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." + (cl-loop + with new-bb = (make-comp-block-cstr :name bb-symbol + :insns `((jump ,(comp-block-name bb-b)))) + with new-edge = (make-comp-edge :src bb-a :dst new-bb) + for ed in (comp-block-in-edges bb-b) + when (eq (comp-edge-src ed) bb-a) + do + ;; Connect `ed' to `new-bb' and disconnect it from `bb-a'. + (cl-assert (memq ed (comp-block-out-edges bb-a))) + (setf (comp-edge-src ed) new-bb + (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a))) + (push ed (comp-block-out-edges new-bb)) + ;; Connect `bb-a' `new-bb' with `new-edge'. + (push (comp-block-out-edges bb-a) new-edge) + (push (comp-block-in-edges new-bb) new-edge) + (setf (comp-func-ssa-status comp-func) 'dirty) + ;; Add `new-edge' to the current function and return it. + (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) + finally (cl-assert nil))) + +(defun comp-cond-cstr-target-block (curr-bb target-bb-sym) + "Return the appropriate basic block to add constraint assumptions into. +CURR-BB is the current basic block. +TARGET-BB-SYM is the symbol name of the target block." + (let ((target-bb (gethash target-bb-sym + (comp-func-blocks comp-func)))) + (if (= (length (comp-block-in-edges target-bb)) 1) + ;; If block has only one predecessor is already suitable for + ;; adding constraint assumptions. + target-bb + (comp-add-new-block-beetween (intern (concat (symbol-name target-bb-sym) + "_cstrs")) + curr-bb target-bb)))) + (defun comp-cond-cstr-func () "`comp-cond-cstr' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - named in-the-basic-block - for insns-seq on (comp-block-insns b) - do (pcase insns-seq - (`((set ,(and (pred comp-mvar-p) cond) - (,(pred comp-call-op-p) - ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) - (comment ,_comment-str) - (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2)) - ;; FIXME We guard the target block against having more - ;; then one predecessor. The right fix will be to add a - ;; new dedicated basic block for the assumptions so we - ;; can proceed always. - (when (= (length (comp-block-in-edges - (gethash bb-1 - (comp-func-blocks comp-func)))) - 1) - (when-let ((target-slot1 (comp-cond-cstr-target-slot - (comp-mvar-slot op1) (car insns-seq) b))) - (comp-emit-assume target-slot1 op2 bb-1 test-fn)) - (when-let ((target-slot2 (comp-cond-cstr-target-slot - (comp-mvar-slot op2) (car insns-seq) b))) - (comp-emit-assume target-slot2 op1 bb-1 test-fn))) - (cl-return-from in-the-basic-block)))))) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do + (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) cond) + (,(pred comp-call-op-p) + ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) + (comment ,_comment-str) + (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) + (let* ((bb-1 (car blocks)) + (bb-target (comp-cond-cstr-target-block b bb-1))) + (setf (car blocks) (comp-block-name bb-target)) + (when-let ((target-slot1 (comp-cond-cstr-target-slot + (comp-mvar-slot op1) (car insns-seq) b))) + (comp-emit-assume target-slot1 op2 bb-target test-fn)) + (when-let ((target-slot2 (comp-cond-cstr-target-slot + (comp-mvar-slot op2) (car insns-seq) b))) + (comp-emit-assume target-slot2 op1 bb-target test-fn))) + (cl-return-from in-the-basic-block)))))) (defun comp-cond-cstr (_) "Rewrite conditional branches adding appropriate 'assume' insns. @@ -2002,45 +2046,38 @@ blocks." (defun comp-compute-edges () "Compute the basic block edges for the current function." - (cl-flet ((edge-add (&rest args &aux (n (funcall - (comp-func-edge-cnt-gen comp-func)))) - (puthash - n - (apply #'make--comp-edge :number n args) - (comp-func-edges-h comp-func)))) - - (cl-loop with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - for last-insn = (car (last (comp-block-insns bb))) - for (op first second third forth) = last-insn - do (cl-case op - (jump - (edge-add :src bb :dst (gethash first blocks))) - (cond-jump - (edge-add :src bb :dst (gethash third blocks)) - (edge-add :src bb :dst (gethash forth blocks))) - (cond-jump-narg-leq - (edge-add :src bb :dst (gethash second blocks)) - (edge-add :src bb :dst (gethash third blocks))) - (push-handler - (edge-add :src bb :dst (gethash third blocks)) - (edge-add :src bb :dst (gethash forth blocks))) - (return) - (otherwise - (signal 'native-ice - (list "block does not end with a branch" - bb - (comp-func-name comp-func))))) - ;; Update edge refs into blocks. - finally - (cl-loop - for edge being the hash-value in (comp-func-edges-h comp-func) - do - (push edge - (comp-block-out-edges (comp-edge-src edge))) - (push edge - (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func)))) + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first second third forth) = last-insn + do (cl-case op + (jump + (make-comp-edge :src bb :dst (gethash first blocks))) + (cond-jump + (make-comp-edge :src bb :dst (gethash third blocks)) + (make-comp-edge :src bb :dst (gethash forth blocks))) + (cond-jump-narg-leq + (make-comp-edge :src bb :dst (gethash second blocks)) + (make-comp-edge :src bb :dst (gethash third blocks))) + (push-handler + (make-comp-edge :src bb :dst (gethash third blocks)) + (make-comp-edge :src bb :dst (gethash forth blocks))) + (return) + (otherwise + (signal 'native-ice + (list "block does not end with a branch" + bb + (comp-func-name comp-func))))) + ;; Update edge refs into blocks. + finally + (cl-loop + for edge being the hash-value in (comp-func-edges-h comp-func) + do + (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." From 174f2a92ebe4cee9d7a50fb443079636943f7be6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 17 Dec 2020 21:51:22 +0100 Subject: [PATCH 1205/1452] * nt/epaths.nt (PATH_REL_LOADSEARCH): Define macro (bug#45303). --- nt/epaths.nt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/nt/epaths.nt b/nt/epaths.nt index 62e77490634..a61bcb944b8 100644 --- a/nt/epaths.nt +++ b/nt/epaths.nt @@ -49,6 +49,11 @@ along with GNU Emacs. If not, see . */ */ #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: /lisp. From 87f6e937995c433825173fb0473a801791d5beac Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 17 Dec 2020 22:07:39 +0100 Subject: [PATCH 1206/1452] * Makefile.in (w32locallisppath): Add PATH_REL_LOADSEARCH (bug#45303). --- Makefile.in | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.in b/Makefile.in index 027dca0bd70..8a9c23c9013 100644 --- a/Makefile.in +++ b/Makefile.in @@ -403,6 +403,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") && \ From 49f81d6a531283416d3a87e46ee6696eea971b64 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 07:40:24 +0100 Subject: [PATCH 1207/1452] Fix Windows libgccjit library name (bug#45303). * lisp/term/w32-win.el (dynamic-library-alist): Fix Windows libgccjit library name. * src/emacs.c (syms_of_emacs): Likewise. --- lisp/term/w32-win.el | 2 +- src/emacs.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 4ed2710a551..1fcfca5dfdd 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -285,7 +285,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(zlib "zlib1.dll" "libz-1.dll") '(lcms2 "liblcms2-2.dll") '(json "libjansson-4.dll") - '(gccjit "libgccjit.dll"))) + '(gccjit "libgccjit-0.dll"))) ;;; multi-tty support (defvar w32-initialized nil diff --git a/src/emacs.c b/src/emacs.c index afdfcade777..4b3f4c7305a 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3084,10 +3084,10 @@ libraries; only those already known by Emacs will be loaded. */); #ifdef WINDOWSNT /* 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.dll to it. */ + is empty, so add libgccjit-0.dll to it. */ if (will_dump_p ()) Vdynamic_library_alist = list1 (list2 (Qgccjit, - build_string ("libgccjit.dll"))); + build_string ("libgccjit-0.dll"))); else Vdynamic_library_alist = Qnil; #else From eeac3f4db4e3cdd0fc71541c827466927334dce4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 08:34:59 +0100 Subject: [PATCH 1208/1452] * Move diagnostic pragmas out of namespace-scope (bug#45303). Pragmas in GCC don't work reliably within function: * src/comp.c (emit_static_object) (Fcomp_native_driver_options_effective_p) (Fcomp_libgccjit_version): Move pragmas out of name-scope. --- src/comp.c | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1842aeb8393..b52e7e34aea 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2493,6 +2493,7 @@ emit_maybe_gc_or_quit (Lisp_Object insn) /* This is in charge of serializing an object and export a function to retrieve it at load time. */ +#pragma GCC diagnostic ignored "-Waddress" static void emit_static_object (const char *name, Lisp_Object obj) { @@ -2521,9 +2522,7 @@ emit_static_object (const char *name, Lisp_Object obj) #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) \ || defined (WINDOWSNT) -#pragma GCC diagnostic ignored "-Waddress" if (gcc_jit_global_set_initializer) -#pragma GCC diagnostic pop { ptrdiff_t str_size = len + 1; ptrdiff_t size = sizeof (static_obj_t) + str_size; @@ -2682,6 +2681,7 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL); gcc_jit_block_end_with_return (block, NULL, res); } +#pragma GCC diagnostic pop static gcc_jit_rvalue * declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, @@ -4363,6 +4363,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +#pragma GCC diagnostic ignored "-Waddress" DEFUN ("comp-native-driver-options-effective-p", Fcomp_native_driver_options_effective_p, Scomp_native_driver_options_effective_p, @@ -4372,14 +4373,12 @@ DEFUN ("comp-native-driver-options-effective-p", { #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) -#pragma GCC diagnostic ignored "-Waddress" if (gcc_jit_context_add_driver_option) return Qt; -#pragma GCC diagnostic pop #endif return Qnil; } - +#pragma GCC diagnostic pop static void add_driver_options (void) @@ -4526,6 +4525,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return filename; } +#pragma GCC diagnostic ignored "-Waddress" DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, Scomp_libgccjit_version, 0, 0, 0, doc: /* Return libgccjit version in use. @@ -4537,19 +4537,16 @@ unknown (before GCC version 10). */) #if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) load_gccjit_if_necessary (true); - /* FIXME this kludge is quite bad. Can we dynamically load on all - operating systems? */ -#pragma GCC diagnostic ignored "-Waddress" return gcc_jit_version_major ? list3 (make_fixnum (gcc_jit_version_major ()), make_fixnum (gcc_jit_version_minor ()), make_fixnum (gcc_jit_version_patchlevel ())) : Qnil; -#pragma GCC diagnostic pop #else return Qnil; #endif } +#pragma GCC diagnostic pop /******************************************************************************/ From 3b53a591faed03679382a601b93da7fe6ce3b4af Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 08:46:56 +0100 Subject: [PATCH 1209/1452] * Clean-up 'internal_condition_case_4' orphan declaration (bug#45303). * src/lisp.h (internal_condition_case_4): Declaration remove. --- src/lisp.h | 1 - 1 file changed, 1 deletion(-) diff --git a/src/lisp.h b/src/lisp.h index 5900b8d25e4..588316e01b8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4157,7 +4157,6 @@ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); -extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); From 407fb165832341d3dccb78d2782d1790a19c4b9d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 20:45:56 +0100 Subject: [PATCH 1210/1452] * Add 'gcc_jit_type_get_const' to Windows dynamic load machinery (bug#45303). * src/comp.c: Add 'gcc_jit_type_get_const' to windows dynamic load machinery. --- src/comp.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/comp.c b/src/comp.c index b52e7e34aea..f77faaa483e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -102,6 +102,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_rvalue_get_type #undef gcc_jit_struct_as_type #undef gcc_jit_struct_set_fields +#undef gcc_jit_type_get_const #undef gcc_jit_type_get_pointer #undef gcc_jit_version_major #undef gcc_jit_version_minor @@ -208,6 +209,7 @@ DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type, DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue)); DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type, (gcc_jit_struct *struct_type)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_const, (gcc_jit_type *type)); DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); DEF_DLL_FN (void, gcc_jit_block_add_assignment, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, @@ -308,6 +310,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_rvalue_get_type); LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); + LOAD_DLL_FN (library, gcc_jit_type_get_const); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); From ab985f41db5fdaeada513d28a065332fd8838cf4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 21:02:49 +0100 Subject: [PATCH 1211/1452] Add 'internal_condition_case_5' (bug#45303). * src/lisp.h (internal_condition_case_4) (internal_condition_case_5): Declare. * src/eval.c (internal_condition_case_5): New function. * src/comp.c (eln_load_path_final_clean_up): Use 'internal_condition_case_5'. --- src/comp.c | 4 ++-- src/eval.c | 29 +++++++++++++++++++++++++++++ src/lisp.h | 2 ++ 3 files changed, 33 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index f77faaa483e..12c5f1c7e49 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4618,11 +4618,11 @@ eln_load_path_final_clean_up (void) FOR_EACH_TAIL (dir_tail) { Lisp_Object files_in_dir = - internal_condition_case_4 (Fdirectory_files, + internal_condition_case_5 (Fdirectory_files, concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, return_nil); + Qt, return_nil, Qnil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } diff --git a/src/eval.c b/src/eval.c index 2b31b91175b..368fa0944a1 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1534,6 +1534,35 @@ internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, } } +/* 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. */ diff --git a/src/lisp.h b/src/lisp.h index 588316e01b8..923e742eec6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4157,6 +4157,8 @@ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), 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 *)); From 3bb2fd0c58c6caf1772564524c782f8a4a3fb2b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Dec 2020 19:49:10 +0100 Subject: [PATCH 1212/1452] * Fix missing 'gcc_jit_type_get_const' macro definition (bug#45303). * src/comp.c (gcc_jit_type_get_pointer): Define macro. --- src/comp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/comp.c b/src/comp.c index 12c5f1c7e49..139cf86c4a0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -376,6 +376,7 @@ init_gccjit_functions (void) #define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type #define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type #define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields +#define gcc_jit_type_get_const fn_gcc_jit_type_get_const #define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer #define gcc_jit_version_major fn_gcc_jit_version_major #define gcc_jit_version_minor fn_gcc_jit_version_minor From 72c1a41573a96a39482a001bfeb3230c471a5681 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 20 Dec 2020 20:53:22 +0100 Subject: [PATCH 1213/1452] Have native compiler always preserve multibyte strings (bug#45342) * lisp/emacs-lisp/comp.el (comp-final): Escape multibyte string when offloading compilation to child process. * test/src/comp-test-funcs.el (comp-test-45342-f): New function * test/src/comp-tests.el (bug-45342): New test --- lisp/emacs-lisp/comp.el | 1 + test/src/comp-test-funcs.el | 5 +++++ test/src/comp-tests.el | 5 +++++ 3 files changed, 11 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cff362cb9e..c6f192d1e83 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2863,6 +2863,7 @@ Prepare every function for final compilation and drive the C back-end." (print-quoted t) (print-gensym t) (print-circle t) + (print-escape-multibyte t) (expr `(progn (require 'comp) (setf comp-verbose ,comp-verbose diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5fa427be190..5fc032b127d 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -390,6 +390,11 @@ (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 " ➓") (_ ""))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e73fc652d62..68201deffe9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -396,6 +396,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "" (comp-test-44968-f "/tmp/test/foo" "/tmp")) +(comp-deftest bug-45342 () + "Preserve multibyte immediate strings. +" + (should (string= " ➊" (comp-test-45342-f 1)))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." From f4153cac3e0381ea63da2cdccd0ec11c4d54d1ba Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Dec 2020 08:35:30 +0100 Subject: [PATCH 1214/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Fix sigmask store/restore. --- src/comp.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index 139cf86c4a0..84a80eba11e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4458,7 +4458,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.d_ephemeral_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); - sigset_t oldset; ptrdiff_t count = 0; if (!noninteractive) @@ -4472,7 +4471,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, #ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); #endif - pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + pthread_sigmask (SIG_BLOCK, &blocked, &saved_sigset); count = SPECPDL_INDEX (); record_unwind_protect_void (restore_sigmask); } From 2526032ea954671aa48a6ad6d924df2941a8364a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Dec 2020 08:45:53 +0100 Subject: [PATCH 1215/1452] * src/comp.c (eln_load_path_final_clean_up): Fix call arg order (bug#45303). --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 84a80eba11e..8907993dc56 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4622,7 +4622,7 @@ eln_load_path_final_clean_up (void) concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, return_nil, Qnil); + Qt, Qnil, return_nil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } From 5b10a0324d5e5fd975e5833f1a058274780226e2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Dec 2020 10:20:35 +0100 Subject: [PATCH 1216/1452] Fix Windows build link-time zlib error (bug#45303) * src/lisp.h (md5_gz_stream): Declare. * src/comp.c (accumulate_and_process_md5) (final_process_md5, md5_gz_stream): Remove. * src/decompress.c (accumulate_and_process_md5) (final_process_md5, md5_gz_stream): Move from comp.c. --- src/comp.c | 88 ---------------------------------------- src/decompress.c | 102 +++++++++++++++++++++++++++++++++++++++++++++++ src/lisp.h | 4 ++ 3 files changed, 106 insertions(+), 88 deletions(-) diff --git a/src/comp.c b/src/comp.c index 8907993dc56..70f61bfbe1d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -665,94 +665,6 @@ comp_hash_string (Lisp_Object string) return digest; } -#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 I'll not 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; - } -} - -static int -md5_gz_stream (FILE *source, void *resblock) -{ - z_stream stream; - unsigned char in[MD5_BLOCKSIZE]; - unsigned char out[MD5_BLOCKSIZE]; - - 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 - static Lisp_Object comp_hash_source_file (Lisp_Object filename) { diff --git a/src/decompress.c b/src/decompress.c index 8e8f2443111..afd43e13ac6 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "buffer.h" #include "composite.h" +#include "md5.h" #include @@ -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; diff --git a/src/lisp.h b/src/lisp.h index 923e742eec6..7dc517be727 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4720,7 +4720,11 @@ extern void syms_of_lcms2 (void); #endif #ifdef HAVE_ZLIB + +#include + /* Defined in decompress.c. */ +extern int md5_gz_stream (FILE *, void *); extern void syms_of_decompress (void); #endif From 2a117ad3d7204fe40b12cb3ebdc88e18346fb145 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Dec 2020 18:02:19 +0100 Subject: [PATCH 1217/1452] * Add mvar pretty print support when dumping LIMPLE * lisp/emacs-lisp/comp.el (comp-prettyformat-mvar) (comp-prettyformat-insn): New function. (comp-log-func): Update to use `comp-prettyformat-insn'. (comp-finalize-phis): Change LIMPLE phi format to ease `comp-prettyformat-insn' destructuring. --- lisp/emacs-lisp/comp.el | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c6f192d1e83..24955c6a237 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -656,7 +656,7 @@ Assume allocation class 'd-default as default." (defconst comp-limple-lock-keywords `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) - (,(rx "#s(" (group-n 1 "comp-mvar")) + (,(rx "#(" (group-n 1 "mvar")) (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) @@ -715,15 +715,30 @@ log with `comp-log-to-buffer'." (with-selected-window log-window (goto-char (point-max))))))) +(defun comp-prettyformat-mvar (mvar) + (format "#(mvar %s %s %S)" + (comp-mvar-id mvar) + (comp-mvar-slot mvar) + (comp-cstr-to-type-spec mvar))) + +(defun comp-prettyformat-insn (insn) + (cl-typecase insn + (comp-mvar (comp-prettyformat-mvar insn)) + (atom (prin1-to-string insn)) + (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")))) + (defun comp-log-func (func verbosity) "Log function FUNC. VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) - (comp-log (comp-block-insns bb) verbosity t)))) + (cl-loop + for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) + (cl-loop + for insn in (comp-block-insns bb) + do (comp-log (comp-prettyformat-insn insn) verbosity))))) (defun comp-log-edges (func) "Log edges in FUNC." @@ -2286,7 +2301,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (cons (aref in-frame slot-n) + collect (list (aref in-frame slot-n) (comp-block-name b)))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) From bad18f509d87fed8595761c0fabb65804ffcba52 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 13 Dec 2020 12:19:30 +0100 Subject: [PATCH 1218/1452] * Improve comp-fwprop pass Wire-up comp-cstr.el routines in fwprop and constraint mvars also on the else side of branches. * lisp/emacs-lisp/comp.el (comp-emit-assume) (comp-cond-cstr-target-mvar, comp-cond-cstr-func) (comp-fwprop-insn): Logic update. (comp-mvar-value-vld-p, comp-mvar-propagate, comp-fwprop-call): Handle neg slot. --- lisp/emacs-lisp/comp.el | 83 ++++++++++++++++++++++------------------- 1 file changed, 44 insertions(+), 39 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 24955c6a237..a75ca312d2e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -520,7 +520,8 @@ CFG is mutated by a pass.") (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." - (when (null (comp-mvar-typeset mvar)) + (when (and (null (comp-mvar-typeset mvar)) + (null (comp-mvar-neg mvar))) (let* ((v (comp-mvar-valset mvar)) (r (comp-mvar-range mvar)) (valset-len (length v)) @@ -1868,26 +1869,34 @@ into the C code forwarding the compilation unit." ;;; conditional branches rewrite pass specific code. -(defun comp-emit-assume (target-slot rhs bb kind) - "Emit an assume of kind KIND for TARGET-SLOT being RHS. +(defun comp-emit-assume (target rhs bb negated) + "Emit an assume for mvar TARGET being RHS. +When NEGATED is non-nil the assumption is negated. The assume is emitted at the beginning of the block BB." - (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind) - (comp-block-insns bb)) - (setf (comp-func-ssa-status comp-func) 'dirty)) + (let ((target-slot (comp-mvar-slot target)) + (tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot target-slot) (and ,target ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb))) + (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-cond-cstr-target-slot (slot-num exit-insn bb) - "Search for the last assignment of SLOT-NUM in BB. +(defun comp-cond-cstr-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB what we'll use as assume target. Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs slot number." +Return the corresponding rhs mvar." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) - (eql slot-num (comp-mvar-slot x))))) + (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) (cl-loop with res = nil for insn in (comp-block-insns bb) when (eq insn exit-insn) - do (cl-return (and (comp-mvar-p res) (comp-mvar-slot res))) + do (cl-return (and (comp-mvar-p res) res)) do (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) (setf res rhs))) @@ -1941,19 +1950,22 @@ TARGET-BB-SYM is the symbol name of the target block." (pcase insns-seq (`((set ,(and (pred comp-mvar-p) cond) (,(pred comp-call-op-p) - ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) + ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) - (let* ((bb-1 (car blocks)) - (bb-target (comp-cond-cstr-target-block b bb-1))) - (setf (car blocks) (comp-block-name bb-target)) - (when-let ((target-slot1 (comp-cond-cstr-target-slot - (comp-mvar-slot op1) (car insns-seq) b))) - (comp-emit-assume target-slot1 op2 bb-target test-fn)) - (when-let ((target-slot2 (comp-cond-cstr-target-slot - (comp-mvar-slot op2) (car insns-seq) b))) - (comp-emit-assume target-slot2 op1 bb-target test-fn))) - (cl-return-from in-the-basic-block)))))) + (cl-loop + with target-mvar1 = (comp-cond-cstr-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp-cond-cstr-target-mvar op2 (car insns-seq) b) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for assume-target = (comp-cond-cstr-target-block b branch-target) + for negated in '(nil t) + do (setf (car branch-target-cell) (comp-block-name assume-target)) + when target-mvar1 + do (comp-emit-assume target-mvar1 op2 assume-target negated) + when target-mvar2 + do (comp-emit-assume target-mvar2 op1 assume-target negated) + finally (cl-return-from in-the-basic-block))))))) (defun comp-cond-cstr (_) "Rewrite conditional branches adding appropriate 'assume' insns. @@ -2384,7 +2396,8 @@ Forward propagate immediate involed in assignments." "Propagate into LVAL properties of RVAL." (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) (comp-mvar-valset lval) (comp-mvar-valset rval) - (comp-mvar-range lval) (comp-mvar-range rval))) + (comp-mvar-range lval) (comp-mvar-range rval) + (comp-mvar-neg lval) (comp-mvar-neg rval))) (defun comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." @@ -2430,7 +2443,8 @@ Fold the call in case." (let ((cstr (comp-cstr-f-ret cstr-f))) (setf (comp-mvar-range lval) (comp-cstr-range cstr) (comp-mvar-valset lval) (comp-cstr-valset cstr) - (comp-mvar-typeset lval) (comp-cstr-typeset cstr)))))) + (comp-mvar-typeset lval) (comp-cstr-typeset cstr) + (comp-mvar-neg lval) (comp-cstr-neg cstr)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." @@ -2444,21 +2458,12 @@ Fold the call in case." (comp-fwprop-call insn lval f args))) (_ (comp-mvar-propagate lval rval)))) - (`(assume ,lval ,rval ,kind) - (pcase kind - ('eq - (comp-mvar-propagate lval rval)) - ((or 'eql 'equal) - (if (or (comp-mvar-symbol-p rval) - (comp-mvar-fixnum-p rval)) - (comp-mvar-propagate lval rval) - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)))) - ('= - (if (comp-mvar-fixnum-p rval) - (comp-mvar-propagate lval rval) - (setf (comp-mvar-typeset lval) - (unless (comp-mvar-range rval) - '(number))))))) + (`(assume ,lval (,kind . ,operands)) + (cl-ecase kind + (and + (apply #'comp-cstr-intersection lval operands)) + (not + (comp-cstr-negation lval (car operands))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) From a0c0daf7a1059fac432f9507cbd198682d057ee5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 16 Dec 2020 18:40:58 +0100 Subject: [PATCH 1219/1452] * Fix a number of type specifier simplification tests * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Fix a number of tests. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 40 +++++++++++++++++-------- 1 file changed, 28 insertions(+), 12 deletions(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index bd141e13ad5..70c446e9be3 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -103,9 +103,9 @@ ;; 31 ((and (member 1 2) (member 3 2)) . (member 2)) ;; 32 - ((and number (integer 1 2)) . number) + ((and number (integer 1 2)) . (integer 1 2)) ;; 33 - ((and integer (integer 1 2)) . integer) + ((and integer (integer 1 2)) . (integer 1 2)) ;; 34 ((and (integer -1 0) (integer 3 5)) . nil) ;; 35 @@ -122,18 +122,18 @@ ((or (member foo) (not (member foo bar))) . (not (member bar))) ;; 41 ((or (member foo bar) (not (member foo))) . t) - ;; 42 Intentionally conservative, see `comp-cstr-union-1-no-mem'. - ((or symbol (not sequence)) . t) + ;; 42 + ((or symbol (not sequence)) . (not sequence)) ;; 43 ((or symbol (not symbol)) . t) - ;; 44 Conservative. - ((or symbol (not sequence)) . t) - ;; 45 - ((or vector (not sequence)) . (not sequence)) + ;; 44 + ((or symbol (not sequence)) . (not sequence)) + ;; 45 Conservative. + ((or vector (not sequence)) . t) ;; 46 - ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0))) ;; 47 - ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 *))) + ((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 @@ -149,7 +149,7 @@ ;; 54 ((or (not (integer 1 2)) (not integer)) . (not integer)) ;; 55 - ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *)))) + ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *)))) ;; 56 ((or number (not (integer 1 2))) . t) ;; 57 @@ -177,7 +177,23 @@ ;; 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)))) + ((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 b a))) + ;; 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)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From 48d43f579e3d2f7e1423f315d537b51de51ea6a4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 16 Dec 2020 18:41:18 +0100 Subject: [PATCH 1220/1452] * Improve constraint simplification logic in comp-cstr.el * lisp/emacs-lisp/comp-cstr.el (with-comp-cstr-accessors): Simplify. (comp-cstr-empty-p): New Funchion. (comp-split-pos-neg): Minor. (comp-normalize-typeset): Logic update. (comp-union-typesets): Minor. (comp-intersect-two-typesets): New functio. (comp-intersect-typesets): Logic update. (comp-range-union, comp-range-intersection): Minor. (comp-cstr-union-homogeneous, comp-cstr-union-1-no-mem) (comp-cstr-intersection-homogeneous) (comp-cstr-intersection-no-mem, comp-cstr-negation) (comp-type-spec-to-cstr, comp-cstr-to-type-spec): Logic update. * lisp/emacs-lisp/comp-cstr.el (with-comp-cstr-accessors): Simplify. --- lisp/emacs-lisp/comp-cstr.el | 242 +++++++++++++++++++---------------- 1 file changed, 130 insertions(+), 112 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6bacd24176d..3f3f4f61451 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -100,14 +100,14 @@ Integer values are handled in the `range' slot.") "Define some quick accessor to reduce code vergosity in BODY." (declare (debug (form body)) (indent defun)) - `(cl-macrolet ((typeset (&rest x) - `(comp-cstr-typeset ,@x)) - (valset (&rest x) - `(comp-cstr-valset ,@x)) - (range (&rest x) - `(comp-cstr-range ,@x)) - (neg (&rest x) - `(comp-cstr-neg ,@x))) + `(cl-macrolet ((typeset (x) + `(comp-cstr-typeset ,x)) + (valset (x) + `(comp-cstr-valset ,x)) + (range (x) + `(comp-cstr-range ,x)) + (neg (x) + `(comp-cstr-neg ,x))) ,@body)) (defun comp-cstr-copy (cstr) @@ -118,6 +118,13 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (copy-tree (neg cstr))))) +(defsubst comp-cstr-empty-p (cstr) + "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset cstr)) + (null (valset cstr)) + (null (range cstr))))) + (defun comp-cstrs-homogeneous (cstrs) "Check if constraints CSTRS are all homogeneously negated or non-negated. Return `pos' if they are all positive, `neg' if they are all @@ -142,7 +149,7 @@ Return them as multiple value." collect cstr into negatives else collect cstr into positives - finally (cl-return (cl-values positives negatives)))) + finally return (cl-values positives negatives))) ;;; Value handling. @@ -168,9 +175,10 @@ Return them as multiple value." (defun comp-normalize-typeset (typeset) "Sort TYPESET and return it." - (cl-sort typeset (lambda (x y) - (string-lessp (symbol-name x) - (symbol-name y))))) + (cl-sort (cl-remove-duplicates typeset) + (lambda (x y) + (string-lessp (symbol-name x) + (symbol-name y))))) (defun comp-supertypes (type) "Return a list of pairs (supertype . hierarchy-level) for TYPE." @@ -224,22 +232,30 @@ Return them as multiple value." do (setf last x) finally (when last (push last res))) - finally (cl-return (comp-normalize-typeset - (cl-remove-duplicates res)))) + finally return (comp-normalize-typeset res)) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) +(defun comp-intersect-two-typesets (t1 t2) + "Intersect typesets T1 and T2." + (with-comp-cstr-accessors + (cl-loop + for types in (list t1 t2) + for other-types in (list t2 t1) + append + (cl-loop + for type in types + when (cl-some (lambda (x) + (comp-subtype-p type x)) + other-types) + collect type)))) + (defun comp-intersect-typesets (&rest typesets) "Intersect types present into TYPESETS." - (when-let ((ty (apply #'append typesets))) - (if (> (length ty) 1) - (cl-reduce - (lambda (x y) - (let ((st (comp-common-supertype-2 x y))) - (cond - ((eq st x) (list y)) - ((eq st y) (list x))))) - ty) - (comp-normalize-typeset ty)))) + (unless (cl-some #'null typesets) + (if (= (length typesets) 1) + (car typesets) + (comp-normalize-typeset + (cl-reduce #'comp-intersect-two-typesets typesets))))) ;;; Integer range handling @@ -289,7 +305,7 @@ Return them as multiple value." (when (= nest 1) (push `(,(comp-range-1+ low) . ,i) res)) (cl-decf nest) - finally (cl-return (reverse res)))) + finally return (reverse res))) (defun comp-range-intersection (&rest ranges) "Combine integer intervals RANGES by intersecting." @@ -321,7 +337,7 @@ Return them as multiple value." (push `(,low . ,i) res)) (cl-decf nest) - finally (cl-return (reverse res)))) + finally return (reverse res))) (defun comp-range-negation (range) "Negate range RANGE." @@ -373,7 +389,11 @@ All SRCS constraints must be homogeneously negated or non-negated. DST is returned." (apply #'comp-cstr-union-homogeneous-no-range dst srcs) ;; Range propagation. - (setf (comp-cstr-range dst) + (setf (comp-cstr-neg dst) + (when srcs + (comp-cstr-neg (car srcs))) + + (comp-cstr-range dst) (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) (comp-cstr-typeset dst)) @@ -399,25 +419,26 @@ DST is returned." ;; or negated so we don't have to cons. (when-let ((res (comp-cstrs-homogeneous srcs))) (apply #'comp-cstr-union-homogeneous dst srcs) - (setf (neg dst) (eq res 'neg)) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) - ;; We use neg as result as *most* of times this will be - ;; negated. + ;; We'll always use neg as result as this is almost + ;; always necessary for describing open intervals + ;; resulting from negated constraints. (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr :neg t) negatives))) ;; Type propagation. (when (and (typeset pos) - ;; When every pos type is not a subtype of some neg ones. + ;; When every pos type is a subtype of some neg ones. (cl-every (lambda (x) (cl-some (lambda (y) - (not (and (not (eq x y)) - (comp-subtype-p x y)))) - (typeset neg))) + (comp-subtype-p x y)) + (append (typeset neg) + (when (range neg) + '(integer))))) (typeset pos))) ;; This is a conservative choice, ATM we can't represent such ;; a disjoint set of types unless we decide to add a new slot @@ -452,30 +473,14 @@ DST is returned." (cl-nset-difference (valset neg) (valset pos))))) ;; Range propagation - (if (and range - (or (range pos) - (range neg))) - (if (or (valset neg) (typeset neg)) - (setf (range neg) - (if (memq 'integer (typeset neg)) - (comp-range-negation (range pos)) - (comp-range-negation - (comp-range-union (range pos) - (comp-range-negation (range neg)))))) - ;; When possibile do not return a negated cstr. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (unless (memq 'integer (typeset dst)) - (comp-range-union - (comp-range-negation (range neg)) - (range pos))) - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (setf (range neg) ())) + (setf (range neg) + (when range + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos))))) - (if (and (null (typeset neg)) - (null (valset neg)) - (null (range neg))) + (if (comp-cstr-empty-p neg) (setf (typeset dst) (typeset pos) (valset dst) (valset pos) (range dst) (range pos) @@ -510,49 +515,57 @@ DST is returned." All SRCS constraints must be homogeneously negated or non-negated. DST is returned." - ;; Value propagation. - (setf (comp-cstr-valset dst) - ;; TODO sort. - (let ((values (cl-loop for src in srcs - for v = (comp-cstr-valset src) - when v - collect v))) - (when values - (cl-reduce (lambda (x y) - (cl-intersection x y :test #'equal)) - values)))) + (with-comp-cstr-accessors + (when (cl-some #'comp-cstr-empty-p srcs) + (setf (valset dst) nil + (range dst) nil + (typeset dst) nil) + (cl-return-from comp-cstr-intersection-homogeneous dst)) - ;; Range propagation. - (when (cl-some #'identity (mapcar #'comp-cstr-range srcs)) - (if (comp-cstr-valset dst) - (progn - (setf (comp-cstr-valset dst) nil - (comp-cstr-range dst) nil - (comp-cstr-typeset dst) nil) - (cl-return-from comp-cstr-intersection-homogeneous dst)) - ;; TODO memoize? - (setf (comp-cstr-range dst) - (apply #'comp-range-intersection - (mapcar #'comp-cstr-range srcs))))) + (setf (neg dst) (when srcs + (neg (car srcs)))) - ;; Type propagation. - (setf (comp-cstr-typeset dst) - (if (or (comp-cstr-range dst) (comp-cstr-valset dst)) - (cl-loop - with type-val = (cl-remove-duplicates - (append (mapcar #'type-of - (comp-cstr-valset dst)) - (when (comp-cstr-range dst) - '(integer)))) - for type in (apply #'comp-intersect-typesets - (mapcar #'comp-cstr-typeset srcs)) - when (and type (not (member type type-val))) - do (setf (comp-cstr-valset dst) nil - (comp-cstr-range dst) nil) - (cl-return nil)) + ;; Type propagation. + (setf (typeset dst) (apply #'comp-intersect-typesets - (mapcar #'comp-cstr-typeset srcs)))) - dst) + (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (valset dst) + (comp-normalize-valset + (cl-loop + for src in srcs + append + (cl-loop + for val in (valset src) + ;; If (member value) is subtypep of all other sources then + ;; is good to be colleted. + when (cl-every (lambda (s) + (or (memq val (valset s)) + (cl-some (lambda (type) + (cl-typep val type)) + (typeset s)))) + (remq src srcs)) + collect val)))) + + ;; Range propagation. + (setf (range dst) + ;; Do range propagation only if the destination typeset + ;; doesn't cover it already. + (unless (cl-some (lambda (type) + (comp-subtype-p 'integer type)) + (typeset dst)) + (apply #'comp-range-intersection + (cl-loop + for src in srcs + ;; Collect effective ranges. + collect (or (range src) + (when (cl-some (lambda (s) + (comp-subtype-p 'integer s)) + (typeset src)) + '((- . +)))))))) + + dst)) (cl-defun comp-cstr-intersection-no-mem (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. @@ -566,8 +579,9 @@ DST is returned." (neg dst) nil) (cl-return-from comp-cstr-intersection-no-mem dst))) (when-let ((res (comp-cstrs-homogeneous srcs))) - (apply #'comp-cstr-intersection-homogeneous dst srcs) - (setf (neg dst) (eq res 'neg)) + (if (eq res 'neg) + (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-intersection-homogeneous dst srcs)) (cl-return-from comp-cstr-intersection-no-mem dst)) ;; Some are negated and some are not @@ -575,7 +589,7 @@ DST is returned." (let* ((pos (apply #'comp-cstr-intersection-homogeneous (make-comp-cstr) positives)) (neg (apply #'comp-cstr-intersection-homogeneous - (make-comp-cstr :neg t) negatives))) + (make-comp-cstr) negatives))) ;; In case pos is not relevant return directly the content ;; of neg. @@ -613,12 +627,8 @@ DST is returned." do (setf found t)))) (setf (range pos) - (if (memq 'integer (typeset pos)) - (progn - (setf (typeset pos) (delq 'integer (typeset pos))) - (comp-range-negation (range neg))) - (comp-range-intersection (range pos) - (comp-range-negation (range neg))))) + (comp-range-intersection (range pos) + (comp-range-negation (range neg)))) ;; Return a non negated form. (setf (typeset dst) (typeset pos) @@ -668,11 +678,12 @@ DST is returned." (defun comp-cstr-negation (dst src) "Negate SRC setting the result in DST. DST is returned." - (setf (comp-cstr-typeset dst) (comp-cstr-typeset src) - (comp-cstr-valset dst) (comp-cstr-valset src) - (comp-cstr-range dst) (comp-cstr-range src) - (comp-cstr-neg dst) (not (comp-cstr-neg src))) - dst) + (with-comp-cstr-accessors + (setf (typeset dst) (typeset src) + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))) + dst)) (defun comp-cstr-negation-make (src) "Negate SRC and return a new constraint." @@ -686,10 +697,14 @@ FN non-nil indicates we are parsing a function lambda list." (if fn x (error "Invalid `%s` in type specifier" x))) + ('nil + (make-comp-cstr :typeset ())) ('fixnum (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) ('boolean (comp-type-spec-to-cstr '(member t nil))) + ('integer + (comp-irange-to-cstr '(- . +))) ('null (comp-value-to-cstr nil)) ((pred atom) (comp-type-to-cstr type-spec)) @@ -742,7 +757,10 @@ FN non-nil indicates we are parsing a function lambda list." (setf range (cl-loop for (l . h) in range for low = (if (integerp l) l '*) for high = (if (integerp h) h '*) - collect `(integer ,low , high)) + if (and (eq low '*) (eq high '*)) + collect 'integer + else + collect `(integer ,low , high)) valset (cl-remove-duplicates valset)) ;; Form the final type specifier. From 34c1d75a317778df1c09f29f10af207d0f36ad13 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Dec 2020 18:39:34 +0100 Subject: [PATCH 1221/1452] * Enumerate and split type specifier tests in comp-tests.el to ease debug * test/src/comp-tests.el (comp-tests-type-spec-tests): Enumerate. (comp-tests-define-type-spec-test): New function. (comp-tests-define-type-spec-tests): New macro to expand tests. --- test/src/comp-tests.el | 64 +++++++++++++++++++++++++++++++----------- 1 file changed, 47 insertions(+), 17 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 68201deffe9..4ea8dbbadb3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -790,18 +790,23 @@ Return a list of results." (native-compile (cadr func-form)))) (defconst comp-tests-type-spec-tests - `(((defun comp-tests-ret-type-spec-f (x) + `( + ;; 1 + ((defun comp-tests-ret-type-spec-f (x) x) t) + ;; 2 ((defun comp-tests-ret-type-spec-f () 1) (integer 1 1)) + ;; 3 ((defun comp-tests-ret-type-spec-f (x) (if x 1 3)) (or (integer 1 1) (integer 3 3))) + ;; 4 ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x @@ -810,6 +815,7 @@ Return a list of results." y)) (integer 1 2)) + ;; 5 ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x @@ -818,77 +824,90 @@ Return a list of results." y)) (or (integer 1 1) (integer 3 3))) + + ;; 6 ((defun comp-tests-ret-type-spec-f (x) (if x (list x) 3)) (or cons (integer 3 3))) + ;; 7 ((defun comp-tests-ret-type-spec-f (x) (if x 'foo 3)) (or (member foo) (integer 3 3))) + ;; 8 ((defun comp-tests-ret-type-spec-f (x) (if (eq x 3) x 'foo)) (or (member foo) (integer 3 3))) + ;; 9 ((defun comp-tests-ret-type-spec-f (x) (if (eq 3 x) x 'foo)) (or (member foo) (integer 3 3))) + ;; 10 ((defun comp-tests-ret-type-spec-f (x) (if (= x 3) x 'foo)) (or (member foo) (integer 3 3))) + ;; 11 ((defun comp-tests-ret-type-spec-f (x) (if (= 3 x) x 'foo)) (or (member foo) (integer 3 3))) - ;; FIXME would be nice to have (or number (member foo)) + ;; 12 ((defun comp-tests-ret-type-spec-8-3-f (x) (if (= x 3) 'foo x)) - t) + (or (member foo) (integer * 2) (integer 4 *))) + ;; 13 ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) x 'foo)) - (or (member foo) number)) + t) + ;; 14 ((defun comp-tests-ret-type-spec-9-1-f (x) (comp-hint-fixnum x)) (integer ,most-negative-fixnum ,most-positive-fixnum)) + ;; 15 ((defun comp-tests-ret-type-spec-f (x) (comp-hint-cons x)) cons) + ;; 16 ((defun comp-tests-ret-type-spec-f (x) - (let (y) - (when x - (setf y 4)) - y)) + (let (y) + (when x + (setf y 4)) + y)) (or null (integer 4 4))) + ;; 17 ((defun comp-tests-ret-type-spec-f () - (let (x - (y 3)) - (setf x y) - y)) + (let (x + (y 3)) + (setf x y) + y)) (integer 3 3)) + ;; 18 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when x @@ -896,15 +915,26 @@ Return a list of results." y)) t) + ;; 19 ((defun comp-tests-ret-type-spec-f (x y) (eq x y)) boolean))) -(comp-deftest ret-type-spec () - "Some derived return type specifier tests." - (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) - for (func-form type-spec) in comp-tests-type-spec-tests - do (comp-tests-check-ret-type-spec func-form type-spec))) +(defun comp-tests-define-type-spec-test (number x) + `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () + ,(format "Type specifier test number %d." number) + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec ',(car x) ',(cadr x))))) + +(defmacro comp-tests-define-type-spec-tests () + "Define all type specifier tests." + `(progn + ,@(cl-loop + for test in comp-tests-type-spec-tests + for n from 1 + collect (comp-tests-define-type-spec-test n test)))) + +(comp-tests-define-type-spec-tests) (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is From 7074988d13353c544f0a870a8ff3a8deb7b0b8f6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 21 Dec 2020 18:41:13 +0100 Subject: [PATCH 1222/1452] * Add a type specifier test to comp-cstr-tests.el * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 70c446e9be3..03bf78968f2 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -193,7 +193,9 @@ ;; 76 ((and symbol (or number marker)) . nil) ;; 77 - ((and (or symbol string) (or number marker)) . nil)) + ((and (or symbol string) (or number marker)) . nil) + ;; 78 + ((and t t) . t)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From d072ee9d3471772dffc42cd3e33b677c1cfb8965 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 16 Dec 2020 18:37:39 +0100 Subject: [PATCH 1223/1452] * Two minors in comp.el * lisp/emacs-lisp/comp.el (comp-known-func-cstr-h) (comp-ret-type-spec): Style. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a75ca312d2e..750c298a02c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -275,7 +275,7 @@ Useful to hook into pass checkers.") for (f type-spec) in comp-known-type-specifiers for cstr = (comp-type-spec-to-cstr type-spec) do (puthash f cstr h) - finally (cl-return h)) + finally return h) "Hash table function -> `comp-constraint'") (defconst comp-symbol-values-optimizable '(most-positive-fixnum @@ -2761,7 +2761,7 @@ Set it into the `ret-type-specifier' slot." do (pcase insn (`(return ,mvar) (push mvar res)))) - finally (cl-return res))))) + finally return res)))) (setf (comp-func-ret-type-specifier func) (comp-cstr-to-type-spec res-mvar)))) From 02551085c121905146fdb48079f300b3376c5a99 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 15 Dec 2020 16:57:23 +0100 Subject: [PATCH 1224/1452] * Rename comp-cond-cstr into comp-add-cstrs * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs-target-mvar) (comp-add-cond-cstrs, comp-add-cstrs): Rename comp-cond-cstr -> comp-add-cstrs. --- lisp/emacs-lisp/comp.el | 56 +++++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 750c298a02c..8791759aaf5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,7 +164,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-fwprop comp-call-optim comp-ipa-pure - comp-cond-cstr + comp-add-cstrs comp-fwprop comp-dead-code comp-tco @@ -1884,24 +1884,6 @@ The assume is emitted at the beginning of the block BB." (comp-block-insns bb))) (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-cond-cstr-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB what we'll use as assume target. -Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs mvar." - (cl-flet ((targetp (x) - ;; Ret t if x is an mvar and target the correct slot number. - (and (comp-mvar-p x) - (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) - (cl-loop - with res = nil - for insn in (comp-block-insns bb) - when (eq insn exit-insn) - do (cl-return (and (comp-mvar-p res) res)) - do (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) - (setf res rhs))) - finally (cl-assert nil)))) - (defun comp-add-new-block-beetween (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop @@ -1924,7 +1906,25 @@ Return the corresponding rhs mvar." (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) finally (cl-assert nil))) -(defun comp-cond-cstr-target-block (curr-bb target-bb-sym) +(defun comp-add-cond-cstrs-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB what we'll use as assume target. +Keep on searching till EXIT-INSN is encountered. +Return the corresponding rhs mvar." + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) + (cl-loop + with res = nil + for insn in (comp-block-insns bb) + when (eq insn exit-insn) + do (cl-return (and (comp-mvar-p res) res)) + do (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (setf res rhs))) + finally (cl-assert nil)))) + +(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym) "Return the appropriate basic block to add constraint assumptions into. CURR-BB is the current basic block. TARGET-BB-SYM is the symbol name of the target block." @@ -1938,8 +1938,8 @@ TARGET-BB-SYM is the symbol name of the target block." "_cstrs")) curr-bb target-bb)))) -(defun comp-cond-cstr-func () - "`comp-cond-cstr' worker function for each selected function." +(defun comp-add-cond-cstrs () + "`comp-add-cstrs' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do @@ -1954,11 +1954,13 @@ TARGET-BB-SYM is the symbol name of the target block." (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-cond-cstr-target-mvar op1 (car insns-seq) b) - with target-mvar2 = (comp-cond-cstr-target-mvar op2 (car insns-seq) b) + with target-mvar1 = (comp-add-cond-cstrs-target-mvar op1 (car insns-seq) + b) + with target-mvar2 = (comp-add-cond-cstrs-target-mvar op2 (car insns-seq) + b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for assume-target = (comp-cond-cstr-target-block b branch-target) + for assume-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(nil t) do (setf (car branch-target-cell) (comp-block-name assume-target)) when target-mvar1 @@ -1967,7 +1969,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-assume target-mvar2 op1 assume-target negated) finally (cl-return-from in-the-basic-block))))))) -(defun comp-cond-cstr (_) +(defun comp-add-cstrs (_) "Rewrite conditional branches adding appropriate 'assume' insns. This is introducing and placing 'assume' insns in use by fwprop to propagate conditional branch test information on target basic @@ -1980,7 +1982,7 @@ blocks." (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-cond-cstr-func) + (comp-add-cond-cstrs) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) From 23791cf74da9c2e6369f2c15ef180ef2a8c21656 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 15 Dec 2020 17:45:53 +0100 Subject: [PATCH 1225/1452] * Allow for modifying insn-cell inside `comp-loop-insn-in-block' * lisp/emacs-lisp/comp.el (comp-loop-insn-in-block): Update. --- lisp/emacs-lisp/comp.el | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8791759aaf5..e8db2383c41 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -759,14 +759,15 @@ VERBOSITY is a number between 0 and 3." (defmacro comp-loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executing BODY. -Inside BODY `insn' can be used to read or set the current -instruction." +Inside BODY `insn' and `insn-cell'can be used to read or set the +current instruction or its cell." (declare (debug (form body)) (indent defun)) - (let ((sym-cell (gensym "cell-"))) - `(cl-symbol-macrolet ((insn (car ,sym-cell))) - (cl-loop for ,sym-cell on (comp-block-insns ,basic-block) - do ,@body)))) + `(cl-symbol-macrolet ((insn (car insn-cell))) + (let ((insn-cell (comp-block-insns ,basic-block))) + (while insn-cell + ,@body + (setf insn-cell (cdr insn-cell)))))) ;;; spill-lap pass specific code. From 07b75deea9febd2cb6fd4d3467e909df341e96fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 15 Dec 2020 23:53:29 +0100 Subject: [PATCH 1226/1452] Enhance type inference constraining function arguments * lisp/emacs-lisp/comp.el: Add some commentary. (comp-cond-cstrs-target-mvar): Rename and update docstring. (comp-add-cond-cstrs): Update to use `comp-cond-cstrs-target-mvar'. (comp-emit-call-cstr, comp-lambda-list-gen, comp-add-call-cstr): New functions. (comp-add-cstrs): Call `comp-add-call-cstr'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Update two type specifier tests. --- lisp/emacs-lisp/comp.el | 80 ++++++++++++++++++++++++++++++++++++----- test/src/comp-tests.el | 4 +-- 2 files changed, 73 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e8db2383c41..6f1ef26ac78 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1868,7 +1868,19 @@ into the C code forwarding the compilation unit." (comp-add-func-to-ctxt (comp-limplify-top-level t)))) -;;; conditional branches rewrite pass specific code. +;;; add-cstrs pass specific code. + +;; This pass is responsible for adding constraints, these are +;; generated from: +;; +;; - Conditional branches: each branch taken or non taken can be used +;; in the CFG to infer infomations on the tested variables. +;; +;; - Function calls: function calls to function assumed to be not +;; redefinable can be used to add constrains on the function +;; arguments. Ex: if we execute successfully (= x y) we know that +;; afterwards both x and y must satisfy the (or number marker) +;; type specifier. (defun comp-emit-assume (target rhs bb negated) "Emit an assume for mvar TARGET being RHS. @@ -1907,10 +1919,10 @@ The assume is emitted at the beginning of the block BB." (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) finally (cl-assert nil))) -(defun comp-add-cond-cstrs-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB what we'll use as assume target. -Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs mvar." +;; Cheap substitute to a copy propagation pass... +(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB the original mvar MVAR got assigned from. +Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) @@ -1955,10 +1967,8 @@ TARGET-BB-SYM is the symbol name of the target block." (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-add-cond-cstrs-target-mvar op1 (car insns-seq) - b) - with target-mvar2 = (comp-add-cond-cstrs-target-mvar op2 (car insns-seq) - b) + with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for assume-target = (comp-add-cond-cstrs-target-block b branch-target) @@ -1970,6 +1980,57 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-assume target-mvar2 op1 assume-target negated) finally (cl-return-from in-the-basic-block))))))) +(defun comp-emit-call-cstr (mvar call-cell cstr) + "Emit a constraint CSTR for MVAR after CALL-CELL." + (let ((next-cell (cdr call-cell)) + (new-cell `((assume ,(make-comp-mvar :slot (comp-mvar-slot mvar)) + (and ,mvar ,cstr))))) + (setf (cdr call-cell) new-cell + (cdr new-cell) next-cell + (comp-func-ssa-status comp-func) 'dirty))) + +(defun comp-lambda-list-gen (lambda-list) + "Return a generator to iterate over LAMBDA-LIST." + (lambda () + (cl-case (car lambda-list) + (&optional + (setf lambda-list (cdr lambda-list)) + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list)))) + (&rest + (cadr lambda-list)) + (t + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list))))))) + +(defun comp-add-call-cstr () + "Add args assumptions for each function of which the type specifier is known." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + do + (comp-loop-insn-in-block bb + (when-let ((match + (pcase insn + (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values cstr-f lhs args))) + (`(,(pred comp-call-op-p) ,f . ,args) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values cstr-f nil args)))))) + (cl-multiple-value-bind (cstr-f lhs args) match + (cl-loop + for arg in args + for gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) + for cstr = (funcall gen) + for target = (comp-cond-cstrs-target-mvar arg insn bb) + when (and target + (or (null lhs) + (not (eql (comp-mvar-slot lhs) + (comp-mvar-slot target))))) + do (comp-emit-call-cstr target insn-cell cstr))))))) + (defun comp-add-cstrs (_) "Rewrite conditional branches adding appropriate 'assume' insns. This is introducing and placing 'assume' insns in use by fwprop @@ -1984,6 +2045,7 @@ blocks." (not (comp-func-has-non-local f))) (let ((comp-func f)) (comp-add-cond-cstrs) + (comp-add-call-cstr) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4ea8dbbadb3..a3e887bde95 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -872,14 +872,14 @@ Return a list of results." (if (= x 3) 'foo x)) - (or (member foo) (integer * 2) (integer 4 *))) + (or (member foo) marker number)) ;; 13 ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) x 'foo)) - t) + (or (member foo) marker number)) ;; 14 ((defun comp-tests-ret-type-spec-9-1-f (x) From 8e816b0ad574a279b12a4d6622c6f224b67083b8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 17 Dec 2020 18:01:10 +0100 Subject: [PATCH 1227/1452] Symplify type specifier (not t) as nil * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-no-mem): Add logic. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add two tests. --- lisp/emacs-lisp/comp-cstr.el | 9 +++++++++ test/lisp/emacs-lisp/comp-cstr-tests.el | 6 +++++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3f3f4f61451..cd8f432412c 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -598,6 +598,15 @@ DST is returned." (valset dst) (valset neg) (range dst) (range neg) (neg dst) t) + + ;; (not t) => nil + (when (and (null (valset dst)) + (null (range dst)) + (neg dst) + (equal '(t) (typeset dst))) + (setf (typeset dst) () + (neg dst) nil)) + (cl-return-from comp-cstr-intersection-no-mem dst)) (when (cl-some diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 03bf78968f2..f7ea00e86f2 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -195,7 +195,11 @@ ;; 77 ((and (or symbol string) (or number marker)) . nil) ;; 78 - ((and t t) . t)) + ((and t t) . t) + ;; 80 + ((and (or marker number) (integer 0 0)) . (integer 0 0)) + ;; 81 + ((and t (not t)) . nil)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From c70c08013f96438b640e07f884349d9436897252 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 17 Dec 2020 22:31:09 +0100 Subject: [PATCH 1228/1452] * Allow for overlapping src and dst in cstr set operations * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem) (comp-cstr-union-1, comp-cstr-intersection-no-mem) (comp-cstr-intersection): Logic update. --- lisp/emacs-lisp/comp-cstr.el | 360 +++++++++++++++++------------------ 1 file changed, 180 insertions(+), 180 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index cd8f432412c..a1722035963 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -402,113 +402,114 @@ DST is returned." (mapcar #'comp-cstr-range srcs)))) dst) -(cl-defun comp-cstr-union-1-no-mem (range dst &rest srcs) +(cl-defun comp-cstr-union-1-no-mem (range &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. Non memoized version of `comp-cstr-union-1'. DST is returned." (with-comp-cstr-accessors - (cl-flet ((give-up () - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () + (let ((dst (make-comp-cstr))) + (cl-flet ((give-up () + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-union-homogeneous dst srcs) + (cl-return-from comp-cstr-union-1-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We'll always use neg as result as this is almost + ;; always necessary for describing open intervals + ;; resulting from negated constraints. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset neg) + (when (range neg) + '(integer))))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) + + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) + + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (comp-union-valsets (valset pos) (valset neg)) + (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) + + ;; Range propagation + (setf (range neg) + (when range + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos))))) + + (if (comp-cstr-empty-p neg) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst))) - - ;; Check first if we are in the simple case of all input non-negate - ;; or negated so we don't have to cons. - (when-let ((res (comp-cstrs-homogeneous srcs))) - (apply #'comp-cstr-union-homogeneous dst srcs) - (cl-return-from comp-cstr-union-1-no-mem dst)) - - ;; Some are negated and some are not - (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) - (let* ((pos (apply #'comp-cstr-union-homogeneous - (make-comp-cstr) positives)) - ;; We'll always use neg as result as this is almost - ;; always necessary for describing open intervals - ;; resulting from negated constraints. - (neg (apply #'comp-cstr-union-homogeneous - (make-comp-cstr :neg t) negatives))) - ;; Type propagation. - (when (and (typeset pos) - ;; When every pos type is a subtype of some neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (comp-subtype-p x y)) - (append (typeset neg) - (when (range neg) - '(integer))))) - (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such - ;; a disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' or adopt something like - ;; `intersection-type' `union-type' in SBCL. Keep it - ;; "simple" for now. - (give-up)) - - ;; Verify disjoint condition between positive types and - ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) - (when (range neg) - '(integer))))) - (when (cl-some (lambda (x) - (cl-some (lambda (y) - (and (not (eq y x)) - (comp-subtype-p y x))) - neg-value-types)) - (typeset pos)) - (give-up))) - - ;; Value propagation. - (cond - ((and (valset pos) (valset neg) - (equal (comp-union-valsets (valset pos) (valset neg)) - (valset pos))) - ;; Pos is a superset of neg. - (give-up)) - (t - ;; pos is a subset or eq to neg - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))))) - - ;; Range propagation - (setf (range neg) - (when range - (comp-range-negation - (comp-range-union - (comp-range-negation (range neg)) - (range pos))))) - - (if (comp-cstr-empty-p neg) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg)))))) - dst)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg)))))) + dst))) (defun comp-cstr-union-1 (range dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. DST is returned." - (let ((mem-h (if range - (comp-cstr-ctxt-union-1-mem-range comp-ctxt) - (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))) - (with-comp-cstr-accessors - (if-let ((mem-res (gethash srcs mem-h))) - (progn - (setf (typeset dst) (typeset mem-res) - (valset dst) (valset mem-res) - (range dst) (range mem-res) - (neg dst) (neg mem-res)) - mem-res) - (let ((res (apply #'comp-cstr-union-1-no-mem range dst srcs))) - (puthash srcs (comp-cstr-copy res) mem-h) - res))))) + (with-comp-cstr-accessors + (let* ((mem-h (if range + (comp-cstr-ctxt-union-1-mem-range comp-ctxt) + (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))) + (res (or (gethash srcs mem-h) + (puthash + srcs + (apply #'comp-cstr-union-1-no-mem range srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) (cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. @@ -567,84 +568,83 @@ DST is returned." dst)) -(cl-defun comp-cstr-intersection-no-mem (dst &rest srcs) - "Combine SRCS by intersection set operation setting the result in DST. -Non memoized version of `comp-cstr-intersection-no-mem'. -DST is returned." - (with-comp-cstr-accessors - (cl-flet ((return-empty () +(cl-defun comp-cstr-intersection-no-mem (&rest srcs) + "Combine SRCS by intersection set operation. +Non memoized version of `comp-cstr-intersection-no-mem'." + (let ((dst (make-comp-cstr))) + (with-comp-cstr-accessors + (cl-flet ((return-empty () + (setf (typeset dst) () + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-intersection-no-mem dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (if (eq res 'neg) + (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-intersection-homogeneous dst srcs)) + (cl-return-from comp-cstr-intersection-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) negatives))) + + ;; In case pos is not relevant return directly the content + ;; of neg. + (when (equal (typeset pos) '(t)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t) + + ;; (not t) => nil + (when (and (null (valset dst)) + (null (range dst)) + (neg dst) + (equal '(t) (typeset dst))) (setf (typeset dst) () - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-intersection-no-mem dst))) - (when-let ((res (comp-cstrs-homogeneous srcs))) - (if (eq res 'neg) - (apply #'comp-cstr-union-homogeneous dst srcs) - (apply #'comp-cstr-intersection-homogeneous dst srcs)) - (cl-return-from comp-cstr-intersection-no-mem dst)) + (neg dst) nil)) - ;; Some are negated and some are not - (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) - (let* ((pos (apply #'comp-cstr-intersection-homogeneous - (make-comp-cstr) positives)) - (neg (apply #'comp-cstr-intersection-homogeneous - (make-comp-cstr) negatives))) + (cl-return-from comp-cstr-intersection-no-mem dst)) - ;; In case pos is not relevant return directly the content - ;; of neg. - (when (equal (typeset pos) '(t)) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) t) + (when (cl-some + (lambda (ty) + (memq ty (typeset neg))) + (typeset pos)) + (return-empty)) - ;; (not t) => nil - (when (and (null (valset dst)) - (null (range dst)) - (neg dst) - (equal '(t) (typeset dst))) - (setf (typeset dst) () - (neg dst) nil)) + ;; Some negated types are subtypes of some non-negated one. + ;; Transform the corresponding set of types from neg to pos. + (cl-loop + for neg-type in (typeset neg) + do (cl-loop + for pos-type in (copy-sequence (typeset pos)) + when (and (not (eq neg-type pos-type)) + (comp-subtype-p neg-type pos-type)) + do (cl-loop + with found + for (type . _) in (comp-supertypes neg-type) + when found + collect type into res + when (eq type pos-type) + do (setf (typeset pos) (cl-union (typeset pos) res)) + (cl-return) + when (eq type neg-type) + do (setf found t)))) - (cl-return-from comp-cstr-intersection-no-mem dst)) + (setf (range pos) + (comp-range-intersection (range pos) + (comp-range-negation (range neg)))) - (when (cl-some - (lambda (ty) - (memq ty (typeset neg))) - (typeset pos)) - (return-empty)) - - ;; Some negated types are subtypes of some non-negated one. - ;; Transform the corresponding set of types from neg to pos. - (cl-loop - for neg-type in (typeset neg) - do (cl-loop - for pos-type in (copy-sequence (typeset pos)) - when (and (not (eq neg-type pos-type)) - (comp-subtype-p neg-type pos-type)) - do (cl-loop - with found - for (type . _) in (comp-supertypes neg-type) - when found - collect type into res - when (eq type pos-type) - do (setf (typeset pos) (cl-union (typeset pos) res)) - ;; (delq neg-type (typeset neg)) - (cl-return) - when (eq type neg-type) - do (setf found t)))) - - (setf (range pos) - (comp-range-intersection (range pos) - (comp-range-negation (range neg)))) - - ;; Return a non negated form. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil))) - dst))) + ;; Return a non negated form. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil))) + dst)))) ;;; Entry points. @@ -667,18 +667,18 @@ DST is returned." (defun comp-cstr-intersection (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. DST is returned." - (let ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))) - (with-comp-cstr-accessors - (if-let ((mem-res (gethash srcs mem-h))) - (progn - (setf (typeset dst) (typeset mem-res) - (valset dst) (valset mem-res) - (range dst) (range mem-res) - (neg dst) (neg mem-res)) - mem-res) - (let ((res (apply #'comp-cstr-intersection-no-mem dst srcs))) - (puthash srcs (comp-cstr-copy res) mem-h) - res))))) + (with-comp-cstr-accessors + (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt)) + (res (or (gethash srcs mem-h) + (puthash + srcs + (apply #'comp-cstr-intersection-no-mem srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." From 3540b1f167d63e1a38ec0719f909dcda60c77ad3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 17 Dec 2020 17:31:22 +0100 Subject: [PATCH 1229/1452] * Guarantee fwprop convergence and termination * lisp/emacs-lisp/comp.el (comp-emit-call-cstr): Have new-mvar as LHS *and* RHS when constraining in and to ensure monotonicity and fwprop convergence. (comp-fwprop): Raise a warning for debug reasons in case fwprop does not converge within 100 iterations. --- lisp/emacs-lisp/comp.el | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6f1ef26ac78..5d2f8d412fe 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1982,9 +1982,11 @@ TARGET-BB-SYM is the symbol name of the target block." (defun comp-emit-call-cstr (mvar call-cell cstr) "Emit a constraint CSTR for MVAR after CALL-CELL." - (let ((next-cell (cdr call-cell)) - (new-cell `((assume ,(make-comp-mvar :slot (comp-mvar-slot mvar)) - (and ,mvar ,cstr))))) + (let* ((next-cell (cdr call-cell)) + (new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and + ;; fwprop convergence!! + (new-cell `((assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))) (setf (cdr call-cell) new-cell (cdr new-cell) next-cell (comp-func-ssa-status comp-func) 'dirty))) @@ -2568,9 +2570,14 @@ Return t if something was changed." (let ((comp-func f)) (comp-fwprop-prologue) (cl-loop - for i from 1 + for i from 1 to 100 while (comp-fwprop*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) + finally + (when (= i 100) + (display-warning + 'comp + (format "fwprop pass jammed into %s?" (comp-func-name f)))) + (comp-log (format "Propagation run %d times\n" i) 2)) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) From e0f20da6ecd1fceabdce480dd878be293cfba027 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 18 Dec 2020 17:22:05 +0100 Subject: [PATCH 1230/1452] Simplify correctly (or (integer 1 1) (not (integer 1 1))) as t * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Logic update. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. --- lisp/emacs-lisp/comp-cstr.el | 17 +++++++++++------ test/lisp/emacs-lisp/comp-cstr-tests.el | 4 +++- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index a1722035963..22d3958aed3 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -474,12 +474,17 @@ DST is returned." (cl-nset-difference (valset neg) (valset pos))))) ;; Range propagation - (setf (range neg) - (when range - (comp-range-negation - (comp-range-union - (comp-range-negation (range neg)) - (range pos))))) + (when range + ;; Handle apart (or (integer 1 1) (not (integer 1 1))) + ;; like cases. + (if (and (range pos) (range neg) + (equal (range pos) (range neg))) + (give-up) + (setf (range neg) + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos)))))) (if (comp-cstr-empty-p neg) (setf (typeset dst) (typeset pos) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index f7ea00e86f2..b38573ca33a 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -199,7 +199,9 @@ ;; 80 ((and (or marker number) (integer 0 0)) . (integer 0 0)) ;; 81 - ((and t (not t)) . nil)) + ((and t (not t)) . nil) + ;; 82 + ((or (integer 1 1) (not (integer 1 1))) . t)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () From 9bbe6eab6c160a454f2705c00ff3aea7f0c6e6c1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 18 Dec 2020 17:44:49 +0100 Subject: [PATCH 1231/1452] Fix native compiler tests when they are bytecompiled * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-test-ts) (comp-cstr-typespec-test, comp-cstr-typespec-tests-alist): Eval also at compile time. * test/src/comp-tests.el (comp-tests-type-spec-tests) (comp-tests-define-type-spec-test): Likewise. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 346 ++++++++++++------------ test/src/comp-tests.el | 235 ++++++++-------- 2 files changed, 292 insertions(+), 289 deletions(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index b38573ca33a..834f4401d9f 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -29,180 +29,182 @@ (require 'cl-lib) (require 'comp-cstr) -(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)))) +(cl-eval-when (compile eval load) -(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)))) + (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)))) -(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)) . (member 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) . integer) - ;; 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 b a))) - ;; 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)) - "Alist type specifier -> expected type specifier.") + (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)) . (member 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) . integer) + ;; 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 b a))) + ;; 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)) + "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () "Generate all tests from `comp-cstr-typespec-tests-alist'." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a3e887bde95..8e069fb3082 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -789,142 +789,143 @@ Return a list of results." (eval func-form t) (native-compile (cadr func-form)))) -(defconst comp-tests-type-spec-tests - `( - ;; 1 - ((defun comp-tests-ret-type-spec-f (x) - x) - t) +(cl-eval-when (compile eval load) + (defconst comp-tests-type-spec-tests + `( + ;; 1 + ((defun comp-tests-ret-type-spec-f (x) + x) + t) - ;; 2 - ((defun comp-tests-ret-type-spec-f () - 1) - (integer 1 1)) + ;; 2 + ((defun comp-tests-ret-type-spec-f () + 1) + (integer 1 1)) - ;; 3 - ((defun comp-tests-ret-type-spec-f (x) - (if x 1 3)) - (or (integer 1 1) (integer 3 3))) + ;; 3 + ((defun comp-tests-ret-type-spec-f (x) + (if x 1 3)) + (or (integer 1 1) (integer 3 3))) - ;; 4 - ((defun comp-tests-ret-type-spec-f (x) - (let (y) + ;; 4 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 2)) + y)) + (integer 1 2)) + + ;; 5 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 3)) + y)) + (or (integer 1 1) (integer 3 3))) + + + ;; 6 + ((defun comp-tests-ret-type-spec-f (x) (if x - (setf y 1) - (setf y 2)) - y)) - (integer 1 2)) + (list x) + 3)) + (or cons (integer 3 3))) - ;; 5 - ((defun comp-tests-ret-type-spec-f (x) - (let (y) + ;; 7 + ((defun comp-tests-ret-type-spec-f (x) (if x - (setf y 1) - (setf y 3)) - y)) - (or (integer 1 1) (integer 3 3))) + 'foo + 3)) + (or (member foo) (integer 3 3))) + ;; 8 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) - ;; 6 - ((defun comp-tests-ret-type-spec-f (x) - (if x - (list x) - 3)) - (or cons (integer 3 3))) + ;; 9 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) - ;; 7 - ((defun comp-tests-ret-type-spec-f (x) - (if x - 'foo - 3)) - (or (member foo) (integer 3 3))) + ;; 10 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) - ;; 8 - ((defun comp-tests-ret-type-spec-f (x) - (if (eq x 3) - x - 'foo)) - (or (member foo) (integer 3 3))) + ;; 11 + ((defun comp-tests-ret-type-spec-f (x) + (if (= 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) - ;; 9 - ((defun comp-tests-ret-type-spec-f (x) - (if (eq 3 x) - x - 'foo)) - (or (member foo) (integer 3 3))) + ;; 12 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 3) + 'foo + x)) + (or (member foo) marker number)) - ;; 10 - ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) - x - 'foo)) - (or (member foo) (integer 3 3))) + ;; 13 + ((defun comp-tests-ret-type-spec-f (x y) + (if (= x y) + x + 'foo)) + (or (member foo) marker number)) - ;; 11 - ((defun comp-tests-ret-type-spec-f (x) - (if (= 3 x) - x - 'foo)) - (or (member foo) (integer 3 3))) + ;; 14 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-fixnum x)) + (integer ,most-negative-fixnum ,most-positive-fixnum)) - ;; 12 - ((defun comp-tests-ret-type-spec-8-3-f (x) - (if (= x 3) - 'foo - x)) - (or (member foo) marker number)) + ;; 15 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-cons x)) + cons) - ;; 13 - ((defun comp-tests-ret-type-spec-8-4-f (x y) - (if (= x y) - x - 'foo)) - (or (member foo) marker number)) + ;; 16 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (when x + (setf y 4)) + y)) + (or null (integer 4 4))) - ;; 14 - ((defun comp-tests-ret-type-spec-9-1-f (x) - (comp-hint-fixnum x)) - (integer ,most-negative-fixnum ,most-positive-fixnum)) + ;; 17 + ((defun comp-tests-ret-type-spec-f () + (let (x + (y 3)) + (setf x y) + y)) + (integer 3 3)) - ;; 15 - ((defun comp-tests-ret-type-spec-f (x) - (comp-hint-cons x)) - cons) + ;; 18 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when x + (setf y x)) + y)) + t) - ;; 16 - ((defun comp-tests-ret-type-spec-f (x) - (let (y) - (when x - (setf y 4)) - y)) - (or null (integer 4 4))) + ;; 19 + ((defun comp-tests-ret-type-spec-f (x y) + (eq x y)) + boolean))) - ;; 17 - ((defun comp-tests-ret-type-spec-f () - (let (x - (y 3)) - (setf x y) - y)) - (integer 3 3)) - - ;; 18 - ((defun comp-tests-ret-type-spec-f (x) - (let ((y 3)) - (when x - (setf y x)) - y)) - t) - - ;; 19 - ((defun comp-tests-ret-type-spec-f (x y) - (eq x y)) - boolean))) - -(defun comp-tests-define-type-spec-test (number x) - `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () - ,(format "Type specifier test number %d." number) - (let ((comp-ctxt (make-comp-cstr-ctxt))) - (comp-tests-check-ret-type-spec ',(car x) ',(cadr x))))) + (defun comp-tests-define-type-spec-test (number x) + `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () + ,(format "Type specifier test number %d." number) + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec ',(car x) ',(cadr x)))))) (defmacro comp-tests-define-type-spec-tests () "Define all type specifier tests." From 6f3570cd4a615caa02c3d86320049a5631ab9b25 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 18 Dec 2020 18:37:16 +0100 Subject: [PATCH 1232/1452] Fix value type inference for doubly negate constraints * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Do not propagate in case of double negation. * test/src/comp-test-funcs.el (comp-test-assume-double-neg-f): New function. * test/src/comp-tests.el (assume-double-neg): New test. --- lisp/emacs-lisp/comp.el | 4 +++- test/src/comp-test-funcs.el | 10 ++++++++++ test/src/comp-tests.el | 4 ++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5d2f8d412fe..895e1ac33e4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2530,7 +2530,9 @@ Fold the call in case." (and (apply #'comp-cstr-intersection lval operands)) (not - (comp-cstr-negation lval (car operands))))) + ;; Prevent double negation! + (unless (comp-cstr-neg (car operands)) + (comp-cstr-negation lval (car operands)))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5fc032b127d..7f70fc2460c 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -395,6 +395,16 @@ (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))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8e069fb3082..eeff599de4c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -401,6 +401,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." " (should (string= " ➊" (comp-test-45342-f 1)))) +(comp-deftest assume-double-neg () + "In fwprop assumtions (not (not (member x))) /= (member x)." + (should-not (comp-test-assume-double-neg-f "bar" "foo"))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." From 5376563517f2235b8b79f661c213fd74dd62b654 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 11:56:15 +0100 Subject: [PATCH 1233/1452] Fix `comp-add-call-cstr' and add a test * lisp/emacs-lisp/comp.el (comp-add-call-cstr): Fix it. * test/src/comp-tests.el (assume-in-loop-1): New test. * test/src/comp-test-funcs.el (comp-test-assume-in-loop-1-f): New function. --- lisp/emacs-lisp/comp.el | 13 ++++++++----- test/src/comp-test-funcs.el | 12 ++++++++++++ test/src/comp-tests.el | 4 ++++ 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 895e1ac33e4..5345e20bfc0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2017,21 +2017,24 @@ TARGET-BB-SYM is the symbol name of the target block." (pcase insn (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) - (cl-values cstr-f lhs args))) + (cl-values f cstr-f lhs args))) (`(,(pred comp-call-op-p) ,f . ,args) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) - (cl-values cstr-f nil args)))))) - (cl-multiple-value-bind (cstr-f lhs args) match + (cl-values f cstr-f nil args)))))) + (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop + with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) for arg in args - for gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) for cstr = (funcall gen) for target = (comp-cond-cstrs-target-mvar arg insn bb) + unless (comp-cstr-p cstr) + do (signal 'native-ice + (list "Incoherent type specifier for function" f)) when (and target (or (null lhs) (not (eql (comp-mvar-slot lhs) (comp-mvar-slot target))))) - do (comp-emit-call-cstr target insn-cell cstr))))))) + do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) "Rewrite conditional branches adding appropriate 'assume' insns. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 7f70fc2460c..a2663eaf9cf 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -405,6 +405,18 @@ ;; 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)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index eeff599de4c..0594a4e086c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -405,6 +405,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "In fwprop assumtions (not (not (member x))) /= (member x)." (should-not (comp-test-assume-double-neg-f "bar" "foo"))) +(comp-deftest assume-in-loop-1 () + "Broken call args assumptions lead to infinite loop." + (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." From ebf8963a9181ab4e87141c2603df996f49389765 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 15:11:30 +0100 Subject: [PATCH 1234/1452] * Fix a bunch of known type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Fixes for: =, string-search, substring. --- lisp/emacs-lisp/comp.el | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5345e20bfc0..2f8587909e6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -198,7 +198,7 @@ Useful to hook into pass checkers.") (symbol-name (function (symbol) string)) (eq (function (t t) boolean)) (eql (function (t t) boolean)) - (= (function ((or number marker) (or number marker)) boolean)) + (= (function ((or number marker) &rest (or number marker)) boolean)) (/= (function ((or number marker) (or number marker)) boolean)) (< (function ((or number marker) &rest (or number marker)) boolean)) (<= (function ((or number marker) &rest (or number marker)) boolean)) @@ -233,11 +233,11 @@ Useful to hook into pass checkers.") (string-equal (function ((or string symbol) (or string symbol)) boolean)) (string< (function ((or string symbol) (or string symbol)) boolean)) (string-lessp (function ((or string symbol) (or string symbol)) boolean)) - (string-search (function (string string) (or integer null))) + (string-search (function (string string &optional integer) integer)) (string-to-char (function (string) integer)) (string-to-number (function (string &optional integer) number)) (string-to-syntax (function (string) cons)) - (substring (function (string &optional integer integer) string)) + (substring (function ((or string vector) &optional integer integer) (or string vector))) (sxhash (function (t) integer)) (sxhash-equal (function (t) integer)) (sxhash-eq (function (t) integer)) @@ -253,7 +253,6 @@ Useful to hook into pass checkers.") (string-to-multibyte (function (string) string)) (tan (function (number) float)) (time-convert (function (t &optional (or boolean integer)) cons)) - (truncate (function (number) integer)) (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum (upcase (function ((or fixnum string)) (or fixnum string))) (user-full-name (function (&optional integer) string)) From 9676e4d7766cea647a4e2b9e27fad97479b418de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 18 Dec 2020 15:22:41 +0100 Subject: [PATCH 1235/1452] * Fix a test in auth-source-tests.el * test/lisp/auth-source-tests.el (auth-source-test-secrets-create-secret): Redefine `read-string' respecting the original number of arguments. --- test/lisp/auth-source-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index deb1b91aab2..4c3005c3efe 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -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)))) From 433ae7b0a5cedbcd7b0a1daf12846e38f00fd111 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Li=C4=81u=2C=20Kiong-G=C4=93=20=E5=BB=96=E5=AE=AE=E6=AF=85?= Date: Tue, 22 Dec 2020 20:02:50 +0100 Subject: [PATCH 1236/1452] Fix --with-nativecomp Windows build (bug#45303) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Liāu, Kiong-Gē 廖宮毅 * src/comp.c (eln_load_path_final_clean_up): Fix argument order. * nt/mingw-cfg.site (ac_cv_func_strsignal): Force `ac_cv_func_strsignal' to no. Copyright-paperwork-exempt: yes --- nt/mingw-cfg.site | 4 ++++ src/comp.c | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/nt/mingw-cfg.site b/nt/mingw-cfg.site index 4a77cc20b4e..a2c93996970 100644 --- a/nt/mingw-cfg.site +++ b/nt/mingw-cfg.site @@ -156,3 +156,7 @@ 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 +# . +ac_cv_func_strsignal=no diff --git a/src/comp.c b/src/comp.c index 70f61bfbe1d..166c75bea0d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4534,7 +4534,7 @@ eln_load_path_final_clean_up (void) concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, Qnil, return_nil); + Qnil, Qt, return_nil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } From 2a22fa8b68d18b83b0a20be66b9123454bf7b6e5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Dec 2020 10:48:29 +0100 Subject: [PATCH 1237/1452] * lisp/emacs-lisp/comp-cstr.el (comp-cstr-copy): Tweak for perf. --- lisp/emacs-lisp/comp-cstr.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 22d3958aed3..aaeb9cf3e9b 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -113,10 +113,10 @@ Integer values are handled in the `range' slot.") (defun comp-cstr-copy (cstr) "Return a deep copy of CSTR." (with-comp-cstr-accessors - (make-comp-cstr :typeset (copy-tree (typeset cstr)) - :valset (copy-tree (valset cstr)) + (make-comp-cstr :typeset (copy-sequence (typeset cstr)) + :valset (copy-sequence (valset cstr)) :range (copy-tree (range cstr)) - :neg (copy-tree (neg cstr))))) + :neg (neg cstr)))) (defsubst comp-cstr-empty-p (cstr) "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise." From fd8dd75a71eef796ba8fb1d2604fd615bebaae42 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Dec 2020 10:46:33 +0100 Subject: [PATCH 1238/1452] Make input constraints into memoization hash immutable (bug#45376) * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1) (comp-cstr-intersection): Copy input before soting it into the memoization hash table. --- lisp/emacs-lisp/comp-cstr.el | 4 ++-- test/src/comp-test-funcs.el | 14 ++++++++++++++ test/src/comp-tests.el | 4 ++++ 3 files changed, 20 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index aaeb9cf3e9b..480d15616a0 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -507,7 +507,7 @@ DST is returned." (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))) (res (or (gethash srcs mem-h) (puthash - srcs + (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-union-1-no-mem range srcs) mem-h)))) (setf (typeset dst) (typeset res) @@ -676,7 +676,7 @@ DST is returned." (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt)) (res (or (gethash srcs mem-h) (puthash - srcs + (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-intersection-no-mem srcs) mem-h)))) (setf (typeset dst) (typeset res) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index a2663eaf9cf..d6bcfca2d94 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -417,6 +417,20 @@ (setq args (cons (substring arg start pos) args)))) args)) +(defun comp-test-45376-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)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0594a4e086c..5f2d702fca0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -409,6 +409,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Broken call args assumptions lead to infinite loop." (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) +(comp-deftest bug-45376 () + "" + (should (equal (comp-test-45376-f) '(1 0)))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." From c90aa68d90b1c5805d3d6327a058098d938ac72f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Dec 2020 11:47:36 +0100 Subject: [PATCH 1239/1452] * Follow cstr basic blocks to perform latch recognition * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Fix latch recognition. --- lisp/emacs-lisp/comp.el | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f8587909e6..485e5dc6ad2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2540,9 +2540,12 @@ Fold the call in case." (`(phi ,lval . ,rest) (let* ((from-latch (cl-some (lambda (x) - (comp-latch-p - (gethash (cdr x) - (comp-func-blocks comp-func)))) + (let* ((bb-name (cadr x)) + (bb (gethash bb-name + (comp-func-blocks comp-func)))) + (or (comp-latch-p bb) + (when (comp-block-cstr-p bb) + (comp-latch-p (car (comp-block-preds bb))))))) rest)) (prop-fn (if from-latch #'comp-cstr-union-no-range From 0a89ed7a962e22892e9c700cfca188197af2a6ad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Dec 2020 14:03:54 +0100 Subject: [PATCH 1240/1452] * Fix non range cstr union operation * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-homogeneous): Add range parameter and handle the non range case. (comp-cstr-union-1-no-mem, comp-cstr-intersection-no-mem): Update `comp-cstr-union-homogeneous' call sites. --- lisp/emacs-lisp/comp-cstr.el | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 480d15616a0..92c981f5acf 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -383,8 +383,9 @@ All SRCS constraints must be homogeneously negated or non-negated." dst) -(defun comp-cstr-union-homogeneous (dst &rest srcs) +(defun comp-cstr-union-homogeneous (range dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. All SRCS constraints must be homogeneously negated or non-negated. DST is returned." (apply #'comp-cstr-union-homogeneous-no-range dst srcs) @@ -397,9 +398,10 @@ DST is returned." (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) (comp-cstr-typeset dst)) - ;; TODO memoize? - (apply #'comp-range-union - (mapcar #'comp-cstr-range srcs)))) + (if range + (apply #'comp-range-union + (mapcar #'comp-cstr-range srcs)) + '((- . +))))) dst) (cl-defun comp-cstr-union-1-no-mem (range &rest srcs) @@ -419,17 +421,17 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. (when-let ((res (comp-cstrs-homogeneous srcs))) - (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-union-homogeneous range dst srcs) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) - (let* ((pos (apply #'comp-cstr-union-homogeneous + (let* ((pos (apply #'comp-cstr-union-homogeneous range (make-comp-cstr) positives)) ;; We'll always use neg as result as this is almost ;; always necessary for describing open intervals ;; resulting from negated constraints. - (neg (apply #'comp-cstr-union-homogeneous + (neg (apply #'comp-cstr-union-homogeneous range (make-comp-cstr :neg t) negatives))) ;; Type propagation. (when (and (typeset pos) @@ -586,7 +588,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-return-from comp-cstr-intersection-no-mem dst))) (when-let ((res (comp-cstrs-homogeneous srcs))) (if (eq res 'neg) - (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-union-homogeneous t dst srcs) (apply #'comp-cstr-intersection-homogeneous dst srcs)) (cl-return-from comp-cstr-intersection-no-mem dst)) From ffcd490cb49ba86d625288ea425d98e8cac22a05 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 23 Dec 2020 15:51:55 +0100 Subject: [PATCH 1241/1452] Negate only values while constraining variables (bug#45376) * lisp/emacs-lisp/comp-cstr.el (comp-cstr-value-negation): New function. * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Use `comp-cstr-value-negation'. * test/src/comp-test-funcs.el (comp-test-45376-1-f): Rename. (comp-test-45376-2-f): New funcion. * test/src/comp-tests.el (bug-45376-1): Rename test. (bug-45376-2): Add test. --- lisp/emacs-lisp/comp-cstr.el | 14 ++++++++++++++ lisp/emacs-lisp/comp.el | 2 +- test/src/comp-test-funcs.el | 20 +++++++++++++++++++- test/src/comp-tests.el | 8 ++++++-- 4 files changed, 40 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 92c981f5acf..8b5639c8a4d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -701,6 +701,20 @@ DST is returned." (neg dst) (not (neg src))) dst)) +(defun comp-cstr-value-negation (dst src) + "Negate values in SRC setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (if (or (valset src) (range src)) + (setf (typeset dst) () + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))) + (setf (typeset dst) (typeset src) + (valset dst) () + (range dst) ())) + dst)) + (defun comp-cstr-negation-make (src) "Negate SRC and return a new constraint." (comp-cstr-negation (make-comp-cstr) src)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 485e5dc6ad2..6ed50dc0122 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2534,7 +2534,7 @@ Fold the call in case." (not ;; Prevent double negation! (unless (comp-cstr-neg (car operands)) - (comp-cstr-negation lval (car operands)))))) + (comp-cstr-value-negation lval (car operands)))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index d6bcfca2d94..7731e6547b1 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -417,7 +417,7 @@ (setq args (cons (substring arg start pos) args)))) args)) -(defun comp-test-45376-f () +(defun comp-test-45376-1-f () ;; Reduced from `eshell-ls-find-column-lengths'. (let* (res (len 2) @@ -431,6 +431,24 @@ 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)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 5f2d702fca0..e0d4bf8df5e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -409,9 +409,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Broken call args assumptions lead to infinite loop." (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) -(comp-deftest bug-45376 () +(comp-deftest bug-45376-1 () "" - (should (equal (comp-test-45376-f) '(1 0)))) + (should (equal (comp-test-45376-1-f) '(1 0)))) + +(comp-deftest bug-45376-2 () + "" + (should (equal (comp-test-45376-2-f) '(0 2 1 0 1 0 1 0 0 0 0 0)))) (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () From 4deeb2f2eec340f8f2ef6f0d474503ea9b30ed43 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 22 Dec 2020 09:57:51 +0100 Subject: [PATCH 1242/1452] Invert basic block argument order in LIMPLE cond-jump * lisp/emacs-lisp/comp.el (comp-emit-cond-jump) (comp-emit-switch, comp-emit-narg-prologue, comp-add-cond-cstrs): Invert basic block argument order in LIMPLE cond-jump. * src/comp.c (emit_limple_insn): Likewise. --- lisp/emacs-lisp/comp.el | 12 ++++++------ src/comp.c | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6ed50dc0122..599c8c75006 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1229,8 +1229,8 @@ Return value is the fall through block name." (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-emit (if negated - (list 'cond-jump a b eff-target-name bb) - (list 'cond-jump a b bb eff-target-name))) + (list 'cond-jump a b bb eff-target-name) + (list 'cond-jump a b eff-target-name bb))) (comp-mark-curr-bb-closed) bb))) @@ -1321,7 +1321,7 @@ Return value is the fall through block name." (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) - do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name)) else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. @@ -1330,7 +1330,7 @@ Return value is the fall through block name." (comp-emit (list 'cond-jump (make-comp-mvar :slot 'scratch) (make-comp-mvar :constant nil) - target-name ff-bb-name)) + ff-bb-name target-name)) unless last ;; All fall through are artificially created here except the last one. do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) @@ -1615,7 +1615,7 @@ the annotation emission." (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) - do (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb)) (comp-make-curr-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) @@ -1971,7 +1971,7 @@ TARGET-BB-SYM is the symbol name of the target block." for branch-target-cell on blocks for branch-target = (car branch-target-cell) for assume-target = (comp-add-cond-cstrs-target-block b branch-target) - for negated in '(nil t) + for negated in '(t nil) do (setf (car branch-target-cell) (comp-block-name assume-target)) when target-mvar1 do (comp-emit-assume target-mvar1 op2 assume-target negated) diff --git a/src/comp.c b/src/comp.c index 166c75bea0d..ee3c15a2f67 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2038,7 +2038,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); - emit_cond_jump (emit_EQ (a, b), target2, target1); + emit_cond_jump (emit_EQ (a, b), target1, target2); } else if (EQ (op, Qcond_jump_narg_leq)) { @@ -2060,7 +2060,7 @@ emit_limple_insn (Lisp_Object insn) GCC_JIT_COMPARISON_LE, gcc_jit_lvalue_as_rvalue (nargs), n); - emit_cond_jump (test, target2, target1); + emit_cond_jump (test, target1, target2); } else if (EQ (op, Qphi) || EQ (op, Qassume)) { From c07c9f6bf81d2355672839e7423a9f2a5f00e4fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 22 Dec 2020 10:29:48 +0100 Subject: [PATCH 1243/1452] Extend cstrs pass to match `when' like code * lisp/emacs-lisp/comp.el (comp-emit-assume): Better parameter names. (comp-add-cond-cstrs-simple): New function. (comp-add-cond-cstrs): Rename assume-target -> block-target. (comp-add-cstrs): Call `comp-add-cond-cstrs-simple'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add test. --- lisp/emacs-lisp/comp.el | 45 ++++++++++++++++++++++++++++++++--------- test/src/comp-tests.el | 8 +++++++- 2 files changed, 42 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 599c8c75006..eef63b52c44 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1881,15 +1881,15 @@ into the C code forwarding the compilation unit." ;; afterwards both x and y must satisfy the (or number marker) ;; type specifier. -(defun comp-emit-assume (target rhs bb negated) - "Emit an assume for mvar TARGET being RHS. +(defun comp-emit-assume (lhs rhs bb negated) + "Emit an assume for mvar LHS being RHS. When NEGATED is non-nil the assumption is negated. The assume is emitted at the beginning of the block BB." - (let ((target-slot (comp-mvar-slot target)) + (let ((lhs-slot (comp-mvar-slot lhs)) (tmp-mvar (if negated (make-comp-mvar :slot (comp-mvar-slot rhs)) rhs))) - (push `(assume ,(make-comp-mvar :slot target-slot) (and ,target ,tmp-mvar)) + (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated (push `(assume ,tmp-mvar (not ,rhs)) @@ -1950,6 +1950,30 @@ TARGET-BB-SYM is the symbol name of the target block." "_cstrs")) curr-bb target-bb)))) +(defun comp-add-cond-cstrs-simple () + "`comp-add-cstrs' worker function for each selected function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do + (cl-loop + named in-the-basic-block + for insn-seq on (comp-block-insns b) + do + (pcase insn-seq + (`((set ,(and (pred comp-mvar-p) tmp-mvar) + ,(and (pred comp-mvar-p) obj1)) + (comment ,_comment-str) + (cond-jump ,tmp-mvar ,obj2 . ,blocks)) + (cl-loop + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for block-target = (comp-add-cond-cstrs-target-block b branch-target) + for negated in '(nil t) + do + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume tmp-mvar obj2 block-target negated) + finally (cl-return-from in-the-basic-block))))))) + (defun comp-add-cond-cstrs () "`comp-add-cstrs' worker function for each selected function." (cl-loop @@ -1960,23 +1984,23 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq - (`((set ,(and (pred comp-mvar-p) cond) + (`((set ,(and (pred comp-mvar-p) obj1) (,(pred comp-call-op-p) ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) (comment ,_comment-str) - (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) + (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for assume-target = (comp-add-cond-cstrs-target-block b branch-target) + for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(t nil) - do (setf (car branch-target-cell) (comp-block-name assume-target)) + do (setf (car branch-target-cell) (comp-block-name block-target)) when target-mvar1 - do (comp-emit-assume target-mvar1 op2 assume-target negated) + do (comp-emit-assume target-mvar1 op2 block-target negated) when target-mvar2 - do (comp-emit-assume target-mvar2 op1 assume-target negated) + do (comp-emit-assume target-mvar2 op1 block-target negated) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) @@ -2048,6 +2072,7 @@ blocks." (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) + (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) (comp-log-func comp-func 3)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e0d4bf8df5e..039e0665375 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -935,7 +935,13 @@ Return a list of results." ;; 19 ((defun comp-tests-ret-type-spec-f (x y) (eq x y)) - boolean))) + boolean) + + ;; 20 + ((defun comp-tests-ret-type-spec-f (x) + (when x + 'foo)) + (or (member foo) null)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 715cac119a02adb489cfda4b8f310cff87c55a2c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 22 Dec 2020 13:04:02 +0100 Subject: [PATCH 1244/1452] * lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Opencode byte-not. --- lisp/emacs-lisp/comp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eef63b52c44..ad09210d8dd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1446,7 +1446,9 @@ the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not null) + (byte-not + (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) + (make-comp-mvar :constant nil)))) (byte-car auto) (byte-cdr auto) (byte-cons auto) From 538f59806c1994df7d77716f896db5602f59dc02 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 22 Dec 2020 15:00:44 +0100 Subject: [PATCH 1245/1452] Extend cstrs pass to match `unless' like code * lisp/emacs-lisp/comp.el (comp-emit-assume): Add assertion. (comp-add-new-block-between): Fix two typos. (comp-add-cond-cstrs-target-block): Fix typo. (comp-add-cond-cstrs-simple): Logic update. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test. --- lisp/emacs-lisp/comp.el | 23 +++++++++++++++++------ test/src/comp-tests.el | 6 ++++++ 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ad09210d8dd..297dabbb5da 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1891,6 +1891,7 @@ The assume is emitted at the beginning of the block BB." (tmp-mvar (if negated (make-comp-mvar :slot (comp-mvar-slot rhs)) rhs))) + (cl-assert lhs-slot) (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated @@ -1898,7 +1899,7 @@ The assume is emitted at the beginning of the block BB." (comp-block-insns bb))) (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-add-new-block-beetween (bb-symbol bb-a bb-b) +(defun comp-add-new-block-between (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop with new-bb = (make-comp-block-cstr :name bb-symbol @@ -1913,8 +1914,8 @@ The assume is emitted at the beginning of the block BB." (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a))) (push ed (comp-block-out-edges new-bb)) ;; Connect `bb-a' `new-bb' with `new-edge'. - (push (comp-block-out-edges bb-a) new-edge) - (push (comp-block-in-edges new-bb) new-edge) + (push new-edge (comp-block-out-edges bb-a)) + (push new-edge (comp-block-in-edges new-bb)) (setf (comp-func-ssa-status comp-func) 'dirty) ;; Add `new-edge' to the current function and return it. (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) @@ -1948,9 +1949,9 @@ TARGET-BB-SYM is the symbol name of the target block." ;; If block has only one predecessor is already suitable for ;; adding constraint assumptions. target-bb - (comp-add-new-block-beetween (intern (concat (symbol-name target-bb-sym) - "_cstrs")) - curr-bb target-bb)))) + (comp-add-new-block-between (intern (concat (symbol-name target-bb-sym) + "_cstrs")) + curr-bb target-bb)))) (defun comp-add-cond-cstrs-simple () "`comp-add-cstrs' worker function for each selected function." @@ -1974,6 +1975,16 @@ TARGET-BB-SYM is the symbol name of the target block." do (setf (car branch-target-cell) (comp-block-name block-target)) (comp-emit-assume tmp-mvar obj2 block-target negated) + finally (cl-return-from in-the-basic-block))) + (`((cond-jump ,obj1 ,obj2 . ,blocks)) + (cl-loop + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for block-target = (comp-add-cond-cstrs-target-block b branch-target) + for negated in '(nil t) + do + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume obj1 obj2 block-target negated) finally (cl-return-from in-the-basic-block))))))) (defun comp-add-cond-cstrs () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 039e0665375..8f0b3406be6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -941,6 +941,12 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when x 'foo)) + (or (member foo) null)) + + ;; 21 + ((defun comp-tests-ret-type-spec-f (x) + (unless x + 'foo)) (or (member foo) null)))) (defun comp-tests-define-type-spec-test (number x) From 672988e961744750d3ea40904807355336116c3f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 22 Dec 2020 20:39:24 +0100 Subject: [PATCH 1246/1452] Symplify (not t) => nil and (not nil) => t * lisp/emacs-lisp/comp-cstr.el (comp-cstr-negation): Symplify (not t) => nil and (not nil) => t. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add two tests. --- lisp/emacs-lisp/comp-cstr.el | 25 +++++++++++++++++++++---- test/lisp/emacs-lisp/comp-cstr-tests.el | 6 +++++- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 8b5639c8a4d..19905950b5a 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -695,10 +695,27 @@ DST is returned." "Negate SRC setting the result in DST. DST is returned." (with-comp-cstr-accessors - (setf (typeset dst) (typeset src) - (valset dst) (valset src) - (range dst) (range src) - (neg dst) (not (neg src))) + (cond + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (equal (typeset src) '(t))) + (setf (typeset dst) () + (valset dst) () + (range dst) nil + (neg dst) nil)) + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (null (typeset src))) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) nil + (neg dst) nil)) + (t (setf (typeset dst) (typeset src) + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))))) dst)) (defun comp-cstr-value-negation (dst src) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 834f4401d9f..1e1376b363b 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -203,7 +203,11 @@ ;; 81 ((and t (not t)) . nil) ;; 82 - ((or (integer 1 1) (not (integer 1 1))) . t)) + ((or (integer 1 1) (not (integer 1 1))) . t) + ;; 83 + ((not t) . nil) + ;; 84 + ((not nil) . t)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () From 96d4c70412ee1f3f0f797d27cd7b8bc5532ba692 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 22 Dec 2020 22:53:05 +0100 Subject: [PATCH 1247/1452] * Fix logic for constraining block with multiple predecessors * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords) (comp-add-cond-cstrs-target-block): Logic update. --- lisp/emacs-lisp/comp.el | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 297dabbb5da..f73bd4b11eb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -662,7 +662,8 @@ Assume allocation class 'd-default as default." (1 font-lock-variable-name-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num) (? (or "_latch" "_cstrs")))))) + (1+ num) (? (or "_latch" + (seq "_cstrs_" (1+ num)))))))) (1 font-lock-constant-face)) (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) @@ -1943,15 +1944,23 @@ Keep on searching till EXIT-INSN is encountered." "Return the appropriate basic block to add constraint assumptions into. CURR-BB is the current basic block. TARGET-BB-SYM is the symbol name of the target block." - (let ((target-bb (gethash target-bb-sym - (comp-func-blocks comp-func)))) - (if (= (length (comp-block-in-edges target-bb)) 1) + (let* ((target-bb (gethash target-bb-sym + (comp-func-blocks comp-func))) + (target-bb-in-edges (comp-block-in-edges target-bb))) + (cl-assert target-bb-in-edges) + (if (= (length target-bb-in-edges) 1) ;; If block has only one predecessor is already suitable for ;; adding constraint assumptions. target-bb - (comp-add-new-block-between (intern (concat (symbol-name target-bb-sym) - "_cstrs")) - curr-bb target-bb)))) + (cl-loop + ;; Search for the first suitable basic block name. + for i from 0 + for new-name = (intern (format "%s_cstrs_%d" (symbol-name target-bb-sym) + i)) + until (null (gethash new-name (comp-func-blocks comp-func))) + finally + ;; Add it. + (cl-return (comp-add-new-block-between new-name curr-bb target-bb)))))) (defun comp-add-cond-cstrs-simple () "`comp-add-cstrs' worker function for each selected function." From 2a6c6bf3242847de5d6a25acbfa2a946617df291 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Dec 2020 08:52:56 +0100 Subject: [PATCH 1248/1452] * Use `comp-assign-op-p' into dead code elimination pass * lisp/emacs-lisp/comp.el (comp-dead-assignments-func): Use `comp-assign-op-p' in place of `comp-set-op-p'. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f73bd4b11eb..bbeaef37e3f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2761,7 +2761,7 @@ Return the list of m-var ids nuked." do (cl-loop for insn in (comp-block-insns b) for (op arg0 . rest) = insn - if (comp-set-op-p op) + if (comp-assign-op-p op) do (push (comp-mvar-id arg0) l-vals) (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) else @@ -2779,7 +2779,7 @@ Return the list of m-var ids nuked." for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn - (when (and (comp-set-op-p op) + (when (and (comp-assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) (setf insn (if (comp-limple-insn-call-p arg1) From 2327a983193bd043714274e78ec597592dceab80 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Dec 2020 09:14:28 +0100 Subject: [PATCH 1249/1452] * Constrain only mvars that are actually used * lisp/emacs-lisp/comp.el (comp-mvar-used-p, comp-collect-mvars) (comp-collect-rhs): New functions. (comp-add-cond-cstrs-simple, comp-add-cond-cstrs): Update logic. (comp-add-cstrs): Call `comp-collect-rhs' before doing anything else. --- lisp/emacs-lisp/comp.el | 63 ++++++++++++++++++++++++++++++++--------- 1 file changed, 49 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bbeaef37e3f..2f39b1d4cb3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1884,6 +1884,34 @@ into the C code forwarding the compilation unit." ;; afterwards both x and y must satisfy the (or number marker) ;; type specifier. + +(defsubst comp-mvar-used-p (mvar) + "Non-nil when MVAR is used as lhs in the current funciton." + (declare (gv-setter (lambda (val) + `(puthash ,mvar ,val comp-pass)))) + (gethash mvar comp-pass)) + +(defun comp-collect-mvars (form) + "Add rhs m-var present in FORM into `comp-pass'." + (cl-loop for x in form + if (consp x) + do (comp-collect-mvars x) + else + when (comp-mvar-p x) + do (setf (comp-mvar-used-p x) t))) + +(defun comp-collect-rhs () + "Collect all lhs mvars into `comp-pass'." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op . args) = insn + if (comp-set-op-p op) + do (comp-collect-mvars (cdr args)) + else + do (comp-collect-mvars args)))) + (defun comp-emit-assume (lhs rhs bb negated) "Emit an assume for mvar LHS being RHS. When NEGATED is non-nil the assumption is negated. @@ -1979,21 +2007,23 @@ TARGET-BB-SYM is the symbol name of the target block." (cl-loop for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(nil t) + when (comp-mvar-used-p tmp-mvar) do - (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume tmp-mvar obj2 block-target negated) + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume tmp-mvar obj2 block-target negated)) finally (cl-return-from in-the-basic-block))) (`((cond-jump ,obj1 ,obj2 . ,blocks)) (cl-loop for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(nil t) + when (comp-mvar-used-p obj1) do - (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume obj1 obj2 block-target negated) + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) (defun comp-add-cond-cstrs () @@ -2016,13 +2046,16 @@ TARGET-BB-SYM is the symbol name of the target block." with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(t nil) - do (setf (car branch-target-cell) (comp-block-name block-target)) - when target-mvar1 - do (comp-emit-assume target-mvar1 op2 block-target negated) - when target-mvar2 - do (comp-emit-assume target-mvar2 op1 block-target negated) + when (or (comp-mvar-used-p target-mvar1) + (comp-mvar-used-p target-mvar2)) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (when (comp-mvar-used-p target-mvar1) + (comp-emit-assume target-mvar1 op2 block-target negated)) + (when (comp-mvar-used-p target-mvar2) + (comp-emit-assume target-mvar2 op1 block-target negated))) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) @@ -2093,8 +2126,10 @@ blocks." ;; variables. (comp-func-l-p f) (not (comp-func-has-non-local f))) - (let ((comp-func f)) - (comp-add-cond-cstrs-simple) + (let ((comp-func f) + (comp-pass (make-hash-table :test #'eq))) + (comp-collect-rhs) + (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) (comp-log-func comp-func 3)))) From b4ee13c94218062baa4d9d15176eee4aaf582d57 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 24 Dec 2020 13:05:30 +0100 Subject: [PATCH 1250/1452] * Memoize `comp-subtype-p' * lisp/emacs-lisp/comp-cstr.el (comp-subtype-p): Memoize. (comp-cstr-ctxt): Add `subtype-p-mem' slot. --- lisp/emacs-lisp/comp-cstr.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 19905950b5a..32989f220a4 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -86,6 +86,9 @@ Integer values are handled in the `range' slot.") (common-supertype-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-common-supertype'.") + (subtype-p-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-subtype-p-mem'.") (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-cstr-union-1'.") @@ -215,7 +218,11 @@ Return them as multiple value." (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." - (eq (comp-common-supertype-2 type1 type2) type2)) + (let ((types (cons type1 type2))) + (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt)) + (puthash types + (eq (comp-common-supertype-2 type1 type2) type2) + (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) (defun comp-union-typesets (&rest typesets) "Union types present into TYPESETS." From bd693ccea7ba4a6aafda103f7a9166f76363c86b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 25 Dec 2020 09:39:22 +0100 Subject: [PATCH 1251/1452] * Don't emit byte op-code annotations in LIMPLE to optimize for compile-time Saves 10~15% in bootstrap time. * lisp/emacs-lisp/comp.el (comp-op-case): Don't emit op-code annotaitons. (comp-limplify-lap-inst, comp-add-cond-cstrs-simple) (comp-add-cond-cstrs, comp-tco-func): Update accordingly. --- lisp/emacs-lisp/comp.el | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f39b1d4cb3..1804f1f9dfa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1390,9 +1390,9 @@ the annotation emission." if body collect `(',op ;; Log all LAP ops except the TAG one. - ,(unless (eq op 'TAG) - `(comp-emit-annotation - ,(concat "LAP op " op-name))) + ;; ,(unless (eq op 'TAG) + ;; `(comp-emit-annotation + ;; ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) `(cl-incf (comp-sp) ,sp-delta)) @@ -1602,8 +1602,8 @@ the annotation emission." ;; Assume to follow the emission of a setimm. ;; This is checked into comp-emit-switch. (comp-emit-switch (comp-slot+1) - (cl-second (comp-block-insns - (comp-limplify-curr-block comp-pass))))) + (cl-first (comp-block-insns + (comp-limplify-curr-block comp-pass))))) (byte-constant (comp-emit-setimm arg)) (byte-discardN-preserve-tos @@ -2002,7 +2002,7 @@ TARGET-BB-SYM is the symbol name of the target block." (pcase insn-seq (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(and (pred comp-mvar-p) obj1)) - (comment ,_comment-str) + ;; (comment ,_comment-str) (cond-jump ,tmp-mvar ,obj2 . ,blocks)) (cl-loop for branch-target-cell on blocks @@ -2039,7 +2039,7 @@ TARGET-BB-SYM is the symbol name of the target block." (`((set ,(and (pred comp-mvar-p) obj1) (,(pred comp-call-op-p) ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) - (comment ,_comment-str) + ;; (comment ,_comment-str) (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) @@ -2856,7 +2856,7 @@ Return the list of m-var ids nuked." for insns-seq on (comp-block-insns b) do (pcase insns-seq (`((set ,l-val (direct-call ,func . ,args)) - (comment ,_comment) + ;; (comment ,_comment) (return ,ret-val)) (when (and (string= func (comp-func-c-name comp-func)) (eq l-val ret-val)) From 89d5a3a7603a0b096d02f58ba0a1997ad98c63ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 25 Dec 2020 10:57:02 +0100 Subject: [PATCH 1252/1452] Enable integer range narrowing under compare and branch * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range) (comp-cstr->, comp-cstr->=, comp-cstr-<, comp-cstr-<=): New functions. * lisp/emacs-lisp/comp.el (comp-equality-fun-p) (comp-range-cmp-fun-p): New functions. (comp-collect-rhs): Use `comp-assign-op-p' in place of `comp-set-op-p'. (comp-negate-range-cmp-fun, comp-reverse-cmp-fun): New functions. (comp-emit-assume): Rework to be able to emit also comparision assumption. (comp-add-cond-cstrs-simple): Update for new `comp-emit-assume'. (comp-add-cond-cstrs-simple): Update to emit range assumption. (comp-fwprop-insn): Execute range assumptions. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add tests. --- lisp/emacs-lisp/comp-cstr.el | 68 +++++++++++++++++++++++ lisp/emacs-lisp/comp.el | 102 +++++++++++++++++++++++++++-------- test/src/comp-tests.el | 77 +++++++++++++++++++++++++- 3 files changed, 224 insertions(+), 23 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 32989f220a4..9d0c67177b2 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -362,6 +362,22 @@ Return them as multiple value." (push `(,(1+ last-h) . +) res)) (cl-return (reverse res))))) +(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range) + "Support range comparison functions." + (with-comp-cstr-accessors + (if ext-range + (setf (typeset dst) () + (valset dst) () + (range dst) (if (range old-dst) + (comp-range-intersection (range old-dst) + ext-range) + ext-range) + (neg dst) nil) + (setf (typeset dst) (typeset old-dst) + (valset dst) (valset old-dst) + (range dst) (range old-dst) + (neg dst) (neg old-dst))))) + ;;; Union specific code. @@ -663,6 +679,58 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;;; Entry points. +(defun comp-cstr-> (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,(1+ src) . +)) + (when-let* ((range (range src)) + (low (cdar (last range))) + (okay (integerp low))) + `((,(1+ low) . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr->= (dst old-dst src) + "Constraint DST being >= than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,src . +)) + (when-let* ((range (range src)) + (low (cdar (last range))) + (okay (integerp low))) + `((,low . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-< (dst old-dst src) + "Constraint DST being < than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,(1- src))) + (when-let* ((range (range src)) + (low (caar (last range))) + (okay (integerp low))) + `((- . ,(1- low))))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-<= (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,src)) + (when-let* ((range (range src)) + (low (caar (last range))) + (okay (integerp low))) + `((- . ,low)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + (defun comp-cstr-union-no-range (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do not propagate the range component. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1804f1f9dfa..7d444af8d9f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -597,6 +597,14 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) +(defun comp-equality-fun-p (function) + "Equality functions predicate for FUNCTION." + (when (memq function '(eq eql = equal)) t)) + +(defun comp-range-cmp-fun-p (function) + "Predicate for range comparision functions." + (when (memq function '(> < >= <=)) t)) + (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -1876,7 +1884,10 @@ into the C code forwarding the compilation unit." ;; generated from: ;; ;; - Conditional branches: each branch taken or non taken can be used -;; in the CFG to infer infomations on the tested variables. +;; in the CFG to infer information on the tested variables. +;; +;; - Range propagation under test and branch (when the test is an +;; arithmetic comparison.) ;; ;; - Function calls: function calls to function assumed to be not ;; redefinable can be used to add constrains on the function @@ -1907,25 +1918,58 @@ into the C code forwarding the compilation unit." do (cl-loop for insn in (comp-block-insns b) for (op . args) = insn - if (comp-set-op-p op) + if (comp-assign-op-p op) do (comp-collect-mvars (cdr args)) else do (comp-collect-mvars args)))) -(defun comp-emit-assume (lhs rhs bb negated) - "Emit an assume for mvar LHS being RHS. +(defun comp-negate-range-cmp-fun (function) + "Negate FUNCTION." + (cl-ecase function + (> '<=) + (< '>=) + (>= '<) + (<= '>))) + +(defun comp-reverse-cmp-fun (function) + "Reverse FUNCTION." + (cl-case function + (> '<) + (< '>) + (>= '<=) + (<= '>=) + (t function))) + +(defun comp-emit-assume (kind lhs rhs bb negated) + "Emit an assume of kind KIND for mvar LHS being RHS. When NEGATED is non-nil the assumption is negated. The assume is emitted at the beginning of the block BB." - (let ((lhs-slot (comp-mvar-slot lhs)) - (tmp-mvar (if negated - (make-comp-mvar :slot (comp-mvar-slot rhs)) - rhs))) + (let ((lhs-slot (comp-mvar-slot lhs))) (cl-assert lhs-slot) - (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar)) - (comp-block-insns bb)) - (if negated - (push `(assume ,tmp-mvar (not ,rhs)) - (comp-block-insns bb))) + (pcase kind + ('and + (let ((tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (and ,lhs ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb))))) + ((pred comp-range-cmp-fun-p) + (let ((kind (if negated + (comp-negate-range-cmp-fun kind) + kind))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (,kind ,lhs + ,(if-let* ((vld (comp-mvar-value-vld-p rhs)) + (val (comp-mvar-value rhs)) + (ok (integerp val))) + val + (make-comp-mvar :slot (comp-mvar-slot rhs))))) + (comp-block-insns bb)))) + (_ (cl-assert nil))) (setf (comp-func-ssa-status comp-func) 'dirty))) (defun comp-add-new-block-between (bb-symbol bb-a bb-b) @@ -2012,7 +2056,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume tmp-mvar obj2 block-target negated)) + (comp-emit-assume 'and tmp-mvar obj2 block-target negated)) finally (cl-return-from in-the-basic-block))) (`((cond-jump ,obj1 ,obj2 . ,blocks)) (cl-loop @@ -2023,7 +2067,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume obj1 obj2 block-target negated)) + (comp-emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) (defun comp-add-cond-cstrs () @@ -2036,26 +2080,32 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq - (`((set ,(and (pred comp-mvar-p) obj1) + (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) - ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) + ,(and (or (pred comp-equality-fun-p) + (pred comp-range-cmp-fun-p)) + fun) + ,op1 ,op2)) ;; (comment ,_comment-str) - (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks)) + (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) + with equality = (comp-equality-fun-p fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) + for kind = (if equality 'and fun) when (or (comp-mvar-used-p target-mvar1) (comp-mvar-used-p target-mvar2)) do (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) (when (comp-mvar-used-p target-mvar1) - (comp-emit-assume target-mvar1 op2 block-target negated)) + (comp-emit-assume kind target-mvar1 op2 block-target negated)) (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume target-mvar2 op1 block-target negated))) + (comp-emit-assume (comp-reverse-cmp-fun kind) + target-mvar2 op1 block-target negated))) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) @@ -2610,13 +2660,21 @@ Fold the call in case." (_ (comp-mvar-propagate lval rval)))) (`(assume ,lval (,kind . ,operands)) - (cl-ecase kind + (cl-case kind (and (apply #'comp-cstr-intersection lval operands)) (not ;; Prevent double negation! (unless (comp-cstr-neg (car operands)) - (comp-cstr-value-negation lval (car operands)))))) + (comp-cstr-value-negation lval (car operands)))) + (> + (comp-cstr-> lval (car operands) (cadr operands))) + (>= + (comp-cstr->= lval (car operands) (cadr operands))) + (< + (comp-cstr-< lval (car operands) (cadr operands))) + (<= + (comp-cstr-<= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8f0b3406be6..22065f8f6e4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -947,7 +947,82 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (unless x 'foo)) - (or (member foo) null)))) + (or (member foo) null)) + + ;; 22 + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 3) + x)) + (or null (integer 4 *))) + + ;; 23 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= x 3) + x)) + (or null (integer 3 *))) + + ;; 24 + ((defun comp-tests-ret-type-spec-f (x) + (when (< x 3) + x)) + (or null (integer * 2))) + + ;; 25 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= x 3) + x)) + (or null (integer * 3))) + + ;; 26 + ((defun comp-tests-ret-type-spec-f (x) + (when (> 3 x) + x)) + (or null (integer * 2))) + + ;; 27 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= 3 x) + x)) + (or null (integer * 3))) + + ;; 28 + ((defun comp-tests-ret-type-spec-f (x) + (when (< 3 x) + x)) + (or null (integer 4 *))) + + ;; 29 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 3 x) + x)) + (or null (integer 3 *))) + + ;; 30 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> x y) + x))) + (or null (integer 4 *))) + + ;; 31 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> y x) + x))) + (or null (integer * 2))) + + ;; 32 + ((defun comp-tests-ret-type-spec-f (x) + (when (and (> x 3) + (< x 10)) + x)) + (or null (integer 4 9))) + + ;; 33 No float range support. + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 1.0) + x)) + (or null marker number)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From c5c0c06b1c37dc32b992dc4deddd8ec7bf154def Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Dec 2020 12:22:21 +0100 Subject: [PATCH 1253/1452] * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add two functions. --- lisp/emacs-lisp/comp.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7d444af8d9f..caea81fccca 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -264,7 +264,10 @@ Useful to hook into pass checkers.") (zerop (function (number) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) - (comp-hint-cons (function (t) cons))) + (comp-hint-cons (function (t) cons)) + ;; Non returning functions + (error (function (string &rest t) nil)) + (signal (function (symbol t) nil))) "Alist used for type propagation.") (defconst comp-known-func-cstr-h From fcd8c60182efc8bfe7bad11fb74489fe5df28d6b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Dec 2020 12:23:27 +0100 Subject: [PATCH 1254/1452] * Remove unnecessary lhs rename in `comp-ssa-rename-insn' * lisp/emacs-lisp/comp.el (comp-ssa-rename-insn): No point to rename lhs as it's being replaced. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index caea81fccca..936e47ff39a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2474,7 +2474,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) (let ((mvar (aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) + (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) (`(fetch-handler . ,_) ;; Clobber all no matter what! From fc02c8458d636e682b079a68f2ee7347e0299132 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Dec 2020 12:34:58 +0100 Subject: [PATCH 1255/1452] * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two more test. --- test/src/comp-tests.el | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 22065f8f6e4..e1c13598ad6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1018,7 +1018,21 @@ Return a list of results." x)) (or null (integer 4 9))) - ;; 33 No float range support. + ;; 33 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (> x 3) + (< x 10)) + x)) + (or null integer)) + + ;; 34 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (< x 3) + (> x 10)) + x)) + (or null (integer * 2) (integer 11 *))) + + ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) From d8939520535224ccee663bba5b3da752f1648009 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Dec 2020 13:09:24 +0100 Subject: [PATCH 1256/1452] Fix missing float handling into `comp-cstr-set-cmp-range' * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range): Add float handling. * test/src/comp-tests.el (comp-tests-type-spec-tests): Update results. --- lisp/emacs-lisp/comp-cstr.el | 2 +- test/src/comp-tests.el | 26 +++++++++++++------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 9d0c67177b2..1927207db63 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -366,7 +366,7 @@ Return them as multiple value." "Support range comparison functions." (with-comp-cstr-accessors (if ext-range - (setf (typeset dst) () + (setf (typeset dst) (and (typeset old-dst) '(float)) (valset dst) () (range dst) (if (range old-dst) (comp-range-intersection (range old-dst) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e1c13598ad6..446c30666f0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -953,84 +953,84 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (> x 3) x)) - (or null (integer 4 *))) + (or null float (integer 4 *))) ;; 23 ((defun comp-tests-ret-type-spec-f (x) (when (>= x 3) x)) - (or null (integer 3 *))) + (or null float (integer 3 *))) ;; 24 ((defun comp-tests-ret-type-spec-f (x) (when (< x 3) x)) - (or null (integer * 2))) + (or null float (integer * 2))) ;; 25 ((defun comp-tests-ret-type-spec-f (x) (when (<= x 3) x)) - (or null (integer * 3))) + (or null float (integer * 3))) ;; 26 ((defun comp-tests-ret-type-spec-f (x) (when (> 3 x) x)) - (or null (integer * 2))) + (or null float (integer * 2))) ;; 27 ((defun comp-tests-ret-type-spec-f (x) (when (>= 3 x) x)) - (or null (integer * 3))) + (or null float (integer * 3))) ;; 28 ((defun comp-tests-ret-type-spec-f (x) (when (< 3 x) x)) - (or null (integer 4 *))) + (or null float (integer 4 *))) ;; 29 ((defun comp-tests-ret-type-spec-f (x) (when (<= 3 x) x)) - (or null (integer 3 *))) + (or null float (integer 3 *))) ;; 30 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when (> x y) x))) - (or null (integer 4 *))) + (or null float (integer 4 *))) ;; 31 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when (> y x) x))) - (or null (integer * 2))) + (or null float (integer * 2))) ;; 32 ((defun comp-tests-ret-type-spec-f (x) (when (and (> x 3) (< x 10)) x)) - (or null (integer 4 9))) + (or null float (integer 4 9))) ;; 33 ((defun comp-tests-ret-type-spec-f (x) (when (or (> x 3) (< x 10)) x)) - (or null integer)) + (or null float integer)) ;; 34 ((defun comp-tests-ret-type-spec-f (x) (when (or (< x 3) (> x 10)) x)) - (or null (integer * 2) (integer 11 *))) + (or null float (integer * 2) (integer 11 *))) ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) From 271fb8a269aff924070b188f23355d0c368356dd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 26 Dec 2020 20:16:26 +0100 Subject: [PATCH 1257/1452] * Fix `byte-compile-file' for native compilation (bug#45442) * lisp/emacs-lisp/bytecomp.el (byte-compile-file): Fix logic for native compilation. --- lisp/emacs-lisp/bytecomp.el | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 620f15c619d..9f5d121024a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2020,16 +2020,16 @@ See also `emacs-lisp-byte-compile-and-load'." (insert "\n") ; aaah, unix. (cond ((null target-file) nil) ;We only wanted the warnings! - ((and (or (file-writable-p target-file) - byte-native-compiling) - ;; 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 @@ -2037,7 +2037,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)) From ee53560c8cb1236bb60304157882abe8e7cddaff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Dec 2020 17:50:05 +0100 Subject: [PATCH 1258/1452] * Don't require trailing backslashes in `comp-eln-load-path' (bug#45462) * src/comp.c (Fcomp_el_to_eln_filename): Don't require trailing backslashes in comp-eln-load-path. --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index ee3c15a2f67..52ebf92c500 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4085,7 +4085,8 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); return Fexpand_file_name (filename, - concat2 (base_dir, Vcomp_native_version_dir)); + concat2 (Ffile_name_as_directory (base_dir), + Vcomp_native_version_dir)); } DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, From 34e9aae4407aceb54c7b6bc4c9b4e3e10ec62314 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Dec 2020 10:58:29 +0100 Subject: [PATCH 1259/1452] * Add comp-cstr-greatest-in-range comp-cstr-smallest-in-range * lisp/emacs-lisp/comp-cstr.el (comp-cstr-smallest-in-range) (comp-cstr-greatest-in-range): New function. (comp-cstr->, comp-cstr->=, comp-cstr-<, comp-cstr-<=): Make use of. --- lisp/emacs-lisp/comp-cstr.el | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 1927207db63..62e3c47ce3a 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -288,6 +288,14 @@ Return them as multiple value." ((eq y '-) nil) (t (< x y)))) +(defsubst comp-cstr-smallest-in-range (range) + "Smallest entry in RANGE." + (caar range)) + +(defsubst comp-cstr-greatest-in-range (range) + "Greater entry in RANGE." + (cdar (last range))) + (defun comp-range-union (&rest ranges) "Combine integer intervals RANGES by union set operation." (cl-loop @@ -687,7 +695,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,(1+ src) . +)) (when-let* ((range (range src)) - (low (cdar (last range))) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((,(1+ low) . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -700,7 +708,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,src . +)) (when-let* ((range (range src)) - (low (cdar (last range))) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((,low . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -713,7 +721,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,(1- src))) (when-let* ((range (range src)) - (low (caar (last range))) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((- . ,(1- low))))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -726,7 +734,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,src)) (when-let* ((range (range src)) - (low (caar (last range))) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) From 92af4e8fc97a3af043904c32488b84c0e943473d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Dec 2020 15:51:57 +0100 Subject: [PATCH 1260/1452] * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range): Improve. --- lisp/emacs-lisp/comp-cstr.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 62e3c47ce3a..d41501e6804 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -374,7 +374,10 @@ Return them as multiple value." "Support range comparison functions." (with-comp-cstr-accessors (if ext-range - (setf (typeset dst) (and (typeset old-dst) '(float)) + (setf (typeset dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (typeset old-dst)) + '(float)) (valset dst) () (range dst) (if (range old-dst) (comp-range-intersection (range old-dst) From 7d07a718416d6c24df0719483279c4278dce4acb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Dec 2020 14:07:08 +0100 Subject: [PATCH 1261/1452] Add sum/subtraction integer range propagation support * lisp/emacs-lisp/comp-cstr.el (comp-range-+, comp-range--): New functions. (comp-cstr-set-range-for-arithm): New macro. (comp-cstr-add-2, comp-cstr-sub-2, comp-cstr-add, comp-cstr-sub): New function. * lisp/emacs-lisp/comp.el (comp-fwprop-call): Wire-up + - integer range propagation. --- lisp/emacs-lisp/comp-cstr.el | 63 +++++++++++++++++++++++++ lisp/emacs-lisp/comp.el | 5 +- test/src/comp-tests.el | 91 +++++++++++++++++++++++++++++++++++- 3 files changed, 157 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d41501e6804..28cffcf0661 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -280,6 +280,22 @@ Return them as multiple value." x (1- x))) +(defsubst comp-range-+ (x y) + (pcase (cons x y) + ((or '(+ . -) '(- . +)) '??) + ((or `(- . ,_) `(,_ . -)) '-) + ((or `(+ . ,_) `(,_ . +)) '+) + (_ (+ x y)))) + +(defsubst comp-range-- (x y) + (pcase (cons x y) + ((or '(+ . +) '(- . -)) '??) + ('(+ . -) '+) + ('(- . +) '-) + ((or `(+ . ,_) `(,_ . -)) '+) + ((or `(- . ,_) `(,_ . +)) '-) + (_ (- x y)))) + (defsubst comp-range-< (x y) (cond ((eq x '+) nil) @@ -389,6 +405,39 @@ Return them as multiple value." (range dst) (range old-dst) (neg dst) (neg old-dst))))) +(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) + ;; Prevent some code duplication for `comp-cstr-add-2' + ;; `comp-cstr-sub-2'. + (declare (debug (range-body)) + (indent defun)) + `(with-comp-cstr-accessors + (when-let ((r1 (range ,src1)) + (r2 (range ,src2))) + (let* ((l1 (comp-cstr-smallest-in-range r1)) + (l2 (comp-cstr-smallest-in-range r2)) + (h1 (comp-cstr-greatest-in-range r1)) + (h2 (comp-cstr-greatest-in-range r2))) + (setf (typeset ,dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (append (typeset src1) + (typeset src2))) + '(float)) + (range ,dst) ,@range-body))))) + +(defun comp-cstr-add-2 (dst src1 src2) + "Sum SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2))))) + +(defun comp-cstr-sub-2 (dst src1 src2) + "Subtract SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + (let ((l (comp-range-- l1 h2)) + (h (comp-range-- h1 l2))) + (if (or (eq l '??) (eq h '??)) + '((- . +)) + `((,l . ,h)))))) + ;;; Union specific code. @@ -742,6 +791,20 @@ SRC can be either a comp-cstr or an integer." `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) +(defun comp-cstr-add (dst srcs) + "Sum SRCS into DST." + (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-add-2 dst dst src))) + +(defun comp-cstr-sub (dst srcs) + "Subtract SRCS into DST." + (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-sub-2 dst dst src))) + (defun comp-cstr-union-no-range (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do not propagate the range component. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 936e47ff39a..336ed39145d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2648,7 +2648,10 @@ Fold the call in case." (setf (comp-mvar-range lval) (comp-cstr-range cstr) (comp-mvar-valset lval) (comp-cstr-valset cstr) (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))))) + (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (cl-case f + (+ (comp-cstr-add lval args)) + (- (comp-cstr-sub lval args))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 446c30666f0..154229ec872 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1036,7 +1036,96 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) - (or null marker number)))) + (or null marker number)) + + ;; 36 + ;; SBCL: (OR (RATIONAL (5)) (SINGLE-FLOAT 5.0) + ;; (DOUBLE-FLOAT 5.0d0) NULL) !? + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (> x 3) + (> y 2)) + (+ x y))) + (or null float (integer 7 *))) + + ;; 37 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 3) + (<= y 2)) + (+ x y))) + (or null float (integer * 5))) + + ;; 38 SBCL gives: (OR (RATIONAL (2) (10)) (SINGLE-FLOAT 2.0 10.0) + ;; (DOUBLE-FLOAT 2.0d0 10.0d0) NULL)!? + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (< 1 x 5) + (< 1 y 5)) + (+ x y))) + (or null float (integer 4 8))) + + ;; 37 + ;; SBCL gives: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) + (or null float (integer 3 13))) + + ;; 38 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 8))) + + ;; 39 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 *))) + + ;; 40 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 41 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 42 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= y 3)) + (- x y))) + (or null float integer)) + + ;; 43 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) + (or null float integer)) + + ;; 44 + ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) + ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) + ((defun comp-tests-ret-type-spec-f (x y z i j k) + (when (and (< 1 x 5) + (< 1 y 5) + (< 1 z 5) + (< 1 i 5) + (< 1 j 5) + (< 1 k 5)) + (+ x y z i j k))) + (or null float (integer 12 24))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 42fb6de0b366622cd59006f69fbc13c5cf3a0714 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Dec 2020 21:33:07 +0100 Subject: [PATCH 1262/1452] Add 1+ 1- integer range propagation support * lisp/emacs-lisp/comp-cstr.el (comp-cstr-one): New special var. * lisp/emacs-lisp/comp.el (comp-fwprop-call): Propagate integer ranges on +1 -1. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests. --- lisp/emacs-lisp/comp-cstr.el | 4 ++++ lisp/emacs-lisp/comp.el | 4 +++- test/src/comp-tests.el | 14 +++++++++++++- 3 files changed, 20 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 28cffcf0661..57d93912d2f 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -154,6 +154,10 @@ Return them as multiple value." collect cstr into positives finally return (cl-values positives negatives))) +(defvar comp-cstr-one (make-comp-cstr :typeset () + :range '((1 . 1))) + "Represent the integer immediate one (1).") + ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 336ed39145d..6b06ac5840d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2651,7 +2651,9 @@ Fold the call in case." (comp-mvar-neg lval) (comp-cstr-neg cstr)))) (cl-case f (+ (comp-cstr-add lval args)) - (- (comp-cstr-sub lval args))))) + (- (comp-cstr-sub lval args)) + (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one))) + (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 154229ec872..d0e482bb501 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1125,7 +1125,19 @@ Return a list of results." (< 1 j 5) (< 1 k 5)) (+ x y z i j k))) - (or null float (integer 12 24))))) + (or null float (integer 12 24))) + + ;; 45 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1+ x))) + (or null float (integer 2 6))) + + ;;46 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1- x))) + (or null float (integer 0 4))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From ccce15299ba3846f5c74335d6d7bc55aac29e007 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 10:48:05 +0100 Subject: [PATCH 1263/1452] * Improve some slot type into comp.el * lisp/emacs-lisp/comp.el (comp-args-base, comp-args) (comp-nargs, comp-func): Fix the type of some slots. --- lisp/emacs-lisp/comp.el | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6b06ac5840d..8ed1427a570 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -375,18 +375,17 @@ This is typically for top-level forms other than defun.") :documentation "When non-nil support late load.")) (cl-defstruct comp-args-base - (min nil :type number + (min nil :type integer :documentation "Minimum number of arguments allowed.")) (cl-defstruct (comp-args (:include comp-args-base)) - (max nil :type number - :documentation "Maximum number of arguments allowed. -To be used when ncall-conv is nil.")) + (max nil :type integer + :documentation "Maximum number of arguments allowed.")) (cl-defstruct (comp-nargs (:include comp-args-base)) "Describe args when the function signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." - (nonrest nil :type number + (nonrest nil :type integer :documentation "Number of non rest arguments.") (rest nil :type boolean :documentation "t if rest argument is present.")) @@ -479,7 +478,7 @@ into it.") :documentation "SSA status either: 'nil', 'dirty' or 't'. Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") - (frame-size nil :type number) + (frame-size nil :type integer) (blocks (make-hash-table :test #'eq) :type hash-table :documentation "Basic block symbol -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table From 8a0467e2ef3c29fc0e9aaec7b6436c9a9bb279d6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 11:22:20 +0100 Subject: [PATCH 1264/1452] ; lisp/emacs-lisp/comp.el (comp-emit-narg-prologue): Nit. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8ed1427a570..a9caeace65a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1633,7 +1633,7 @@ the annotation emission." (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) finally (comp-emit '(jump entry_rest_args))) - (when (not (= minarg nonrest)) + (when (/= minarg nonrest) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_fallback_%s" i)) for next-bb = (if (= (1+ i) nonrest) From e532ec95529224025465421e97243fda7b559d9a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 11:25:39 +0100 Subject: [PATCH 1265/1452] Compute function type for native compiled functions * lisp/emacs-lisp/comp.el (comp-func): `type' rename from `ret-type-specifier'. (comp-args-to-lambda-list): New function. (comp-compute-function-type): New function from `comp-ret-type-spec'. (comp-final): Update. * test/src/comp-tests.el (comp-tests-check-ret-type-spec): Update. --- lisp/emacs-lisp/comp.el | 71 ++++++++++++++++++++++++++++------------- test/src/comp-tests.el | 2 +- 2 files changed, 50 insertions(+), 23 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a9caeace65a..c6bd040e5f6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,8 +497,8 @@ CFG is mutated by a pass.") :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean :documentation "t if pure nil otherwise.") - (ret-type-specifier '(t) :type list - :documentation "Derived return type specifier.")) + (type nil :type list + :documentation "Derived return type.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -2970,26 +2970,53 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. -(defun comp-ret-type-spec (_ func) +(defun comp-args-to-lambda-list (args) + "Return a lambda list for args." + (cl-loop + with res + repeat (comp-args-base-min args) + do (push t res) + finally + (if (comp-args-p args) + (cl-loop + with n = (- (comp-args-max args) (comp-args-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res)) + (cl-loop + with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res) + finally (when (comp-nargs-rest args) + (push '&rest res) + (push 't res)))) + (cl-return (reverse res)))) + +(defun comp-compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. -Set it into the `ret-type-specifier' slot." - (let* ((comp-func (make-comp-func)) - (res-mvar (apply #'comp-cstr-union - (make-comp-cstr) - (cl-loop - with res = nil - for bb being the hash-value in (comp-func-blocks - func) - do (cl-loop - for insn in (comp-block-insns bb) - ;; Collect over every exit point the returned - ;; mvars and union results. - do (pcase insn - (`(return ,mvar) - (push mvar res)))) - finally return res)))) - (setf (comp-func-ret-type-specifier func) - (comp-cstr-to-type-spec res-mvar)))) +Set it into the `type' slot." + (when (comp-func-l-p func) + (let* ((comp-func (make-comp-func)) + (res-mvar (apply #'comp-cstr-union + (make-comp-cstr) + (cl-loop + with res = nil + for bb being the hash-value in (comp-func-blocks + func) + do (cl-loop + for insn in (comp-block-insns bb) + ;; Collect over every exit point the returned + ;; mvars and union results. + do (pcase insn + (`(return ,mvar) + (push mvar res)))) + finally return res)))) + (setf (comp-func-type func) + `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + ,(comp-cstr-to-type-spec res-mvar)))))) (defun comp-finalize-container (cont) "Finalize data container CONT." @@ -3093,7 +3120,7 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." - (maphash #'comp-ret-type-spec (comp-ctxt-funcs-h comp-ctxt)) + (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run ;; Always run the C side of the compilation as a sub-process ;; unless during bootstrap or async compilation (bug#45056). GCC diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d0e482bb501..dbfa3702ff1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -800,7 +800,7 @@ Return a list of results." ,(lambda (_) (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) (comp-ctxt-funcs-h comp-ctxt)))) - (should (equal (comp-func-ret-type-specifier f) + (should (equal (cl-third (comp-func-type f)) type-specifier)))))))) (eval func-form t) (native-compile (cadr func-form)))) From eafcc8eda0a78e78d1a53b30dafb22786dd60591 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 11:54:34 +0100 Subject: [PATCH 1266/1452] Propagate function calls also when hiddend under funcall * lisp/emacs-lisp/comp.el (comp-fwprop-call): Propagate functions also when called under `funcall'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test. --- lisp/emacs-lisp/comp.el | 4 ++++ test/src/comp-tests.el | 7 ++++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c6bd040e5f6..2ca7c50045e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2642,6 +2642,10 @@ Return non-nil if the function is folded successfully." F is the function being called with arguments ARGS. Fold the call in case." (unless (comp-function-call-maybe-fold insn f args) + (when (and (eq 'funcall f) + (comp-mvar-value-vld-p (car args))) + (setf f (comp-mvar-value (car args)) + args (cdr args))) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (let ((cstr (comp-cstr-f-ret cstr-f))) (setf (comp-mvar-range lval) (comp-cstr-range cstr) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dbfa3702ff1..d4eb39a736f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1137,7 +1137,12 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1- x))) - (or null float (integer 0 4))))) + (or null float (integer 0 4))) + + ;; 47 + ((defun comp-tests-ret-type-spec-f () + (error "foo")) + nil))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 5a8622ba2c623c60fab5b2784d5f15eeebcf46f2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 12:59:12 +0100 Subject: [PATCH 1267/1452] Reorder subr register function arguments to make some room * src/comp.c (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr): Use a rest arg to pass 'doc_idx' and 'intspec' parameters. * lisp/emacs-lisp/comp.el (comp-emit-for-top-level) (comp-emit-lambda-for-top-level): Update. --- lisp/emacs-lisp/comp.el | 28 +++++++++++++++------------- src/comp.c | 27 ++++++++++++++------------- 2 files changed, 29 insertions(+), 26 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ca7c50045e..3b84569c458 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1693,17 +1693,17 @@ the annotation emission." 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) + (make-comp-mvar :constant c-name) (car args) (cdr args) - (make-comp-mvar :constant c-name) (make-comp-mvar :constant - (let* ((h (comp-ctxt-function-docs comp-ctxt)) - (i (hash-table-count h))) - (puthash i (comp-func-doc f) h) - i)) - (make-comp-mvar :constant - (comp-func-int-spec f)) + (list + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i) + (comp-func-int-spec f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -1734,15 +1734,17 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) + (make-comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) - (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar - :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) - (i (hash-table-count h))) - (puthash i (comp-func-doc func) h) - i)) - (make-comp-mvar :constant (comp-func-int-spec func)) + :constant + (list + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc func) h) + i) + (comp-func-int-spec func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) diff --git a/src/comp.c b/src/comp.c index 52ebf92c500..ee8ae98e2ac 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4925,13 +4925,14 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, } DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, - 7, 7, 0, + 6, 6, 0, doc: /* Register anonymous lambda. This gets called by top_level_run during the load phase. */) - (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) { + Lisp_Object doc_idx = FIRST (rest); + Lisp_Object intspec = SECOND (rest); struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); if (cu->loaded_once) return Qnil; @@ -4953,13 +4954,14 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 7, 7, 0, + 6, 6, 0, doc: /* Register exported subr. This gets called by top_level_run during the load phase. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) { + Lisp_Object doc_idx = FIRST (rest); + Lisp_Object intspec = SECOND (rest); Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); @@ -4982,16 +4984,15 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, - Scomp__late_register_subr, 7, 7, 0, + Scomp__late_register_subr, 6, 6, 0, doc: /* Register exported subr. This gets called by late_top_level_run during the load phase. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) - Fcomp__register_subr (name, minarg, maxarg, c_name, doc, intspec, comp_u); + Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u); Fremhash (name, Vcomp_deferred_pending_h); return Qnil; } From 2b3c7c751739f48545c3888549ae312ea334951b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 13:41:38 +0100 Subject: [PATCH 1268/1452] Store function type and expose it with `subr-type' * src/lisp.h (struct Lisp_Subr): Add 'type' field. (SUBR_TYPE): New inline accessor. * src/pdumper.c (dump_subr): Update for 'type' field. * src/data.c (Fsubr_type): New primitive. (syms_of_data): Update. * src/comp.c (ABI_VERSION): Bump new ABI version. (make_subr): Set type. (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr): Receive and pass subr type to 'make_subr'. * src/alloc.c (mark_object): Mark subr type. * lisp/emacs-lisp/comp.el (comp-func): Change slot type into mvar. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Pass type mvar to subr register functions. (comp-compute-function-type): Fix-up subr type mvars. * test/src/comp-tests.el (comp-tests-check-ret-type-spec): Use `subr-type'. --- lisp/emacs-lisp/comp.el | 21 ++++++++++++++------- src/alloc.c | 1 + src/comp.c | 28 ++++++++++++++++------------ src/data.c | 14 ++++++++++++++ src/lisp.h | 7 +++++++ src/pdumper.c | 3 ++- test/src/comp-tests.el | 16 ++++++---------- 7 files changed, 60 insertions(+), 30 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3b84569c458..35a9e05cfb7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,8 +497,8 @@ CFG is mutated by a pass.") :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean :documentation "t if pure nil otherwise.") - (type nil :type list - :documentation "Derived return type.")) + (type nil :type (or null comp-mvar) + :documentation "Mvar holding the derived return type.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -1696,6 +1696,8 @@ the annotation emission." (make-comp-mvar :constant c-name) (car args) (cdr args) + (setf (comp-func-type f) + (make-comp-mvar :constant nil)) (make-comp-mvar :constant (list @@ -1737,6 +1739,8 @@ These are stored in the reloc data array." (make-comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) + (setf (comp-func-type func) + (make-comp-mvar :constant nil)) (make-comp-mvar :constant (list @@ -3004,7 +3008,8 @@ These are substituted with a normal 'set' op." (defun comp-compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `type' slot." - (when (comp-func-l-p func) + (when (and (comp-func-l-p func) + (comp-mvar-p (comp-func-type func))) (let* ((comp-func (make-comp-func)) (res-mvar (apply #'comp-cstr-union (make-comp-cstr) @@ -3019,10 +3024,12 @@ Set it into the `type' slot." do (pcase insn (`(return ,mvar) (push mvar res)))) - finally return res)))) - (setf (comp-func-type func) - `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) - ,(comp-cstr-to-type-spec res-mvar)))))) + finally return res))) + (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + ,(comp-cstr-to-type-spec res-mvar)))) + (comp-add-const-to-relocs type) + ;; Fix it up. + (setf (comp-mvar-value (comp-func-type func)) type)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/src/alloc.c b/src/alloc.c index 754b8f2aef8..bdf721e5270 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6719,6 +6719,7 @@ mark_object (Lisp_Object arg) mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); mark_object (subr->lambda_list[0]); + mark_object (subr->type[0]); } break; diff --git a/src/comp.c b/src/comp.c index ee8ae98e2ac..04bf9973d26 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,7 +411,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "0" +#define ABI_VERSION "1" /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" @@ -4886,8 +4886,8 @@ native_function_doc (Lisp_Object function) static Lisp_Object make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx, + Lisp_Object intspec, Lisp_Object comp_u) { struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); dynlib_handle_ptr handle = cu->handle; @@ -4918,6 +4918,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; x->s.native_c_name[0] = xstrdup (SSDATA (c_name)); + x->s.type[0] = type; Lisp_Object tem; XSETSUBR (tem, &x->s); @@ -4925,11 +4926,12 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, } DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, - 6, 6, 0, + 7, 7, 0, doc: /* Register anonymous lambda. This gets called by top_level_run during the load phase. */) (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); @@ -4938,7 +4940,7 @@ This gets called by top_level_run during the load phase. */) return Qnil; Lisp_Object tem = - make_subr (c_name, minarg, maxarg, c_name, doc_idx, intspec, comp_u); + make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u); /* We must protect it against GC because the function is not reachable through symbols. */ @@ -4954,17 +4956,18 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 6, 6, 0, + 7, 7, 0, doc: /* Register exported subr. This gets called by top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); Lisp_Object tem = - make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, - comp_u); + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, + intspec, comp_u); if (AUTOLOADP (XSYMBOL (name)->u.s.function)) /* Remember that the function was already an autoload. */ @@ -4984,11 +4987,12 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, - Scomp__late_register_subr, 6, 6, 0, + Scomp__late_register_subr, 7, 7, 0, doc: /* Register exported subr. This gets called by late_top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) diff --git a/src/data.c b/src/data.c index 544b20d50cc..c5476495bd6 100644 --- a/src/data.c +++ b/src/data.c @@ -896,6 +896,19 @@ function or t otherwise. */) : 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, @@ -4057,6 +4070,7 @@ syms_of_data (void) 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); diff --git a/src/lisp.h b/src/lisp.h index efbb7a45242..6f00ae84517 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2071,6 +2071,7 @@ struct Lisp_Subr 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 { @@ -4759,6 +4760,12 @@ 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) { diff --git a/src/pdumper.c b/src/pdumper.c index ae5bbef9b77..a9c43a463db 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2860,7 +2860,7 @@ 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_35CE99B716) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_AA236F7759) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2893,6 +2893,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) 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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d4eb39a736f..c79190e2967 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -792,18 +792,14 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) -(defun comp-tests-check-ret-type-spec (func-form type-specifier) +(defun comp-tests-check-ret-type-spec (func-form ret-type) (let ((lexical-binding t) - (speed 2) - (comp-post-pass-hooks - `((comp-final - ,(lambda (_) - (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) - (comp-ctxt-funcs-h comp-ctxt)))) - (should (equal (cl-third (comp-func-type f)) - type-specifier)))))))) + (comp-speed 2) + (f-name (cl-second func-form))) (eval func-form t) - (native-compile (cadr func-form)))) + (native-compile f-name) + (should (equal (cl-third (subr-type (symbol-function f-name))) + ret-type)))) (cl-eval-when (compile eval load) (defconst comp-tests-type-spec-tests From ba41a183dd5123130a0393b84658ec3f2fdd66f4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 29 Dec 2020 11:39:04 +0100 Subject: [PATCH 1269/1452] * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Better `comp-type-to-cstr'. --- lisp/emacs-lisp/comp-cstr.el | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 57d93912d2f..8a8e22e030d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -49,7 +49,16 @@ "Likewise like `cl--all-builtin-types' but with t as common supertype.") (cl-defstruct (comp-cstr (:constructor comp-type-to-cstr - (type &aux (typeset (list type)))) + (type &aux + (null (eq type 'null)) + (integer (eq type 'integer)) + (typeset (if (or null integer) + nil + (list type))) + (valset (when null + '(nil))) + (range (when integer + '((- . +)))))) (:constructor comp-value-to-cstr (value &aux (valset (list value)) From e83c6994e1f2553634e0877e86a8ebaa19fbc5d1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 29 Dec 2020 11:39:26 +0100 Subject: [PATCH 1270/1452] * Define `cl-satisfies-deftype' mapping predicate -> type * lisp/emacs-lisp/cl-macs.el (cl-satisfies-deftype): Define symbol property as reverse of `cl-deftype-satisfies'. --- lisp/emacs-lisp/cl-macs.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f4b22ffbea2..7dfcc288e67 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3198,7 +3198,8 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; FIXME: Do we really want to consider this a type? (integer-or-marker . integer-or-marker-p) )) - (put type 'cl-deftype-satisfies pred)) + (put type 'cl-deftype-satisfies pred) + (put pred 'cl-satisfies-deftype type)) ;;;###autoload (define-inline cl-typep (val type) From c4efb49a27f05284d28eac7f60b28495c68f63fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 29 Dec 2020 13:29:02 +0100 Subject: [PATCH 1271/1452] Constrain mvars under compare and branch with built-in predicates * lisp/emacs-lisp/comp.el (comp-emit-assume): Update. (comp-known-predicate-p): New function. (comp-add-cond-cstrs): Extend to pattern match predicate calls. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-null-p) (comp-pred-to-cstr): New function. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a number of tests and fix comments. --- lisp/emacs-lisp/comp-cstr.el | 11 ++++++ lisp/emacs-lisp/comp.el | 69 +++++++++++++++++++++++++++++++----- test/src/comp-tests.el | 69 +++++++++++++++++++++++++++--------- 3 files changed, 123 insertions(+), 26 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 8a8e22e030d..ce702422932 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -137,6 +137,13 @@ Integer values are handled in the `range' slot.") (null (valset cstr)) (null (range cstr))))) +(defsubst comp-cstr-null-p (x) + "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset x)) + (null (range x)) + (equal (valset x) '(nil))))) + (defun comp-cstrs-homogeneous (cstrs) "Check if constraints CSTRS are all homogeneously negated or non-negated. Return `pos' if they are all positive, `neg' if they are all @@ -167,6 +174,10 @@ Return them as multiple value." :range '((1 . 1))) "Represent the integer immediate one (1).") +(defun comp-pred-to-cstr (predicate) + "Given PREDICATE return the correspondig constraint." + (comp-type-to-cstr (get predicate 'cl-satisfies-deftype))) + ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 35a9e05cfb7..b885ff88411 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1895,7 +1895,10 @@ into the C code forwarding the compilation unit." ;; in the CFG to infer information on the tested variables. ;; ;; - Range propagation under test and branch (when the test is an -;; arithmetic comparison.) +;; arithmetic comparison). +;; +;; - Type constraint under test and branch (when the test is a +;; known predicate). ;; ;; - Function calls: function calls to function assumed to be not ;; redefinable can be used to add constrains on the function @@ -1956,15 +1959,22 @@ The assume is emitted at the beginning of the block BB." (cl-assert lhs-slot) (pcase kind ('and - (let ((tmp-mvar (if negated - (make-comp-mvar :slot (comp-mvar-slot rhs)) - rhs))) + (if (comp-mvar-p rhs) + (let ((tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (and ,lhs ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb)))) + ;; If is only a constraint we can negate it directly. (push `(assume ,(make-comp-mvar :slot lhs-slot) - (and ,lhs ,tmp-mvar)) - (comp-block-insns bb)) - (if negated - (push `(assume ,tmp-mvar (not ,rhs)) - (comp-block-insns bb))))) + (and ,lhs ,(if negated + (comp-cstr-negation-make rhs) + rhs))) + (comp-block-insns bb)))) ((pred comp-range-cmp-fun-p) (let ((kind (if negated (comp-negate-range-cmp-fun kind) @@ -2078,6 +2088,10 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) +(defun comp-known-predicate-p (pred) + (when (symbolp pred) + (get pred 'cl-satisfies-deftype))) + (defun comp-add-cond-cstrs () "`comp-add-cstrs' worker function for each selected function." (cl-loop @@ -2114,6 +2128,43 @@ TARGET-BB-SYM is the symbol name of the target block." (when (comp-mvar-used-p target-mvar2) (comp-emit-assume (comp-reverse-cmp-fun kind) target-mvar2 op1 block-target negated))) + finally (cl-return-from in-the-basic-block))) + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (pred comp-known-predicate-p) fun) + ,op)) + ;; (comment ,_comment-str) + (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) + with cstr = (comp-pred-to-cstr fun) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(t nil) + when (comp-mvar-used-p target-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and target-mvar cstr block-target negated)) + finally (cl-return-from in-the-basic-block))) + ;; Match predicate on the negated branch (unless). + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (pred comp-known-predicate-p) fun) + ,op)) + (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) + (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) + with cstr = (comp-pred-to-cstr fun) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(nil t) + when (comp-mvar-used-p target-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and target-mvar cstr block-target negated)) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c79190e2967..240af102ec4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -837,7 +837,6 @@ Return a list of results." y)) (or (integer 1 1) (integer 3 3))) - ;; 6 ((defun comp-tests-ret-type-spec-f (x) (if x @@ -1035,8 +1034,6 @@ Return a list of results." (or null marker number)) ;; 36 - ;; SBCL: (OR (RATIONAL (5)) (SINGLE-FLOAT 5.0) - ;; (DOUBLE-FLOAT 5.0d0) NULL) !? ((defun comp-tests-ret-type-spec-f (x y) (when (and (> x 3) (> y 2)) @@ -1051,15 +1048,14 @@ Return a list of results." (+ x y))) (or null float (integer * 5))) - ;; 38 SBCL gives: (OR (RATIONAL (2) (10)) (SINGLE-FLOAT 2.0 10.0) - ;; (DOUBLE-FLOAT 2.0d0 10.0d0) NULL)!? + ;; 38 ((defun comp-tests-ret-type-spec-f (x y) (when (and (< 1 x 5) (< 1 y 5)) (+ x y))) (or null float (integer 4 8))) - ;; 37 + ;; 39 ;; SBCL gives: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) @@ -1067,7 +1063,7 @@ Return a list of results." (+ x y))) (or null float (integer 3 13))) - ;; 38 + ;; 40 ;; SBCL: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) @@ -1075,42 +1071,42 @@ Return a list of results." (- x y))) (or null float (integer -2 8))) - ;; 39 + ;; 41 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x) (<= 2 y 3)) (- x y))) (or null float (integer -2 *))) - ;; 40 + ;; 42 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) (<= 2 y)) (- x y))) (or null float (integer * 8))) - ;; 41 + ;; 43 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= x 10) (<= 2 y)) (- x y))) (or null float (integer * 8))) - ;; 42 + ;; 44 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= x 10) (<= y 3)) (- x y))) (or null float integer)) - ;; 43 + ;; 45 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 2 x) (<= 3 y)) (- x y))) (or null float integer)) - ;; 44 + ;; 46 ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) ((defun comp-tests-ret-type-spec-f (x y z i j k) @@ -1123,22 +1119,61 @@ Return a list of results." (+ x y z i j k))) (or null float (integer 12 24))) - ;; 45 + ;; 47 ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1+ x))) (or null float (integer 2 6))) - ;;46 + ;;48 ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1- x))) (or null float (integer 0 4))) - ;; 47 + ;; 49 ((defun comp-tests-ret-type-spec-f () (error "foo")) - nil))) + nil) + + ;; 50 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + x + 'bar)) + (or (member bar) string)) + + ;; 51 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + 'bar + x)) + (not string)) + + ;; 52 + ((defun comp-tests-ret-type-spec-f (x) + (if (integerp x) + x + 'bar)) + (or (member bar) integer)) + + ;; 53 + ((defun comp-tests-ret-type-spec-f (x) + (when (integerp x) + x)) + (or null integer)) + + ;; 54 + ((defun comp-tests-ret-type-spec-f (x) + (unless (symbolp x) + x)) + (not symbol)) + + ;; 55 + ((defun comp-tests-ret-type-spec-f (x) + (unless (integerp x) + x)) + (not integer)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From a3b816ff8ce17ec559043b053e60b631e5dc5eb8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 29 Dec 2020 14:31:16 +0100 Subject: [PATCH 1272/1452] * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Better `comp-value-to-cstr'. --- lisp/emacs-lisp/comp-cstr.el | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index ce702422932..c03056e3afe 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -61,7 +61,11 @@ '((- . +)))))) (:constructor comp-value-to-cstr (value &aux - (valset (list value)) + (integer (integerp value)) + (valset (unless integer + (list value))) + (range (when integer + `((,value . ,value)))) (typeset ()))) (:constructor comp-irange-to-cstr (irange &aux @@ -170,9 +174,8 @@ Return them as multiple value." collect cstr into positives finally return (cl-values positives negatives))) -(defvar comp-cstr-one (make-comp-cstr :typeset () - :range '((1 . 1))) - "Represent the integer immediate one (1).") +(defvar comp-cstr-one (comp-value-to-cstr 1) + "Represent the integer immediate one.") (defun comp-pred-to-cstr (predicate) "Given PREDICATE return the correspondig constraint." From 3f00d666e9674ba18f1ded490a27ac2868a32a88 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 29 Dec 2020 17:39:15 +0100 Subject: [PATCH 1273/1452] Fix missing negation handling in a bunch of predicates * lisp/emacs-lisp/comp.el (comp-mvar-fixnum-p) (comp-mvar-symbol-p, comp-mvar-cons-p): Consider neg slot. * test/src/comp-tests.el (comp-test-not-cons): New test. * test/src/comp-test-funcs.el (comp-test-not-cons-f): New function. --- lisp/emacs-lisp/comp.el | 21 +++++++++++++-------- test/src/comp-test-funcs.el | 6 ++++++ test/src/comp-tests.el | 3 +++ 3 files changed, 22 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b885ff88411..bf266256f70 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -538,6 +538,8 @@ CFG is mutated by a pass.") (integerp high) (= low high)))))))) +;; FIXME move these into cstr? + (defun comp-mvar-value (mvar) "Return the constant value of MVAR. `comp-mvar-value-vld-p' *must* be satisfied before calling @@ -556,18 +558,20 @@ CFG is mutated by a pass.") (defun comp-mvar-fixnum-p (mvar) "Return t if MVAR is certainly a fixnum." - (when-let (range (comp-mvar-range mvar)) - (let* ((low (caar range)) - (high (cdar (last range)))) - (unless (or (eq low '-) - (< low most-negative-fixnum) - (eq high '+) - (> high most-positive-fixnum)) - t)))) + (when (null (comp-mvar-neg mvar)) + (when-let (range (comp-mvar-range mvar)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t))))) (defun comp-mvar-symbol-p (mvar) "Return t if MVAR is certainly a symbol." (and (null (comp-mvar-range mvar)) + (null (comp-mvar-neg mvar)) (or (and (null (comp-mvar-valset mvar)) (equal (comp-mvar-typeset mvar) '(symbol))) (and (or (null (comp-mvar-typeset mvar)) @@ -578,6 +582,7 @@ CFG is mutated by a pass.") "Return t if MVAR is certainly a cons." (and (null (comp-mvar-valset mvar)) (null (comp-mvar-range mvar)) + (null (comp-mvar-neg mvar)) (equal (comp-mvar-typeset mvar) '(cons)))) (defun comp-mvar-type-hint-match-p (mvar type-hint) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 7731e6547b1..49e80763bee 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -449,6 +449,12 @@ (setq x (1+ x))))) res)) +(defun comp-test-not-cons-f (x) + ;; Reduced from `cl-copy-list'. + (if (consp x) + (print x) + (car x))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 240af102ec4..4546eccb622 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -479,6 +479,9 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Check cond-rw does not break target blocks with multiple predecessor." (should (null (comp-test-cond-rw-1-2-f)))) +(comp-deftest comp-test-not-cons () + (should-not (comp-test-not-cons-f nil))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 0593f478762437e2a8618f3f874a26424e4590b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 29 Dec 2020 19:41:28 +0100 Subject: [PATCH 1274/1452] * Add more function type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add more type specifiers. --- lisp/emacs-lisp/comp.el | 244 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 239 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bf266256f70..7e5a9ec951c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -184,7 +184,11 @@ Useful to hook into pass checkers.") ;; FIXME this probably should not be here but... good for now. (defconst comp-known-type-specifiers - `((cons (function (t t) cons)) + `( + ;; pure-fns + (cons (function (t t) cons)) + (car (function (list) t)) + (cdr (function (list) t)) (1+ (function ((or number marker)) number)) (1- (function ((or number marker)) number)) (+ (function (&rest (or number marker)) number)) @@ -194,7 +198,7 @@ Useful to hook into pass checkers.") (% (function ((or number marker) (or number marker)) number)) (concat (function (&rest sequence) string)) (regexp-opt (function (list) string)) - (string-to-char (function (string) integer)) + (string-to-char (function (string) fixnum)) (symbol-name (function (symbol) string)) (eq (function (t t) boolean)) (eql (function (t t) boolean)) @@ -234,16 +238,15 @@ Useful to hook into pass checkers.") (string< (function ((or string symbol) (or string symbol)) boolean)) (string-lessp (function ((or string symbol) (or string symbol)) boolean)) (string-search (function (string string &optional integer) integer)) - (string-to-char (function (string) integer)) (string-to-number (function (string &optional integer) number)) (string-to-syntax (function (string) cons)) - (substring (function ((or string vector) &optional integer integer) (or string vector))) + (substring (function ((or string vector) &optional integer integer) + (or string vector))) (sxhash (function (t) integer)) (sxhash-equal (function (t) integer)) (sxhash-eq (function (t) integer)) (sxhash-eql (function (t) integer)) (symbol-function (function (symbol) t)) - (symbol-name (function (symbol) string)) (symbol-plist (function (symbol) list)) (symbol-value (function (symbol) t)) (string-make-unibyte (function (string) string)) @@ -262,6 +265,237 @@ Useful to hook into pass checkers.") (vconcat (function (&rest sequence) vector)) ;; TODO all window-* :x (zerop (function (number) boolean)) + ;; side-effect-free-fns + (acos (function (number) float)) + (append (function (&rest list) list)) + (asin (function (number) float)) + (atan (function (number &optional number) float)) + (boundp (function (symbol) boolean)) + (buffer-file-name (function (&optional buffer) string)) + (buffer-local-variables (function (&optional buffer) list)) + (buffer-modified-p (function (&optional buffer) boolean)) + (buffer-substring (function ((or integer marker) (or integer marker)) string)) + (byte-code-function-p (function (t) boolean)) + (capitalize (function (or integer string) (or integer string))) + (car-less-than-car (function (list list) boolean)) + (char-after (function (&optional (or marker integer)) fixnum)) + (char-before (function (&optional (or marker integer)) fixnum)) + (char-equal (function (integer integer) boolean)) + (char-to-string (function (fixnum) string)) + (char-width (function (fixnum) fixnum)) + (compare-strings (function (string (or integer marker null) + (or integer marker null) + string (or integer marker null) + (or integer marker null) + &optional t) + (or (member t) fixnum))) + (coordinates-in-window-p (function (cons window) boolean)) + (copy-alist (function (list) list)) + (copy-sequence (function (sequence) sequence)) + (copy-marker (function (&optional (or integer marker) boolean) marker)) + (cos (function (number) float)) + (count-lines (function ((or integer marker) (or integer marker) &optional t) + integer)) + (current-time-string (function (&optional string boolean) string)) + (current-time-zone (function (&optional string boolean) cons)) + (decode-char (function (cons t) (or fixnum null))) + (decode-time (function (&optional string symbol symbol) cons)) + (default-boundp (function (symbol) boolean)) + (default-value (function (symbol) t)) + (documentation (function ((or function symbol subr) &optional t) + (or null string))) + (downcase (function ((or fixnum string)) (or fixnum string))) + (encode-char (function (fixnum symbol) (or fixnum null))) + (exp (function (number) float)) + (expt (function (number number) float)) + (encode-time (function (cons &rest t) cons)) + (error-message-string (function (list) string)) + (fboundp (function (symbol) boolean)) + (featurep (function (symbol &optional symbol) boolean)) + (file-directory-p (function (string) boolean)) + (file-exists-p (function (string) boolean)) + (file-locked-p (function (string) boolean)) + (file-name-absolute-p (function (string) boolean)) + (file-newer-than-file-p (function (string string) boolean)) + (file-readable-p (function (string) boolean)) + (file-symlink-p (function (string) boolean)) + (file-writable-p (function (string) boolean)) + (float-time (function (&optional cons) float)) + (format (function (string &rest t) string)) + (format-time-string (function (string &optional cons symbol) string)) + (frame-first-window (function ((or frame window)) window)) + (frame-root-window (function (&optional (or frame window)) window)) + (frame-selected-window (function (&optional (or frame window)) window)) + (frame-visible-p (function (frame) boolean)) + (get (function (symbol symbol) t)) + (gethash (function (t hash-table &optional t) t)) + (get-buffer (function ((or buffer string)) (or buffer null))) + (get-buffer-window (function (&optional (or buffer string) + (or symbol (integer 0 0))) + (or null window))) + (getenv (function (string &optional frame) (or null string))) + (get-file-buffer (function (string) (or null buffer))) + (hash-table-count (function (hash-table) integer)) + (int-to-string (function (number) string)) + (intern-soft (function (string &optional vector) symbol)) + (keymap-parent (function (cons) (or cons null))) + (length< (function (sequence fixnum) boolean)) + (length> (function (sequence fixnum) boolean)) + (length= (function (sequence fixnum) boolean)) + (line-beginning-position (function (&optional integer) integer)) + (line-end-position (function (&optional integer) integer)) + (local-variable-if-set-p (function (symbol &optional buffer) boolean)) + (local-variable-p (function (symbol &optional buffer) boolean)) + (locale-info (function ((member codeset days months paper)) + (or null string))) + (log (function (number number) float)) + (log10 (function (number) float)) + ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? + (lsh (function (integer integer) integer)) + (make-byte-code (function ((or fixnum list) string vector integer &optional + string t &rest t) + vector)) + (make-list (function (integer t) list)) + (make-string (function (integer fixnum &optional t) string)) + (make-symbol (function (string) symbol)) + (marker-buffer (function (marker) buffer)) + (minibuffer-selected-window (function () window)) + (minibuffer-window (function (&optional frame) window)) + (multibyte-char-to-unibyte (function (fixnum) fixnum)) + (next-window (function (&optional window t t) window)) + (number-to-string (function (number) string)) + (parse-colon-path (function (string) cons)) + (previous-window (function (&optional window t t) window)) + (prin1-to-string (function (t &optional t) string)) + (propertize (function (string &rest t) string)) + (degrees-to-radians (function (number) float)) + (radians-to-degrees (function (number) float)) + (read-from-string (function (string &ptional integer integer) cons)) + (region-beginning (function () integer)) + (region-end (function () integer)) + (reverse (function (sequence) sequence)) + (sin (function (number) float)) + (string (function (&rest fixnum) strng)) + (get-largest-window (function (&optional t t t) window)) + (get-lru-window (function (&optional t t t) window)) + (one-window-p (function (&optional t t) boolean)) + (regexp-quote (function (string) string)) + (proper-list-p (function (t) integer)) + (nth (function (integer list) t)) + (nthcdr (function (integer list) list)) + (last (function (list &optional integer) list)) + (length (function (sequence) integer)) + (memq (function (t list) list)) + (memql (function (t list) list)) + (member (function (t list) list)) + (assq (function (t list) list)) + (rassq (function (t list) list)) + (rassoc (function (t list) list)) + (plist-get (function (list t) t)) + (lax-plist-get (function (list t) t)) + (plist-member (function (list t) list)) + (aref (function (array fixnum) t)) + (elt (function (sequence integer) t)) + (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) + (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) + (bool-vector-count-population (function (bool-vector) fixnum)) + (bool-vector-count-consecutive (function (bool-vector bool-vector integer) + fixnum)) + ;; side-effect-and-error-free-fns + (arrayp (function (t) boolean)) + (atom (function (t) boolean)) + (bignump (function (t) boolean)) + (bobp (function () boolean)) + (bolp (function () boolean)) + (bool-vector-p (function (t) boolean)) + (buffer-end (function ((or number marker)) integer)) + (buffer-list (function (&optional frame) list)) + (buffer-size (function (&optional buffer) integer)) + (buffer-string (function () string)) + (bufferp (function (t) boolean)) + (car-safe (function (t) t)) + (case-table-p (function (t) boolean)) + (cdr-safe (function (t) t)) + (char-or-string-p (function (t) boolean)) + (characterp (function (t &optional t) boolean)) + (charsetp (function (t) boolean)) + (commandp (function (t &optional t) boolean)) + (consp (function (t) boolean)) + (current-buffer (function () buffer)) + (current-global-map (function () cons)) + (current-indentation (function () integer)) + (current-local-map (function () cons)) + (current-minor-mode-maps (function () cons)) + (current-time (function () cons)) + (eobp (function () boolean)) + (eolp (function () boolean)) + (equal (function (t t) boolean)) + (eventp (function (t) boolean)) + (fixnump (function (t) boolean)) + (floatp (function (t) boolean)) + (following-char (function () fixnum)) + (framep (function (t) boolean)) + (hash-table-p (function (t) boolean)) + (identity (function (t) t)) + (ignore (function (&rest t) null)) + (integerp (function (t) boolean)) + (integer-or-marker-p (function (t) boolean)) + (interactive-p (function () boolean)) + (invocation-directory (function () string)) + (invocation-name (function () string)) + (keymapp (function (t) boolean)) + (keywordp (function (t) boolean)) + (list (function (&rest t) list)) + (listp (function (t) boolean)) + (make-marker (function () marker)) + (mark (function (&optional t) (or integer null))) + (mark-marker (function () marker)) + (markerp (function (t) boolean)) + (max-char (function () fixnum)) + (memory-limit (function () integer)) + (mouse-movement-p (function (t) boolean)) + (natnump (function (t) boolean)) + (nlistp (function (t) boolean)) + (not (function (t) boolean)) + (null (function (t) boolean)) + (number-or-marker-p (function (t) boolean)) + (numberp (function (t) boolean)) + (overlayp (function (t) boolean)) + (point (function () integer)) + (point-marker (function () marker)) + (point-min (function () integer)) + (point-max (function () integer)) + (preceding-char (function () fixnum)) + (processp (function (t) boolean)) + (recent-keys (function (&optional (or cons null)) vector)) + (recursion-depth (function () integer)) + (safe-length (function (t) integer)) + (selected-frame (function () frame)) + (selected-window (function () window)) + (sequencep (function (t) boolean)) + (standard-case-table (function () char-table)) + (standard-syntax-table (function () char-table)) + (stringp (function (t) boolean)) + (subrp (function (t) boolean)) + (symbolp (function (t) boolean)) + (syntax-table (function () char-table)) + (syntax-table-p (function (t) boolean)) + (this-command-keys (function () string)) + (this-command-keys-vector (function () vector)) + (this-single-command-keys (function () vector)) + (this-single-command-raw-keys (function () vector)) + (type-of (function (t) symbol)) + (user-real-login-name (function () string)) + (user-real-uid (function () integer)) + (user-uid (function () integer)) + (vector (function (&rest t) vector)) + (vectorp (function (t) boolean)) + (visible-frame-list (function () list)) + (wholenump (function (t) boolean)) + (window-configuration-p (function (t) boolean)) + (window-live-p (function (t) boolean)) + (window-valid-p (function (t) boolean)) + (windowp (function (t) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons)) From db2a49327a48a375cc2813d5211d762c5dfe55ff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 30 Dec 2020 13:50:23 +0100 Subject: [PATCH 1275/1452] * Order function types in aphabetical order * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Reorder in aphabetical order and comment. --- lisp/emacs-lisp/comp.el | 367 +++++++++++++++++++--------------------- 1 file changed, 176 insertions(+), 191 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7e5a9ec951c..b6ade0b99db 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -185,133 +185,112 @@ Useful to hook into pass checkers.") ;; FIXME this probably should not be here but... good for now. (defconst comp-known-type-specifiers `( - ;; pure-fns - (cons (function (t t) cons)) - (car (function (list) t)) - (cdr (function (list) t)) - (1+ (function ((or number marker)) number)) - (1- (function ((or number marker)) number)) + ;; Functions we can trust not to be or if redefined should expose + ;; the same type. Vast majority of these is either pure or + ;; pritive, the original list is the union of pure + + ;; side-effect-free-fns + side-effect-and-error-free-fns: + (% (function ((or number marker) (or number marker)) number)) + (* (function (&rest (or number marker)) number)) (+ (function (&rest (or number marker)) number)) (- (function (&rest (or number marker)) number)) - (* (function (&rest (or number marker)) number)) (/ (function ((or number marker) &rest (or number marker)) number)) - (% (function ((or number marker) (or number marker)) number)) - (concat (function (&rest sequence) string)) - (regexp-opt (function (list) string)) - (string-to-char (function (string) fixnum)) - (symbol-name (function (symbol) string)) - (eq (function (t t) boolean)) - (eql (function (t t) boolean)) - (= (function ((or number marker) &rest (or number marker)) boolean)) (/= (function ((or number marker) (or number marker)) boolean)) + (1+ (function ((or number marker)) number)) + (1- (function ((or number marker)) number)) (< (function ((or number marker) &rest (or number marker)) boolean)) (<= (function ((or number marker) &rest (or number marker)) boolean)) - (>= (function ((or number marker) &rest (or number marker)) boolean)) + (= (function ((or number marker) &rest (or number marker)) boolean)) (> (function ((or number marker) &rest (or number marker)) boolean)) - (min (function ((or number marker) &rest (or number marker)) number)) - (max (function ((or number marker) &rest (or number marker)) number)) - (mod (function ((or number marker) (or number marker)) - (or (integer 0 *) (float 0 *)))) + (>= (function ((or number marker) &rest (or number marker)) boolean)) (abs (function (number) number)) - (ash (function (integer integer) integer)) - (sqrt (function (number) float)) - (logand (function (&rest (or integer marker)) integer)) - (logior (function (&rest (or integer marker)) integer)) - (lognot (function (integer) integer)) - (logxor (function (&rest (or integer marker)) integer)) - (logcount (function (integer) integer)) - (copysign (function (float float) float)) - (isnan (function (float) boolean)) - (ldexp (function (number integer) float)) - (float (function (number) float)) - (logb (function (number) integer)) - (floor (function (number &optional number) integer)) - (ceiling (function (number &optional number) integer)) - (round (function (number &optional number) integer)) - (truncate (function (number &optional number) integer)) - (ffloor (function (float) float)) - (fceiling (function (float) float)) - (fround (function (float) float)) - (ftruncate (function (float) float)) - (string= (function ((or string symbol) (or string symbol)) boolean)) - (string-equal (function ((or string symbol) (or string symbol)) boolean)) - (string< (function ((or string symbol) (or string symbol)) boolean)) - (string-lessp (function ((or string symbol) (or string symbol)) boolean)) - (string-search (function (string string &optional integer) integer)) - (string-to-number (function (string &optional integer) number)) - (string-to-syntax (function (string) cons)) - (substring (function ((or string vector) &optional integer integer) - (or string vector))) - (sxhash (function (t) integer)) - (sxhash-equal (function (t) integer)) - (sxhash-eq (function (t) integer)) - (sxhash-eql (function (t) integer)) - (symbol-function (function (symbol) t)) - (symbol-plist (function (symbol) list)) - (symbol-value (function (symbol) t)) - (string-make-unibyte (function (string) string)) - (string-make-multibyte (function (string) string)) - (string-as-multibyte (function (string) string)) - (string-as-unibyte (function (string) string)) - (string-to-multibyte (function (string) string)) - (tan (function (number) float)) - (time-convert (function (t &optional (or boolean integer)) cons)) - (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum - (upcase (function ((or fixnum string)) (or fixnum string))) - (user-full-name (function (&optional integer) string)) - (user-login-name (function (&optional integer) (or string null))) - (user-original-login-name (function (&optional integer) (or string null))) - (custom-variable-p (function (symbol) boolean)) - (vconcat (function (&rest sequence) vector)) - ;; TODO all window-* :x - (zerop (function (number) boolean)) - ;; side-effect-free-fns (acos (function (number) float)) (append (function (&rest list) list)) + (aref (function (array fixnum) t)) + (arrayp (function (t) boolean)) + (ash (function (integer integer) integer)) (asin (function (number) float)) + (assq (function (t list) list)) (atan (function (number &optional number) float)) + (atom (function (t) boolean)) + (bignump (function (t) boolean)) + (bobp (function () boolean)) + (bolp (function () boolean)) + (bool-vector-count-consecutive (function (bool-vector bool-vector integer) fixnum)) + (bool-vector-count-population (function (bool-vector) fixnum)) + (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) + (bool-vector-p (function (t) boolean)) + (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) (boundp (function (symbol) boolean)) + (buffer-end (function ((or number marker)) integer)) (buffer-file-name (function (&optional buffer) string)) + (buffer-list (function (&optional frame) list)) (buffer-local-variables (function (&optional buffer) list)) (buffer-modified-p (function (&optional buffer) boolean)) + (buffer-size (function (&optional buffer) integer)) + (buffer-string (function () string)) (buffer-substring (function ((or integer marker) (or integer marker)) string)) + (bufferp (function (t) boolean)) (byte-code-function-p (function (t) boolean)) (capitalize (function (or integer string) (or integer string))) + (car (function (list) t)) (car-less-than-car (function (list list) boolean)) + (car-safe (function (t) t)) + (case-table-p (function (t) boolean)) + (cdr (function (list) t)) + (cdr-safe (function (t) t)) + (ceiling (function (number &optional number) integer)) (char-after (function (&optional (or marker integer)) fixnum)) (char-before (function (&optional (or marker integer)) fixnum)) (char-equal (function (integer integer) boolean)) + (char-or-string-p (function (t) boolean)) (char-to-string (function (fixnum) string)) (char-width (function (fixnum) fixnum)) - (compare-strings (function (string (or integer marker null) - (or integer marker null) - string (or integer marker null) - (or integer marker null) - &optional t) - (or (member t) fixnum))) + (characterp (function (t &optional t) boolean)) + (charsetp (function (t) boolean)) + (commandp (function (t &optional t) boolean)) + (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum))) + (concat (function (&rest sequence) string)) + (cons (function (t t) cons)) + (consp (function (t) boolean)) (coordinates-in-window-p (function (cons window) boolean)) (copy-alist (function (list) list)) - (copy-sequence (function (sequence) sequence)) (copy-marker (function (&optional (or integer marker) boolean) marker)) + (copy-sequence (function (sequence) sequence)) + (copysign (function (float float) float)) (cos (function (number) float)) - (count-lines (function ((or integer marker) (or integer marker) &optional t) - integer)) + (count-lines (function ((or integer marker) (or integer marker) &optional t) integer)) + (current-buffer (function () buffer)) + (current-global-map (function () cons)) + (current-indentation (function () integer)) + (current-local-map (function () cons)) + (current-minor-mode-maps (function () cons)) + (current-time (function () cons)) (current-time-string (function (&optional string boolean) string)) (current-time-zone (function (&optional string boolean) cons)) + (custom-variable-p (function (symbol) boolean)) (decode-char (function (cons t) (or fixnum null))) (decode-time (function (&optional string symbol symbol) cons)) (default-boundp (function (symbol) boolean)) (default-value (function (symbol) t)) - (documentation (function ((or function symbol subr) &optional t) - (or null string))) + (degrees-to-radians (function (number) float)) + (documentation (function ((or function symbol subr) &optional t) (or null string))) (downcase (function ((or fixnum string)) (or fixnum string))) + (elt (function (sequence integer) t)) (encode-char (function (fixnum symbol) (or fixnum null))) + (encode-time (function (cons &rest t) cons)) + (eobp (function () boolean)) + (eolp (function () boolean)) + (eq (function (t t) boolean)) + (eql (function (t t) boolean)) + (equal (function (t t) boolean)) + (error-message-string (function (list) string)) + (eventp (function (t) boolean)) (exp (function (number) float)) (expt (function (number number) float)) - (encode-time (function (cons &rest t) cons)) - (error-message-string (function (list) string)) (fboundp (function (symbol) boolean)) + (fceiling (function (float) float)) (featurep (function (symbol &optional symbol) boolean)) + (ffloor (function (float) float)) (file-directory-p (function (string) boolean)) (file-exists-p (function (string) boolean)) (file-locked-p (function (string) boolean)) @@ -320,174 +299,179 @@ Useful to hook into pass checkers.") (file-readable-p (function (string) boolean)) (file-symlink-p (function (string) boolean)) (file-writable-p (function (string) boolean)) + (fixnump (function (t) boolean)) + (float (function (number) float)) (float-time (function (&optional cons) float)) + (floatp (function (t) boolean)) + (floor (function (number &optional number) integer)) + (following-char (function () fixnum)) (format (function (string &rest t) string)) (format-time-string (function (string &optional cons symbol) string)) (frame-first-window (function ((or frame window)) window)) (frame-root-window (function (&optional (or frame window)) window)) (frame-selected-window (function (&optional (or frame window)) window)) (frame-visible-p (function (frame) boolean)) + (framep (function (t) boolean)) + (fround (function (float) float)) + (ftruncate (function (float) float)) (get (function (symbol symbol) t)) - (gethash (function (t hash-table &optional t) t)) (get-buffer (function ((or buffer string)) (or buffer null))) - (get-buffer-window (function (&optional (or buffer string) - (or symbol (integer 0 0))) - (or null window))) - (getenv (function (string &optional frame) (or null string))) + (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) (get-file-buffer (function (string) (or null buffer))) - (hash-table-count (function (hash-table) integer)) - (int-to-string (function (number) string)) - (intern-soft (function (string &optional vector) symbol)) - (keymap-parent (function (cons) (or cons null))) - (length< (function (sequence fixnum) boolean)) - (length> (function (sequence fixnum) boolean)) - (length= (function (sequence fixnum) boolean)) - (line-beginning-position (function (&optional integer) integer)) - (line-end-position (function (&optional integer) integer)) - (local-variable-if-set-p (function (symbol &optional buffer) boolean)) - (local-variable-p (function (symbol &optional buffer) boolean)) - (locale-info (function ((member codeset days months paper)) - (or null string))) - (log (function (number number) float)) - (log10 (function (number) float)) - ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? - (lsh (function (integer integer) integer)) - (make-byte-code (function ((or fixnum list) string vector integer &optional - string t &rest t) - vector)) - (make-list (function (integer t) list)) - (make-string (function (integer fixnum &optional t) string)) - (make-symbol (function (string) symbol)) - (marker-buffer (function (marker) buffer)) - (minibuffer-selected-window (function () window)) - (minibuffer-window (function (&optional frame) window)) - (multibyte-char-to-unibyte (function (fixnum) fixnum)) - (next-window (function (&optional window t t) window)) - (number-to-string (function (number) string)) - (parse-colon-path (function (string) cons)) - (previous-window (function (&optional window t t) window)) - (prin1-to-string (function (t &optional t) string)) - (propertize (function (string &rest t) string)) - (degrees-to-radians (function (number) float)) - (radians-to-degrees (function (number) float)) - (read-from-string (function (string &ptional integer integer) cons)) - (region-beginning (function () integer)) - (region-end (function () integer)) - (reverse (function (sequence) sequence)) - (sin (function (number) float)) - (string (function (&rest fixnum) strng)) (get-largest-window (function (&optional t t t) window)) (get-lru-window (function (&optional t t t) window)) - (one-window-p (function (&optional t t) boolean)) - (regexp-quote (function (string) string)) - (proper-list-p (function (t) integer)) - (nth (function (integer list) t)) - (nthcdr (function (integer list) list)) - (last (function (list &optional integer) list)) - (length (function (sequence) integer)) - (memq (function (t list) list)) - (memql (function (t list) list)) - (member (function (t list) list)) - (assq (function (t list) list)) - (rassq (function (t list) list)) - (rassoc (function (t list) list)) - (plist-get (function (list t) t)) - (lax-plist-get (function (list t) t)) - (plist-member (function (list t) list)) - (aref (function (array fixnum) t)) - (elt (function (sequence integer) t)) - (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) - (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) - (bool-vector-count-population (function (bool-vector) fixnum)) - (bool-vector-count-consecutive (function (bool-vector bool-vector integer) - fixnum)) - ;; side-effect-and-error-free-fns - (arrayp (function (t) boolean)) - (atom (function (t) boolean)) - (bignump (function (t) boolean)) - (bobp (function () boolean)) - (bolp (function () boolean)) - (bool-vector-p (function (t) boolean)) - (buffer-end (function ((or number marker)) integer)) - (buffer-list (function (&optional frame) list)) - (buffer-size (function (&optional buffer) integer)) - (buffer-string (function () string)) - (bufferp (function (t) boolean)) - (car-safe (function (t) t)) - (case-table-p (function (t) boolean)) - (cdr-safe (function (t) t)) - (char-or-string-p (function (t) boolean)) - (characterp (function (t &optional t) boolean)) - (charsetp (function (t) boolean)) - (commandp (function (t &optional t) boolean)) - (consp (function (t) boolean)) - (current-buffer (function () buffer)) - (current-global-map (function () cons)) - (current-indentation (function () integer)) - (current-local-map (function () cons)) - (current-minor-mode-maps (function () cons)) - (current-time (function () cons)) - (eobp (function () boolean)) - (eolp (function () boolean)) - (equal (function (t t) boolean)) - (eventp (function (t) boolean)) - (fixnump (function (t) boolean)) - (floatp (function (t) boolean)) - (following-char (function () fixnum)) - (framep (function (t) boolean)) + (getenv (function (string &optional frame) (or null string))) + (gethash (function (t hash-table &optional t) t)) + (hash-table-count (function (hash-table) integer)) (hash-table-p (function (t) boolean)) (identity (function (t) t)) (ignore (function (&rest t) null)) - (integerp (function (t) boolean)) + (int-to-string (function (number) string)) (integer-or-marker-p (function (t) boolean)) + (integerp (function (t) boolean)) (interactive-p (function () boolean)) + (intern-soft (function (string &optional vector) symbol)) (invocation-directory (function () string)) (invocation-name (function () string)) + (isnan (function (float) boolean)) + (keymap-parent (function (cons) (or cons null))) (keymapp (function (t) boolean)) (keywordp (function (t) boolean)) + (last (function (list &optional integer) list)) + (lax-plist-get (function (list t) t)) + (ldexp (function (number integer) float)) + (length (function (sequence) integer)) + (length< (function (sequence fixnum) boolean)) + (length= (function (sequence fixnum) boolean)) + (length> (function (sequence fixnum) boolean)) + (line-beginning-position (function (&optional integer) integer)) + (line-end-position (function (&optional integer) integer)) (list (function (&rest t) list)) (listp (function (t) boolean)) + (local-variable-if-set-p (function (symbol &optional buffer) boolean)) + (local-variable-p (function (symbol &optional buffer) boolean)) + (locale-info (function ((member codeset days months paper)) (or null string))) + (log (function (number number) float)) + (log10 (function (number) float)) + (logand (function (&rest (or integer marker)) integer)) + (logb (function (number) integer)) + (logcount (function (integer) integer)) + (logior (function (&rest (or integer marker)) integer)) + (lognot (function (integer) integer)) + (logxor (function (&rest (or integer marker)) integer)) + ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? + (lsh (function (integer integer) integer)) + (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector)) + (make-list (function (integer t) list)) (make-marker (function () marker)) + (make-string (function (integer fixnum &optional t) string)) + (make-symbol (function (string) symbol)) (mark (function (&optional t) (or integer null))) (mark-marker (function () marker)) + (marker-buffer (function (marker) buffer)) (markerp (function (t) boolean)) + (max (function ((or number marker) &rest (or number marker)) number)) (max-char (function () fixnum)) + (member (function (t list) list)) (memory-limit (function () integer)) + (memq (function (t list) list)) + (memql (function (t list) list)) + (min (function ((or number marker) &rest (or number marker)) number)) + (minibuffer-selected-window (function () window)) + (minibuffer-window (function (&optional frame) window)) + (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) (mouse-movement-p (function (t) boolean)) + (multibyte-char-to-unibyte (function (fixnum) fixnum)) (natnump (function (t) boolean)) + (next-window (function (&optional window t t) window)) (nlistp (function (t) boolean)) (not (function (t) boolean)) + (nth (function (integer list) t)) + (nthcdr (function (integer list) list)) (null (function (t) boolean)) (number-or-marker-p (function (t) boolean)) + (number-to-string (function (number) string)) (numberp (function (t) boolean)) + (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) + (parse-colon-path (function (string) cons)) + (plist-get (function (list t) t)) + (plist-member (function (list t) list)) (point (function () integer)) (point-marker (function () marker)) - (point-min (function () integer)) (point-max (function () integer)) + (point-min (function () integer)) (preceding-char (function () fixnum)) + (previous-window (function (&optional window t t) window)) + (prin1-to-string (function (t &optional t) string)) (processp (function (t) boolean)) + (proper-list-p (function (t) integer)) + (propertize (function (string &rest t) string)) + (radians-to-degrees (function (number) float)) + (rassoc (function (t list) list)) + (rassq (function (t list) list)) + (read-from-string (function (string &ptional integer integer) cons)) (recent-keys (function (&optional (or cons null)) vector)) (recursion-depth (function () integer)) + (regexp-opt (function (list) string)) + (regexp-quote (function (string) string)) + (region-beginning (function () integer)) + (region-end (function () integer)) + (reverse (function (sequence) sequence)) + (round (function (number &optional number) integer)) (safe-length (function (t) integer)) (selected-frame (function () frame)) (selected-window (function () window)) (sequencep (function (t) boolean)) + (sin (function (number) float)) + (sqrt (function (number) float)) (standard-case-table (function () char-table)) (standard-syntax-table (function () char-table)) + (string (function (&rest fixnum) strng)) + (string-as-multibyte (function (string) string)) + (string-as-unibyte (function (string) string)) + (string-equal (function ((or string symbol) (or string symbol)) boolean)) + (string-lessp (function ((or string symbol) (or string symbol)) boolean)) + (string-make-multibyte (function (string) string)) + (string-make-unibyte (function (string) string)) + (string-search (function (string string &optional integer) integer)) + (string-to-char (function (string) fixnum)) + (string-to-multibyte (function (string) string)) + (string-to-number (function (string &optional integer) number)) + (string-to-syntax (function (string) cons)) + (string< (function ((or string symbol) (or string symbol)) boolean)) + (string= (function ((or string symbol) (or string symbol)) boolean)) (stringp (function (t) boolean)) (subrp (function (t) boolean)) + (substring (function ((or string vector) &optional integer integer) (or string vector))) + (sxhash (function (t) integer)) + (sxhash-eq (function (t) integer)) + (sxhash-eql (function (t) integer)) + (sxhash-equal (function (t) integer)) + (symbol-function (function (symbol) t)) + (symbol-name (function (symbol) string)) + (symbol-plist (function (symbol) list)) + (symbol-value (function (symbol) t)) (symbolp (function (t) boolean)) (syntax-table (function () char-table)) (syntax-table-p (function (t) boolean)) + (tan (function (number) float)) (this-command-keys (function () string)) (this-command-keys-vector (function () vector)) (this-single-command-keys (function () vector)) (this-single-command-raw-keys (function () vector)) + (time-convert (function (t &optional (or boolean integer)) cons)) + (truncate (function (number &optional number) integer)) (type-of (function (t) symbol)) + (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum + (upcase (function ((or fixnum string)) (or fixnum string))) + (user-full-name (function (&optional integer) string)) + (user-login-name (function (&optional integer) (or string null))) + (user-original-login-name (function (&optional integer) (or string null))) (user-real-login-name (function () string)) (user-real-uid (function () integer)) (user-uid (function () integer)) + (vconcat (function (&rest sequence) vector)) (vector (function (&rest t) vector)) (vectorp (function (t) boolean)) (visible-frame-list (function () list)) @@ -496,6 +480,7 @@ Useful to hook into pass checkers.") (window-live-p (function (t) boolean)) (window-valid-p (function (t) boolean)) (windowp (function (t) boolean)) + (zerop (function (number) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons)) From e81643bef500e1f1ec49d152f7db1ffc5a74ecd5 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 31 Dec 2020 11:27:53 +0100 Subject: [PATCH 1276/1452] * Add `comp-insert-insn' * lisp/emacs-lisp/comp.el (comp-insert-insn): New inline. (comp-emit-call-cstr): Split logic and call `comp-insert-insn'. --- lisp/emacs-lisp/comp.el | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6ade0b99db..d7578fdcc07 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2391,17 +2391,22 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-emit-assume 'and target-mvar cstr block-target negated)) finally (cl-return-from in-the-basic-block))))))) -(defun comp-emit-call-cstr (mvar call-cell cstr) - "Emit a constraint CSTR for MVAR after CALL-CELL." - (let* ((next-cell (cdr call-cell)) - (new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) - ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and - ;; fwprop convergence!! - (new-cell `((assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))) - (setf (cdr call-cell) new-cell +(defsubst comp-insert-insn (insn insn-cell) + "Insert INSN as second insn of INSN-CELL." + (let ((next-cell (cdr insn-cell)) + (new-cell `(,insn))) + (setf (cdr insn-cell) new-cell (cdr new-cell) next-cell (comp-func-ssa-status comp-func) 'dirty))) +(defun comp-emit-call-cstr (mvar call-cell cstr) + "Emit a constraint CSTR for MVAR after CALL-CELL." + (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and + ;; fwprop convergence!! + (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr)))) + (comp-insert-insn insn call-cell))) + (defun comp-lambda-list-gen (lambda-list) "Return a generator to iterate over LAMBDA-LIST." (lambda () From f78580a0f5b913c60862d2ddedfc6b80e5cb4791 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 31 Dec 2020 15:27:24 +0100 Subject: [PATCH 1277/1452] * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords): Color returns as red. --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7578fdcc07..a6704e8c180 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -894,6 +894,8 @@ Assume allocation class 'd-default as default." (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) + (,(rx bol "(" (group-n 1 "return")) + (1 font-lock-warning-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") (1+ num) (? (or "_latch" From e9f5fadb0ecb64148472f846a99a0d7e95daeaee Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 31 Dec 2020 15:32:51 +0100 Subject: [PATCH 1278/1452] * Fix two predicates for missing negation handling * lisp/emacs-lisp/comp-cstr.el (comp-cstr-empty-p) (comp-cstr-null-p): Fix missing negation handling. --- lisp/emacs-lisp/comp-cstr.el | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c03056e3afe..a53372be006 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -139,14 +139,16 @@ Integer values are handled in the `range' slot.") (with-comp-cstr-accessors (and (null (typeset cstr)) (null (valset cstr)) - (null (range cstr))))) + (null (range cstr)) + (null (neg cstr))))) -(defsubst comp-cstr-null-p (x) +(defsubst comp-cstr-null-p (cstr) "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise." (with-comp-cstr-accessors - (and (null (typeset x)) - (null (range x)) - (equal (valset x) '(nil))))) + (and (null (typeset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (valset cstr) '(nil))))) (defun comp-cstrs-homogeneous (cstrs) "Check if constraints CSTRS are all homogeneously negated or non-negated. From 67c443adc1ef8a03d27c6172247e792421bb0e13 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 31 Dec 2020 17:37:13 +0100 Subject: [PATCH 1279/1452] Introduce 'unreachable' LIMPLE operator Introduce 'unreachable' as LIMPLE operater so we can handle correctly in the CFG functions throwing values or signaling errors. * src/comp.c (retrive_block): Better error diagnostic. (emit_limple_insn): Add `unreachable'. (compile_function): Fix block iteration. (syms_of_comp): Define 'Qunreachable'. * lisp/emacs-lisp/comp.el (comp-block): New variable. (comp-block-lap): Add `non-ret-insn' slot. (comp-branch-op-p): New predicate. (comp-limple-lock-keywords): Color `unreachable' as red. (comp-compute-edges): Add `unreachable'. (comp-fwprop-call): Store non returning function call. (comp-fwprop*): Update. (comp-clean-orphan-blocks, comp-rewrite-non-locals): New functions. (comp-fwprop): Call `comp-rewrite-non-locals'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests. * test/src/comp-test-funcs.el (comp-test-non-local-1) (comp-test-non-local-2, comp-test-non-local-3) (comp-test-non-local-4): New functions. --- lisp/emacs-lisp/comp.el | 82 +++++++++++++++++++++++++++++----- src/comp.c | 47 ++++++++++++-------- test/src/comp-test-funcs.el | 16 +++++++ test/src/comp-tests.el | 88 +++++++++++++++++++++++-------------- 4 files changed, 171 insertions(+), 62 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a6704e8c180..3ef9a6be739 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -537,6 +537,9 @@ Useful to hook into pass checkers.") (defvar comp-func nil "Bound to the current function by most passes.") +(defvar comp-block nil + "Bound to the current basic block by some pass.") + (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" 'native-compiler-error) @@ -637,13 +640,17 @@ Is in use to help the SSA rename pass.")) (:include comp-block) (:constructor make--comp-block-lap (addr sp name))) ; Positional - "A basic block created from lap." + "A basic block created from lap (real code)." ;; These two slots are used during limplification. (sp nil :type number :documentation "When non-nil indicates the sp value while entering into it.") (addr nil :type number - :documentation "Start block LAP address.")) + :documentation "Start block LAP address.") + (non-ret-insn nil :type list + :documentation "Non returning basic blocks. +`comp-fwprop' may identify and store here basic blocks performing +non local exits.")) (cl-defstruct (comp-latch (:copier nil) (:include comp-block)) @@ -843,6 +850,10 @@ To be used by all entry points." "Call predicate for OP." (when (memq op comp-limple-calls) t)) +(defun comp-branch-op-p (op) + "Branch predicate for OP." + (when (memq op comp-limple-branches) t)) + (defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." (comp-call-op-p (car-safe insn))) @@ -894,7 +905,7 @@ Assume allocation class 'd-default as default." (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) - (,(rx bol "(" (group-n 1 "return")) + (,(rx bol "(" (group-n 1 (or "return" "unreachable"))) (1 font-lock-warning-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") @@ -2581,6 +2592,7 @@ blocks." (make-comp-edge :src bb :dst (gethash third blocks)) (make-comp-edge :src bb :dst (gethash forth blocks))) (return) + (unreachable) (otherwise (signal 'native-ice (list "block does not end with a branch" @@ -2936,6 +2948,9 @@ Fold the call in case." args (cdr args))) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (let ((cstr (comp-cstr-f-ret cstr-f))) + (when (comp-cstr-empty-p cstr) + ;; Store it to be rewrittein as non local exit. + (setf (comp-block-lap-non-ret-insn comp-block) insn)) (setf (comp-mvar-range lval) (comp-cstr-range cstr) (comp-mvar-valset lval) (comp-cstr-valset cstr) (comp-mvar-typeset lval) (comp-cstr-typeset cstr) @@ -2997,15 +3012,61 @@ Fold the call in case." Return t if something was changed." (cl-loop with modified = nil for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop for insn in (comp-block-insns b) - for orig-insn = (unless modified - ;; Save consing after 1th change. - (comp-copy-insn insn)) - do (comp-fwprop-insn insn) - when (and (null modified) (not (equal insn orig-insn))) - do (setf modified t)) + do (cl-loop + with comp-block = b + for insn in (comp-block-insns b) + for orig-insn = (unless modified + ;; Save consing after 1th change. + (comp-copy-insn insn)) + do (comp-fwprop-insn insn) + when (and (null modified) (not (equal insn orig-insn))) + do (setf modified t)) finally return modified)) +(defun comp-clean-orphan-blocks (block) + "Iterativelly remove all non reachable blocks orphaned by BLOCK." + (while + (cl-loop + with repeat = nil + with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + when (and (not (eq (comp-block-name bb) 'entry)) + (cl-notany (lambda (ed) + (and (gethash (comp-block-name (comp-edge-src ed)) + blocks) + (not (eq (comp-edge-src ed) block)))) + (comp-block-in-edges bb))) + do + (comp-log (format "Removing block: %s" (comp-block-name bb)) 1) + (remhash (comp-block-name bb) blocks) + (setf repeat t) + finally return repeat))) + +(defun comp-rewrite-non-locals () + "Make explicit in LIMPLE non-local exits if identified." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + for non-local-insn = (and (comp-block-lap-p bb) + (comp-block-lap-non-ret-insn bb)) + when non-local-insn + do + (cl-loop + for ed in (comp-block-out-edges bb) + for dst-bb = (comp-edge-dst ed) + ;; Remove one or more block if necessary. + when (length= (comp-block-in-edges dst-bb) 1) + do + (comp-log (format "Removing block: %s" (comp-block-name dst-bb)) 1) + (remhash (comp-block-name dst-bb) (comp-func-blocks comp-func)) + (comp-clean-orphan-blocks bb)) + ;; Rework the current block. + (let* ((insn-seq (memq non-local-insn (comp-block-insns bb)))) + (setf (comp-block-lap-non-ret-insn bb) () + (comp-block-out-edges bb) () + ;; Prune unnecessary insns! + (cdr insn-seq) '((unreachable)) + (comp-func-ssa-status comp-func) 'dirty)))) + (defun comp-fwprop (_) "Forward propagate types and consts within the lattice." (comp-ssa) @@ -3024,6 +3085,7 @@ Return t if something was changed." 'comp (format "fwprop pass jammed into %s?" (comp-func-name f)))) (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-rewrite-non-locals) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) diff --git a/src/comp.c b/src/comp.c index 04bf9973d26..da4361030b1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -753,7 +753,7 @@ retrive_block (Lisp_Object block_name) Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); if (NILP (value)) - xsignal1 (Qnative_ice, build_string ("missing basic block")); + xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name); return (gcc_jit_block *) xmint_pointer (value); } @@ -2282,6 +2282,13 @@ emit_limple_insn (Lisp_Object insn) NULL, emit_mvar_rval (arg[0])); } + else if (EQ (op, Qunreachable)) + { + /* Libgccjit has no __builtin_unreachable. */ + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_lisp_obj_rval (Qnil)); + } else { xsignal2 (Qnative_ice, @@ -3910,13 +3917,13 @@ compile_function (Lisp_Object func) The "entry" block must be declared as first. */ declare_block (Qentry); Lisp_Object blocks = CALL1I (comp-func-blocks, func); - Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); - for (ptrdiff_t i = 0; i < ht->count; i++) + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) { - Lisp_Object block = HASH_VALUE (ht, i); - if (!EQ (block, entry_block)) - declare_block (HASH_KEY (ht, i)); + Lisp_Object block_name = HASH_KEY (ht, i); + if (!EQ (block_name, Qentry) + && !EQ (block_name, Qunbound)) + declare_block (block_name); } gcc_jit_block_add_assignment (retrive_block (Qentry), @@ -3925,21 +3932,24 @@ compile_function (Lisp_Object func) gcc_jit_lvalue_as_rvalue (comp.func_relocs)); - for (ptrdiff_t i = 0; i < ht->count; i++) + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) { Lisp_Object block_name = HASH_KEY (ht, i); - Lisp_Object block = HASH_VALUE (ht, i); - Lisp_Object insns = CALL1I (comp-block-insns, block); - if (NILP (block) || NILP (insns)) - xsignal1 (Qnative_ice, - build_string ("basic block is missing or empty")); - - comp.block = retrive_block (block_name); - while (CONSP (insns)) + if (!EQ (block_name, Qunbound)) { - Lisp_Object insn = XCAR (insns); - emit_limple_insn (insn); - insns = XCDR (insns); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = CALL1I (comp-block-insns, block); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); @@ -5098,6 +5108,7 @@ compiled one. */); DEFSYM (Qassume, "assume"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); + DEFSYM (Qunreachable, "unreachable"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qphi, "phi"); diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 49e80763bee..1c2fb3d3c0b 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -621,6 +621,22 @@ (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)))) + (provide 'comp-test-funcs) ;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4546eccb622..9801136152a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -949,50 +949,50 @@ Return a list of results." ;; 22 ((defun comp-tests-ret-type-spec-f (x) - (when (> x 3) - x)) + (when (> x 3) + x)) (or null float (integer 4 *))) ;; 23 ((defun comp-tests-ret-type-spec-f (x) - (when (>= x 3) - x)) + (when (>= x 3) + x)) (or null float (integer 3 *))) ;; 24 ((defun comp-tests-ret-type-spec-f (x) - (when (< x 3) - x)) + (when (< x 3) + x)) (or null float (integer * 2))) ;; 25 ((defun comp-tests-ret-type-spec-f (x) - (when (<= x 3) - x)) + (when (<= x 3) + x)) (or null float (integer * 3))) ;; 26 ((defun comp-tests-ret-type-spec-f (x) - (when (> 3 x) - x)) + (when (> 3 x) + x)) (or null float (integer * 2))) ;; 27 ((defun comp-tests-ret-type-spec-f (x) - (when (>= 3 x) - x)) + (when (>= 3 x) + x)) (or null float (integer * 3))) ;; 28 ((defun comp-tests-ret-type-spec-f (x) - (when (< 3 x) - x)) + (when (< 3 x) + x)) (or null float (integer 4 *))) ;; 29 ((defun comp-tests-ret-type-spec-f (x) - (when (<= 3 x) - x)) + (when (<= 3 x) + x)) (or null float (integer 3 *))) ;; 30 @@ -1032,8 +1032,8 @@ Return a list of results." ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) - (when (> x 1.0) - x)) + (when (> x 1.0) + x)) (or null marker number)) ;; 36 @@ -1061,17 +1061,17 @@ Return a list of results." ;; 39 ;; SBCL gives: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= 1 x 10) - (<= 2 y 3)) - (+ x y))) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) (or null float (integer 3 13))) ;; 40 ;; SBCL: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= 1 x 10) - (<= 2 y 3)) - (- x y))) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) (or null float (integer -2 8))) ;; 41 @@ -1090,23 +1090,23 @@ Return a list of results." ;; 43 ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= x 10) - (<= 2 y)) - (- x y))) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) (or null float (integer * 8))) ;; 44 ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= x 10) - (<= y 3)) - (- x y))) + (when (and (<= x 10) + (<= y 3)) + (- x y))) (or null float integer)) ;; 45 ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= 2 x) - (<= 3 y)) - (- x y))) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) (or null float integer)) ;; 46 @@ -1176,7 +1176,27 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (unless (integerp x) x)) - (not integer)))) + (not integer)) + + ;; 56 + ((defun comp-tests-ret-type-spec-f (x) + (cl-ecase x + (1 (message "one")) + (5 (message "five"))) + x) + t + ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block + ;; boundary if necessary as this should return: + ;; (or (integer 1 1) (integer 5 5)) + ) + + ;; 57 + ((defun comp-tests-ret-type-spec-f (x) + (unless (or (eq x 'foo) + (= x 3)) + (error "Not foo or 3")) + x) + (or (member foo) (integer 3 3))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 6ba94f7c77b4013e15f8a5a9181fba9a2df20ab7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 Jan 2021 12:27:39 +0100 Subject: [PATCH 1280/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Fix hash table iteration. --- src/comp.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index da4361030b1..2670c917ed6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4413,12 +4413,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, struct Lisp_Hash_Table *func_h = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); - for (ptrdiff_t i = 0; i < func_h->count; i++) - declare_function (HASH_VALUE (func_h, i)); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) + if (!EQ (HASH_VALUE (func_h, i), Qunbound)) + declare_function (HASH_VALUE (func_h, i)); /* Compile all functions. Can't be done before because the relocation structs has to be already defined. */ - for (ptrdiff_t i = 0; i < func_h->count; i++) - compile_function (HASH_VALUE (func_h, i)); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) + if (!EQ (HASH_VALUE (func_h, i), Qunbound)) + compile_function (HASH_VALUE (func_h, i)); add_driver_options (); From 93ff838575d25eba76bb0b3d476a36a56bbfba30 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 Jan 2021 11:09:00 +0100 Subject: [PATCH 1281/1452] * Clean unreachable block using dominance tree to handle circularities With this commit unreachable basic blocks are pruned automatically by comp-ssa relying on dominance analysis. This solves the issue of unreachable cluster of basic blocks referencing each other. * lisp/emacs-lisp/comp.el (comp-block-lap): New `no-ret' slot. (comp-compute-dominator-tree): Update. (comp-remove-unreachable-blocks): New functions. (comp-ssa): Update to call `comp-remove-unreachable-blocks'. (comp-clean-orphan-blocks): Delete. (comp-rewrite-non-locals): Update and simplify. --- lisp/emacs-lisp/comp.el | 66 +++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 35 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ef9a6be739..227333f72c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -648,9 +648,12 @@ into it.") (addr nil :type number :documentation "Start block LAP address.") (non-ret-insn nil :type list - :documentation "Non returning basic blocks. + :documentation "Insn known to perform a non local exit. `comp-fwprop' may identify and store here basic blocks performing -non local exits.")) +non local exits and mark it rewrite it later.") + (no-ret nil :type boolean + :documentation "t when the block is known to perform a +non local exit (ends with an `unreachable' insn).")) (cl-defstruct (comp-latch (:copier nil) (:include comp-block)) @@ -2669,7 +2672,9 @@ blocks." when (comp-block-dom p) do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) new-idom + do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) + (comp-block-lap-no-ret new-idom)) + new-idom) changed t)))))) (defun comp-compute-dominator-frontiers () @@ -2824,16 +2829,34 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." when (eq op 'phi) do (finalize-phi args b))))) +(defun comp-remove-unreachable-blocks () + "Remove unreachable basic blocks. +Return t when one or more block was removed, nil otherwise." + (cl-loop + with ret + for bb being each hash-value of (comp-func-blocks comp-func) + for bb-name = (comp-block-name bb) + when (and (not (eq 'entry bb-name)) + (null (comp-block-dom bb))) + do + (comp-log (format "Removing block: %s" bb-name) 1) + (remhash bb-name (comp-func-blocks comp-func)) + (setf (comp-func-ssa-status comp-func) t + ret t) + finally return ret)) + (defun comp-ssa () "Port all functions into minimal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) (ssa-status (comp-func-ssa-status f))) (unless (eq ssa-status t) - (when (eq ssa-status 'dirty) - (comp-clean-ssa f)) - (comp-compute-edges) - (comp-compute-dominator-tree) + (cl-loop + when (eq ssa-status 'dirty) + do (comp-clean-ssa f) + do (comp-compute-edges) + (comp-compute-dominator-tree) + until (null (comp-remove-unreachable-blocks))) (comp-compute-dominator-frontiers) (comp-log-block-info) (comp-place-phis) @@ -3023,25 +3046,6 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-clean-orphan-blocks (block) - "Iterativelly remove all non reachable blocks orphaned by BLOCK." - (while - (cl-loop - with repeat = nil - with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - when (and (not (eq (comp-block-name bb) 'entry)) - (cl-notany (lambda (ed) - (and (gethash (comp-block-name (comp-edge-src ed)) - blocks) - (not (eq (comp-edge-src ed) block)))) - (comp-block-in-edges bb))) - do - (comp-log (format "Removing block: %s" (comp-block-name bb)) 1) - (remhash (comp-block-name bb) blocks) - (setf repeat t) - finally return repeat))) - (defun comp-rewrite-non-locals () "Make explicit in LIMPLE non-local exits if identified." (cl-loop @@ -3050,18 +3054,10 @@ Return t if something was changed." (comp-block-lap-non-ret-insn bb)) when non-local-insn do - (cl-loop - for ed in (comp-block-out-edges bb) - for dst-bb = (comp-edge-dst ed) - ;; Remove one or more block if necessary. - when (length= (comp-block-in-edges dst-bb) 1) - do - (comp-log (format "Removing block: %s" (comp-block-name dst-bb)) 1) - (remhash (comp-block-name dst-bb) (comp-func-blocks comp-func)) - (comp-clean-orphan-blocks bb)) ;; Rework the current block. (let* ((insn-seq (memq non-local-insn (comp-block-insns bb)))) (setf (comp-block-lap-non-ret-insn bb) () + (comp-block-lap-no-ret bb) t (comp-block-out-edges bb) () ;; Prune unnecessary insns! (cdr insn-seq) '((unreachable)) From c29037c877ae0d606daf3949dfc3e4e43883d74f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 Jan 2021 12:00:04 +0100 Subject: [PATCH 1282/1452] * lisp/emacs-lisp/comp.el (comp-compute-dominator-tree): Fix. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 227333f72c8..848bcf70cdb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2650,7 +2650,7 @@ blocks." (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. - (bb1 (gethash 'bb_1 blocks))) + (bb0 (gethash 'bb_0 blocks))) (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) with changed = t while changed From 807471f9ffd303048140175932cf6b1e09eb7652 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 Jan 2021 13:53:08 +0100 Subject: [PATCH 1283/1452] ; * lisp/emacs-lisp/comp.el (comp-compute-dominator-tree): Reindent. --- lisp/emacs-lisp/comp.el | 52 +++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 848bcf70cdb..9fea3451359 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2651,31 +2651,33 @@ blocks." (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. (bb0 (gethash 'bb_0 blocks))) - (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) - with changed = t - while changed - initially (progn - (comp-log "Computing dominator tree...\n" 2) - (setf (comp-block-dom entry) entry) - ;; Set the post order number. - (cl-loop for name in (reverse rev-bb-list) - for b = (gethash name blocks) - for i from 0 - do (setf (comp-block-post-num b) i))) - do (cl-loop - for name in (cdr rev-bb-list) - for b = (gethash name blocks) - for preds = (comp-block-preds b) - for new-idom = (first-processed preds) - initially (setf changed nil) - do (cl-loop for p in (delq new-idom preds) - when (comp-block-dom p) - do (setf new-idom (intersect p new-idom))) - unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) - (comp-block-lap-no-ret new-idom)) - new-idom) - changed t)))))) + (cl-loop + with rev-bb-list = (comp-collect-rev-post-order entry) + with changed = t + while changed + initially (progn + (comp-log "Computing dominator tree...\n" 2) + (setf (comp-block-dom entry) entry) + ;; Set the post order number. + (cl-loop for name in (reverse rev-bb-list) + for b = (gethash name blocks) + for i from 0 + do (setf (comp-block-post-num b) i))) + do (cl-loop + for name in (cdr rev-bb-list) + for b = (gethash name blocks) + for preds = (comp-block-preds b) + for new-idom = (first-processed preds) + initially (setf changed nil) + do (cl-loop for p in (delq new-idom preds) + when (comp-block-dom p) + do (setf new-idom (intersect p new-idom))) + unless (eq (comp-block-dom b) new-idom) + do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) + (comp-block-lap-no-ret + new-idom)) + new-idom) + changed t)))))) (defun comp-compute-dominator-frontiers () "Compute the dominator frontier for each basic block in `comp-func'." From 9420ea6e0840bffcb140d3677dfdabb9251c1f63 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 1 Jan 2021 14:13:02 +0100 Subject: [PATCH 1284/1452] Add `throw' to non returning functions * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add throw. --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9fea3451359..340846bf70a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2,7 +2,7 @@ ;; Author: Andrea Corallo -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Keywords: lisp ;; Package: emacs @@ -485,6 +485,7 @@ Useful to hook into pass checkers.") (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons)) ;; Non returning functions + (throw (function (t t) nil)) (error (function (string &rest t) nil)) (signal (function (symbol t) nil))) "Alist used for type propagation.") From 03be03d36636626d4c45acd76e2f2d36be02ec8c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Jan 2021 11:30:10 +0100 Subject: [PATCH 1285/1452] * Rename `dom' slot into `idom' in `comp-block' struct * lisp/emacs-lisp/comp.el (comp-block): Rename dom `slot' into `idom'. (comp-clean-ssa, comp-compute-dominator-tree) (comp-compute-dominator-frontiers, comp-dom-tree-walker) (comp-remove-unreachable-blocks): Update accordingly. --- lisp/emacs-lisp/comp.el | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 340846bf70a..ab3763f5edf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -627,7 +627,7 @@ This is typically for top-level forms other than defun.") :documentation "List of incoming edges.") (out-edges () :type list :documentation "List of out-coming edges.") - (dom nil :type (or null comp-block) + (idom nil :type (or null comp-block) :documentation "Immediate dominator.") (df (make-hash-table) :type (or null hash-table) :documentation "Dominance frontier set. Block-name -> block") @@ -2568,7 +2568,7 @@ blocks." for b being each hash-value of (comp-func-blocks f) do (setf (comp-block-in-edges b) () (comp-block-out-edges b) () - (comp-block-dom b) nil + (comp-block-idom b) nil (comp-block-df b) (make-hash-table) (comp-block-post-num b) nil (comp-block-final-frame b) nil @@ -2637,14 +2637,14 @@ blocks." (finger2 (comp-block-post-num b2))) (while (not (= finger1 finger2)) (while (< finger1 finger2) - (setf b1 (comp-block-dom b1) + (setf b1 (comp-block-idom b1) finger1 (comp-block-post-num b1))) (while (< finger2 finger1) - (setf b2 (comp-block-dom b2) + (setf b2 (comp-block-idom b2) finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) + (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l))) p (signal 'native-ice "cant't find first preprocessed")))) @@ -2658,7 +2658,7 @@ blocks." while changed initially (progn (comp-log "Computing dominator tree...\n" 2) - (setf (comp-block-dom entry) entry) + (setf (comp-block-idom entry) entry) ;; Set the post order number. (cl-loop for name in (reverse rev-bb-list) for b = (gethash name blocks) @@ -2671,10 +2671,10 @@ blocks." for new-idom = (first-processed preds) initially (setf changed nil) do (cl-loop for p in (delq new-idom preds) - when (comp-block-dom p) + when (comp-block-idom p) do (setf new-idom (intersect p new-idom))) - unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) + unless (eq (comp-block-idom b) new-idom) + do (setf (comp-block-idom b) (unless (and (comp-block-lap-p new-idom) (comp-block-lap-no-ret new-idom)) new-idom) @@ -2691,14 +2691,14 @@ blocks." when (>= (length preds) 2) ; All joins do (cl-loop for p in preds for runner = p - do (while (not (eq runner (comp-block-dom b))) + do (while (not (eq runner (comp-block-idom b))) (puthash b-name b (comp-block-df runner)) - (setf runner (comp-block-dom runner)))))) + (setf runner (comp-block-idom runner)))))) (defun comp-log-block-info () "Log basic blocks info for the current function." (maphash (lambda (name bb) - (let ((dom (comp-block-dom bb)) + (let ((dom (comp-block-idom bb)) (df (comp-block-df bb))) (comp-log (format "block: %s idom: %s DF %s\n" name @@ -2756,7 +2756,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when-let ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) - when (eq bb (comp-block-dom child)) + when (eq bb (comp-block-idom child)) ;; Current block is the immediate dominator then recur. do (comp-dom-tree-walker child pre-lambda post-lambda))) (when post-lambda @@ -2840,7 +2840,7 @@ Return t when one or more block was removed, nil otherwise." for bb being each hash-value of (comp-func-blocks comp-func) for bb-name = (comp-block-name bb) when (and (not (eq 'entry bb-name)) - (null (comp-block-dom bb))) + (null (comp-block-idom bb))) do (comp-log (format "Removing block: %s" bb-name) 1) (remhash bb-name (comp-func-blocks comp-func)) From 43d0e8483e5b51aec1347b8a2ed53acae34a9811 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Jan 2021 12:18:39 +0100 Subject: [PATCH 1286/1452] Fix `functionp' contraining (bug#45576) * lisp/emacs-lisp/comp.el (comp-known-predicates) (comp-known-predicates-h): New constants. (comp-known-predicate-p, comp-pred-to-cstr): New functions. * lisp/emacs-lisp/cl-macs.el (cl-deftype-satisfies): Don't define. * test/src/comp-tests.el (comp-test-45576): New testcase. * test/src/comp-test-funcs.el (comp-test-45576-f): New function. --- lisp/emacs-lisp/cl-macs.el | 3 +-- lisp/emacs-lisp/comp-cstr.el | 6 +---- lisp/emacs-lisp/comp.el | 49 +++++++++++++++++++++++++++++++++--- test/src/comp-test-funcs.el | 8 ++++++ test/src/comp-tests.el | 5 ++++ 5 files changed, 60 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 664d865cffd..ac7360b935b 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3199,8 +3199,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; FIXME: Do we really want to consider this a type? (integer-or-marker . integer-or-marker-p) )) - (put type 'cl-deftype-satisfies pred) - (put pred 'cl-satisfies-deftype type)) + (put type 'cl-deftype-satisfies pred)) ;;;###autoload (define-inline cl-typep (val type) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index a53372be006..e63afa16a23 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -2,7 +2,7 @@ ;; Author: Andrea Corallo -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Keywords: lisp ;; Package: emacs @@ -179,10 +179,6 @@ Return them as multiple value." (defvar comp-cstr-one (comp-value-to-cstr 1) "Represent the integer immediate one.") -(defun comp-pred-to-cstr (predicate) - "Given PREDICATE return the correspondig constraint." - (comp-type-to-cstr (get predicate 'cl-satisfies-deftype))) - ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ab3763f5edf..455fd72efcd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -500,6 +500,51 @@ Useful to hook into pass checkers.") finally return h) "Hash table function -> `comp-constraint'") +(defconst comp-known-predicates + '((arrayp . array) + (atom . atom) + (characterp . base-char) + (booleanp . boolean) + (bool-vector-p . bool-vector) + (bufferp . buffer) + (natnump . character) + (char-table-p . char-table) + (hash-table-p . hash-table) + (consp . cons) + (integerp . fixnum) + (floatp . float) + (functionp . (or function symbol)) + (integerp . integer) + (keywordp . keyword) + (listp . list) + (numberp . number) + (null . null) + (numberp . real) + (sequencep . sequence) + (stringp . string) + (symbolp . symbol) + (vectorp . vector) + (integer-or-marker-p . integer-or-marker)) + "Alist predicate -> matched type specifier.") + +(defconst comp-known-predicates-h + (cl-loop + with comp-ctxt = (make-comp-cstr-ctxt) + with h = (make-hash-table :test #'eq) + for (pred . type-spec) in comp-known-predicates + for cstr = (comp-type-spec-to-cstr type-spec) + do (puthash pred cstr h) + finally return h) + "Hash table function -> `comp-constraint'") + +(defun comp-known-predicate-p (predicate) + "Predicate matching if PREDICATE is known." + (when (gethash predicate comp-known-predicates-h) t)) + +(defun comp-pred-to-cstr (predicate) + "Given PREDICATE return the correspondig constraint." + (gethash predicate comp-known-predicates-h)) + (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -2329,10 +2374,6 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) -(defun comp-known-predicate-p (pred) - (when (symbolp pred) - (get pred 'cl-satisfies-deftype))) - (defun comp-add-cond-cstrs () "`comp-add-cstrs' worker function for each selected function." (cl-loop diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 1c2fb3d3c0b..d0ec6365819 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -455,6 +455,14 @@ (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))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9801136152a..faaa2f4e4f8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -482,6 +482,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest comp-test-not-cons () (should-not (comp-test-not-cons-f nil))) +(comp-deftest comp-test-45576 () + "Functionp satisfies also symbols. +." + (should (eq (comp-test-45576-f) 'eval))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From a3f2373bfb604af5570c86b4ffefb23296a5bfdd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 Jan 2021 13:22:30 +0100 Subject: [PATCH 1287/1452] * lisp/emacs-lisp/comp.el (comp-known-predicates): Some more tweaking. --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 455fd72efcd..3247b19c5e2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -503,15 +503,15 @@ Useful to hook into pass checkers.") (defconst comp-known-predicates '((arrayp . array) (atom . atom) - (characterp . base-char) + (characterp . fixnum) (booleanp . boolean) (bool-vector-p . bool-vector) (bufferp . buffer) - (natnump . character) + (natnump . (integer 0 *)) (char-table-p . char-table) (hash-table-p . hash-table) (consp . cons) - (integerp . fixnum) + (integerp . integer) (floatp . float) (functionp . (or function symbol)) (integerp . integer) @@ -519,7 +519,7 @@ Useful to hook into pass checkers.") (listp . list) (numberp . number) (null . null) - (numberp . real) + (numberp . number) (sequencep . sequence) (stringp . string) (symbolp . symbol) From 5074447ef4980e2eb613e908e346fd3471f52139 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Jan 2021 22:04:29 +0100 Subject: [PATCH 1288/1452] Fix type inference for bug#45635 * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Fix missing mixed pos neg handling. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. * test/src/comp-tests.el (45635): New testcase. * test/src/comp-test-funcs.el (comp-test-45635-f): New function. --- lisp/emacs-lisp/comp-cstr.el | 16 ++++++++++++++++ test/lisp/emacs-lisp/comp-cstr-tests.el | 4 +++- test/src/comp-test-funcs.el | 15 +++++++++++++++ test/src/comp-tests.el | 5 +++++ 4 files changed, 39 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index e63afa16a23..651c7b7931e 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -558,6 +558,22 @@ DST is returned." ;; "simple" for now. (give-up)) + ;; When every neg type is a subtype of some pos one. + ;; In case return pos. + (when (and (typeset neg) + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset pos) + (when (range pos) + '(integer))))) + (typeset neg))) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + ;; Verify disjoint condition between positive types and ;; negative types coming from values, in case give-up. (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 1e1376b363b..149afaf85d8 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -207,7 +207,9 @@ ;; 83 ((not t) . nil) ;; 84 - ((not nil) . t)) + ((not nil) . t) + ;; 85 + ((or (not string) t) . t)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index d0ec6365819..694d9d426d5 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -463,6 +463,21 @@ 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))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index faaa2f4e4f8..23a108796b8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -487,6 +487,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ." (should (eq (comp-test-45576-f) 'eval))) +(comp-deftest 45635-1 () + "." + (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga") + "PragmataPro Liga"))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 7293c23d14ed96cc07eeb87f0d974dcc25dcfa98 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Jan 2021 22:14:50 +0100 Subject: [PATCH 1289/1452] * Fix a type specifier test * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Fix a testcase. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 149afaf85d8..f5ed05244d7 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -103,7 +103,7 @@ ;; 30 ((and (member foo) (integer 1 2)) . nil) ;; 31 - ((and (member 1 2) (member 3 2)) . (member 2)) + ((and (member 1 2) (member 3 2)) . (integer 2 2)) ;; 32 ((and number (integer 1 2)) . (integer 1 2)) ;; 33 From 8ad983c4acef60a80e8d6b6ba891b1ef957f2d7c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Jan 2021 22:16:07 +0100 Subject: [PATCH 1290/1452] * test/src/comp-tests.el (cond-rw-1, not-cons, 45576): Rename three tests. --- test/src/comp-tests.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 23a108796b8..19e0940db84 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -475,14 +475,14 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." '(1 2 3 (4 5 6)))) (should (null (comp-test-copy-insn-f nil)))) -(comp-deftest comp-test-cond-rw-1 () +(comp-deftest cond-rw-1 () "Check cond-rw does not break target blocks with multiple predecessor." (should (null (comp-test-cond-rw-1-2-f)))) -(comp-deftest comp-test-not-cons () +(comp-deftest not-cons-1 () (should-not (comp-test-not-cons-f nil))) -(comp-deftest comp-test-45576 () +(comp-deftest 45576-1 () "Functionp satisfies also symbols. ." (should (eq (comp-test-45576-f) 'eval))) From 33b8ce865fcfd58538ae2d7c3fff04998fcd3330 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 6 Jan 2021 15:26:38 +0100 Subject: [PATCH 1291/1452] Fix bug#45603 Reported and reduced by Mauricio Collares. * lisp/emacs-lisp/comp.el (comp-final): Fix coding system for the tmp file used to pass data the child processes. * test/src/comp-tests.el (45603-1): New testcase * test/src/comp-test-45603.el : New File. --- lisp/emacs-lisp/comp.el | 1 + test/src/comp-test-45603.el | 28 ++++++++++++++++++++++++++++ test/src/comp-tests.el | 5 +++++ 3 files changed, 34 insertions(+) create mode 100644 test/src/comp-test-45603.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3247b19c5e2..88b6a4690df 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3550,6 +3550,7 @@ Prepare every function for final compilation and drive the C back-end." (file-name-base output) "-") nil ".el"))) (with-temp-file temp-file + (insert ";; -*-coding: nil; -*-\n") (insert (prin1-to-string expr))) (with-temp-buffer (unwind-protect diff --git a/test/src/comp-test-45603.el b/test/src/comp-test-45603.el new file mode 100644 index 00000000000..f1c0dafb68d --- /dev/null +++ b/test/src/comp-test-45603.el @@ -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) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 19e0940db84..c0325a8d5df 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -492,6 +492,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga") "PragmataPro Liga"))) +(comp-deftest 45603-1 () + "" + (load (native-compile (concat comp-test-directory "comp-test-45603.el"))) + (should (fboundp #'comp-test-45603--file-local-name))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From ad0d553e8f8ddc8cb821944b043cfaec75dbb104 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 4 Jan 2021 22:45:42 +0100 Subject: [PATCH 1292/1452] * Add a type specifier test * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add testcase. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index f5ed05244d7..b4db54666c7 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -209,7 +209,9 @@ ;; 84 ((not nil) . t) ;; 85 - ((or (not string) t) . t)) + ((or (not string) t) . t) + ;; 86 + ((or (not vector) sequence) . sequence)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () From 213b5d73159cafbdd52b9c0fb0479544cca98a77 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 7 Jan 2021 23:10:18 +0100 Subject: [PATCH 1293/1452] * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Fix typo. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 88b6a4690df..d1953b59f04 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -410,7 +410,7 @@ Useful to hook into pass checkers.") (radians-to-degrees (function (number) float)) (rassoc (function (t list) list)) (rassq (function (t list) list)) - (read-from-string (function (string &ptional integer integer) cons)) + (read-from-string (function (string &optional integer integer) cons)) (recent-keys (function (&optional (or cons null)) vector)) (recursion-depth (function () integer)) (regexp-opt (function (list) string)) From 325c0765dfa4ef363d4f29650568bdafce0f0971 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 8 Jan 2021 00:44:55 +0100 Subject: [PATCH 1294/1452] Add new customize `comp-libgccjit-reproducer' * lisp/emacs-lisp/comp.el (comp-libgccjit-reproducer): New customize. * src/comp.c (Fcomp__compile_ctxt_to_file): Use `comp-libgccjit-reproducer' for dumping repoducer. (syms_of_comp): Define 'Qcomp_libgccjit_reproducer'. --- lisp/emacs-lisp/comp.el | 6 ++++++ src/comp.c | 7 +++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d1953b59f04..79cf942e89d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -136,6 +136,12 @@ Passing these options is only available in libgccjit version 9 and above." :type 'list) +(defcustom comp-libgccjit-reproducer nil + "When non-nil produce a libgccjit reproducer. +The reproducer is a file comp_SRCNAME_repro.c deposed in the .eln +output directory." + :type 'boolean) + (defvar comp-dry-run nil "If non-nil, run everything but the C back-end.") diff --git a/src/comp.c b/src/comp.c index 2670c917ed6..f6445a7621d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4428,8 +4428,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (base_name)), 1); - if (comp.debug > 2) - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) + gcc_jit_context_dump_reproducer_to_file ( + comp.ctxt, + format_string ("comp_%s_repro.c", SSDATA (base_name))); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); @@ -5099,6 +5101,7 @@ compiled one. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); DEFSYM (Qcomp_native_driver_options, "comp-native-driver-options"); + DEFSYM (Qcomp_libgccjit_reproducer, "comp-libgccjit-reproducer"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); From 42ff68ec2f1149704da59fd692fafb095a44cce2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 9 Jan 2021 12:24:15 +0100 Subject: [PATCH 1295/1452] Improve `comp-libgccjit-reproducer' * src/comp.c (Fcomp__compile_ctxt_to_file): Better libgccjit reproducer file name. * lisp/emacs-lisp/comp.el (comp-libgccjit-reproducer): Doc update. (comp-final, comp-run-async-workers): Pass `comp-libgccjit-reproducer' setting to child workers. --- lisp/emacs-lisp/comp.el | 6 ++++-- src/comp.c | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 79cf942e89d..d5ca3b00049 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -138,8 +138,8 @@ and above." (defcustom comp-libgccjit-reproducer nil "When non-nil produce a libgccjit reproducer. -The reproducer is a file comp_SRCNAME_repro.c deposed in the .eln -output directory." +The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in +the .eln output directory." :type 'boolean) (defvar comp-dry-run nil @@ -3543,6 +3543,7 @@ Prepare every function for final compilation and drive the C back-end." (expr `(progn (require 'comp) (setf comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer comp-ctxt ,comp-ctxt comp-eln-load-path ',comp-eln-load-path comp-native-driver-options @@ -3795,6 +3796,7 @@ display a message." (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer comp-async-compilation t comp-eln-load-path ',comp-eln-load-path comp-native-driver-options diff --git a/src/comp.c b/src/comp.c index f6445a7621d..619f5e1b65f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4431,7 +4431,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) gcc_jit_context_dump_reproducer_to_file ( comp.ctxt, - format_string ("comp_%s_repro.c", SSDATA (base_name))); + format_string ("%s_libgccjit_repro.c", SSDATA (base_name))); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); From 79b9a262ffab37296a39c2d69cdabae153db10a7 Mon Sep 17 00:00:00 2001 From: Omar Polo Date: Tue, 12 Jan 2021 21:27:11 +0100 Subject: [PATCH 1296/1452] * configure.ac: Fix native-comp OpenBSD build. --- configure.ac | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/configure.ac b/configure.ac index 1f9fd330a35..2a4a373371c 100644 --- a/configure.ac +++ b/configure.ac @@ -3825,10 +3825,15 @@ if test "${with_nativecomp}" != "no"; then AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken]) LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes - # mingw32 loads the library dynamically. - if test "${opsys}" != "mingw32"; then - LIBGCCJIT_LIB="-lgccjit -ldl" - fi + case "${opsys}" in + # mingw32 loads the library dynamically. + mingw32) ;; + # OpenBSD doesn't have libdl, all the functions are in libc + 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 From 00101a8d4cc5bbf875711753c936be52e6e549b1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 10 Jan 2021 15:39:16 +0100 Subject: [PATCH 1297/1452] * Introduce native compilation time reports * lisp/emacs-lisp/comp.el (comp-log-time-report): New special variable. (comp--native-compile): Rework to log time reports. --- lisp/emacs-lisp/comp.el | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d5ca3b00049..156b00e6273 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -142,6 +142,9 @@ The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in the .eln output directory." :type 'boolean) +(defvar comp-log-time-report nil + "If non-nil, log a time report for each pass.") + (defvar comp-dry-run nil "If non-nil, run everything but the C back-end.") @@ -3869,15 +3872,24 @@ load once finished compiling." :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err - (mapc (lambda (pass) - (unless (memq pass comp-disabled-passes) - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)))) - comp-passes) + (cl-loop + with report = nil + for t0 = (current-time) + for pass in comp-passes + unless (memq pass comp-disabled-passes) + do + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) + finally + (when comp-log-time-report + (comp-log (format "Done compiling %s" data) 0) + (cl-loop for (pass . time) in (reverse report) + do (comp-log (format "Pass %s took: %fs." pass time) 0)))) (native-compiler-error ;; Add source input. (let ((err-val (cdr err))) From f1efac1f9efbfa15b6434ebef507c00c1277633f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 Jan 2021 21:53:41 +0100 Subject: [PATCH 1298/1452] * Normalize `comp-eln-load-path' entries for trampoline comp (bug#43475) * lisp/emacs-lisp/comp.el (comp-eln-load-path-eff): New function. (comp-trampoline-search, comp-trampoline-compile) (comp-clean-up-stale-eln): Update to use normalized `comp-eln-load-path-eff'. --- lisp/emacs-lisp/comp.el | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 156b00e6273..875f15aa75c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3592,6 +3592,15 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive function advice machinery +(defun comp-eln-load-path-eff () + "Return a list of effective eln load directories. +Account for `comp-load-path' and `comp-native-version-dir'." + (mapcar (lambda (dir) + (concat (file-name-as-directory + (expand-file-name dir invocation-directory)) + comp-native-version-dir)) + comp-eln-load-path)) + (defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) @@ -3616,9 +3625,8 @@ Prepare every function for final compilation and drive the C back-end." Return the trampoline if found or nil otherwise." (cl-loop with rel-filename = (comp-trampoline-filename subr-name) - for dir in comp-eln-load-path - for filename = (expand-file-name rel-filename - (concat dir comp-native-version-dir)) + for dir in (comp-eln-load-path-eff) + for filename = (expand-file-name rel-filename dir) when (file-exists-p filename) do (cl-return (native-elisp-load filename)))) @@ -3644,8 +3652,7 @@ Return the trampoline if found or nil otherwise." (comp--native-compile form nil (cl-loop - for load-dir in comp-eln-load-path - for dir = (concat load-dir comp-native-version-dir) + for dir in (comp-eln-load-path-eff) for f = (expand-file-name (comp-trampoline-filename subr-name) dir) @@ -3684,11 +3691,10 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast comp-eln-load-path) ; Skip last dir. + for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. do (cl-loop - with full-dir = (concat dir comp-native-version-dir) - for f in (when (file-exists-p full-dir) - (directory-files full-dir t regexp t)) + for f in (when (file-exists-p dir) + (directory-files dir t regexp t)) do (comp-delete-or-replace-file f))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) @@ -3877,14 +3883,14 @@ load once finished compiling." for t0 = (current-time) for pass in comp-passes unless (memq pass comp-disabled-passes) - do - (comp-log (format "(%s) Running pass %s:\n" + do + (comp-log (format "(%s) Running pass %s:\n" function-or-file pass) 2) - (setf data (funcall pass data)) - (push (cons pass (float-time (time-since t0))) report) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) finally (when comp-log-time-report (comp-log (format "Done compiling %s" data) 0) From 88100bed0af530f04cf56acca9f9d1bb12b45771 Mon Sep 17 00:00:00 2001 From: Philip Brown Date: Fri, 15 Jan 2021 00:35:36 -0800 Subject: [PATCH 1299/1452] * Set `backtrace-line-length' in async worker processes Philip Brown * lisp/emacs-lisp/comp.el (comp-run-async-workers): Set backtrace-line-length in async worker processes. Copyright-paperwork-exempt: yes --- lisp/emacs-lisp/comp.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 875f15aa75c..d127cea449e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3802,6 +3802,8 @@ display a message." source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn (require 'comp) + ,(when (boundp 'backtrace-line-length) + `(setf backtrace-line-length ,backtrace-line-length)) (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose From 883d937320a8be2bdc6d0ab7b5dd9551cbfeebd4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Jan 2021 16:50:16 +0100 Subject: [PATCH 1300/1452] Make `comp-enable-subr-trampolines' effective for advices (bug#45854) * src/comp.c: Copyright update. (syms_of_comp): Update `comp-enable-subr-trampolines' doc. * lisp/emacs-lisp/comp.el (comp-subr-trampoline-install): Check for `comp-enable-subr-trampolines'. --- lisp/emacs-lisp/comp.el | 3 ++- src/comp.c | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d127cea449e..238d86f7d51 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3668,7 +3668,8 @@ Return the trampoline if found or nil otherwise." ;;;###autoload (defun comp-subr-trampoline-install (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." - (unless (or (memq subr-name comp-never-optimize-functions) + (unless (or (null comp-enable-subr-trampolines) + (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p (symbol-function subr-name))) (comp--install-trampoline diff --git a/src/comp.c b/src/comp.c index 619f5e1b65f..b5adc3ed864 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,5 +1,5 @@ /* Compile elisp into native code. - Copyright (C) 2019-2020 Free Software Foundation, Inc. + Copyright (C) 2019-2021 Free Software Foundation, Inc. Author: Andrea Corallo @@ -5269,8 +5269,8 @@ The last directory of this list is assumed to be the system one. */); Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, - doc: /* If non-nil, enable trampoline synthesis triggered by `fset'. -This makes primitives redefinable effectively. */); + doc: /* If non-nil enable primitive trampoline synthesis. +This makes primitive functions redefinable or advisable effectively. */); DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> installed trampoline. From 339b4a754b0abe8e376c96ff3ca9624d8942cab2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 Jan 2021 23:54:52 +0100 Subject: [PATCH 1301/1452] * Introduce `comp-fwprop-max-insns-scan' as heuristic threshold * lisp/emacs-lisp/comp.el (comp-fwprop-max-insns-scan): New constant. (comp-fwprop*): Give-up when `comp-fwprop-max-insns-scan' is exceeded. --- lisp/emacs-lisp/comp.el | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 238d86f7d51..d4faa207b5d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2926,6 +2926,11 @@ Return t when one or more block was removed, nil otherwise." ;; This is also responsible for removing function calls to pure functions if ;; possible. +(defconst comp-fwprop-max-insns-scan 4500 + ;; Choosen as ~ the greatest required value for full convergence + ;; native compiling all Emacs codebase. + "Max number of scanned insn before giving-up.") + (defun comp-copy-insn (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. @@ -3086,7 +3091,9 @@ Fold the call in case." (defun comp-fwprop* () "Propagate for set* and phi operands. Return t if something was changed." - (cl-loop with modified = nil + (cl-loop named outer + with modified = nil + with i = 0 for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop with comp-block = b @@ -3094,9 +3101,13 @@ Return t if something was changed." for orig-insn = (unless modified ;; Save consing after 1th change. (comp-copy-insn insn)) - do (comp-fwprop-insn insn) + do + (comp-fwprop-insn insn) + (cl-incf i) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) + when (> i comp-fwprop-max-insns-scan) + do (cl-return-from outer nil) finally return modified)) (defun comp-rewrite-non-locals () From 39b3bcd324c4519ae3b204a31ab1a385b8ba9574 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 17 Jan 2021 22:00:42 +0100 Subject: [PATCH 1302/1452] * Run dead code removal always before fwprop, optim bootstrap time (~20% less) * lisp/emacs-lisp/comp.el (comp-passes): Remove `comp-dead-code'. (comp-fwprop): Call `comp-dead-code'. (comp-dead-code): Remove fake arg. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d4faa207b5d..d2e0d0fb79d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -175,7 +175,6 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-ipa-pure comp-add-cstrs comp-fwprop - comp-dead-code comp-tco comp-fwprop comp-remove-type-hints @@ -3130,6 +3129,7 @@ Return t if something was changed." (defun comp-fwprop (_) "Forward propagate types and consts within the lattice." (comp-ssa) + (comp-dead-code) (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) ;; FIXME remove the following condition when tested. @@ -3302,7 +3302,7 @@ Return the list of m-var ids nuked." insn)))))))) nuke-list))) -(defun comp-dead-code (_) +(defun comp-dead-code () "Dead code elimination." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) From 0ffb3dfaa483b0c5cf1f7f367efcb5e9c041ab53 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 18 Jan 2021 22:37:52 +0100 Subject: [PATCH 1303/1452] Do not add unnecesary arg constraints (bug#45812 bug#45705 bug#45751). These have the effect of bloating the IR for no effect killing compile time. The typical cases for that are extremely long backuoted lists. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-t): New var. * lisp/emacs-lisp/comp.el (comp-add-call-cstr): No need to add arg call constraints if this is t. --- lisp/emacs-lisp/comp-cstr.el | 3 +++ lisp/emacs-lisp/comp.el | 3 +++ 2 files changed, 6 insertions(+) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 651c7b7931e..1afb928e10c 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -179,6 +179,9 @@ Return them as multiple value." (defvar comp-cstr-one (comp-value-to-cstr 1) "Represent the integer immediate one.") +(defvar comp-cstr-t (comp-type-to-cstr t) + "Represent the superclass t.") + ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d2e0d0fb79d..02a9f4ae1ff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2513,6 +2513,9 @@ TARGET-BB-SYM is the symbol name of the target block." do (signal 'native-ice (list "Incoherent type specifier for function" f)) when (and target + ;; No need to add call constraints if this is t + ;; (bug#45812 bug#45705 bug#45751). + (not (equal comp-cstr-t cstr)) (or (null lhs) (not (eql (comp-mvar-slot lhs) (comp-mvar-slot target))))) From 41509d873e8a05aa98133cb78f384e06e69779ab Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Feb 2021 21:20:28 +0100 Subject: [PATCH 1304/1452] * Short eln filename hashes * src/comp.c (HASH_LENGTH): New macro. (comp_hash_string, comp_hash_source_file): Trim the hash before returning. --- src/comp.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index b5adc3ed864..1b346f847dd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -413,6 +413,9 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ #define ABI_VERSION "1" +/* Length of the hashes used for eln file naming. */ +#define HASH_LENGTH 8 + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -662,7 +665,7 @@ comp_hash_string (Lisp_Object string) md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); - return digest; + return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); } static Lisp_Object @@ -688,7 +691,7 @@ comp_hash_source_file (Lisp_Object filename) hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE); - return digest; + return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); } /* Produce a key hashing Vcomp_subr_list. */ From 1f626e9662d8120acd5a937f847123cc2b8c6e31 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 3 Feb 2021 21:10:47 +0100 Subject: [PATCH 1305/1452] * Remove `system-configuration' from eln filename * src/comp.c (hash_native_abi): Remove `system-configuration' from eln filename. Add `system-configuration' and `emacs-version' into `comp-abi-hash'. --- src/comp.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 1b346f847dd..289d89d37d1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -704,16 +704,12 @@ hash_native_abi (void) Vcomp_abi_hash = comp_hash_string ( - concat2 (build_string (ABI_VERSION), + concat3 (build_string (ABI_VERSION), + concat2 (Vemacs_version, Vsystem_configuration), Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string ("")))); - Lisp_Object separator = build_string ("-"); Vcomp_native_version_dir = - concat3 (Vemacs_version, - separator, - concat3 (Vsystem_configuration, - separator, - Vcomp_abi_hash)); + concat3 (Vemacs_version, build_string ("-"), Vcomp_abi_hash); } static void From 4fba79feee58e074d112bb47467913f9aec089c7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Feb 2021 21:48:19 +0100 Subject: [PATCH 1306/1452] Add late load pdumper hooks so these can call into Lisp * src/pdumper.h (pdumper_do_now_and_after_late_load): New function. * src/pdumper.c (dump_late_hooks, nr_dump_late_hooks): New static variables. (dump_metadata_for_pdumper): Add support for late load hooks. (pdumper_do_now_and_after_late_load_impl): New functions. (pdumper_load): Add support for late load hooks. * src/window.c (init_window_once): Register 'init_window_once_for_pdumper' to be executed after late load. --- src/pdumper.c | 24 ++++++++++++++++++++++++ src/pdumper.h | 13 +++++++++++++ src/window.c | 2 +- 3 files changed, 38 insertions(+), 1 deletion(-) diff --git a/src/pdumper.c b/src/pdumper.c index f0711078a5a..1f1f6e05df4 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -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; @@ -3245,6 +3248,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, @@ -4316,6 +4325,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) { @@ -5597,6 +5615,12 @@ pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) 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 = diff --git a/src/pdumper.h b/src/pdumper.h index 24e99e22c7a..49e6739b0dc 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -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, diff --git a/src/window.c b/src/window.c index eb16e2a4338..f8b97287e64 100644 --- a/src/window.c +++ b/src/window.c @@ -8134,7 +8134,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) From d3a399dd299bf7e811cf42950d5f8ac67f063b36 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 11 Feb 2021 21:37:53 +0100 Subject: [PATCH 1307/1452] * lisp/emacs-lisp/comp.el (comp-trampoline-compile): Default to speed 1. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 02a9f4ae1ff..40360809765 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3661,7 +3661,7 @@ Return the trampoline if found or nil otherwise." ;; Use speed 0 to maximize compilation speed and not to ;; optimize away funcall calls! (byte-optimize nil) - (comp-speed 0) + (comp-speed 1) (lexical-binding t)) (comp--native-compile form nil From 8646113ba0c523827f07b01585c3fd1080d3d7b8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Feb 2021 19:56:19 +0100 Subject: [PATCH 1308/1452] * src/comp.c (load_comp_unit): Fix 'data_ephemeral_vec' shadowing decl. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 289d89d37d1..df770c650e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4858,7 +4858,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, is not cons hashed. */ if (!recursive_load) { - Lisp_Object volatile data_ephemeral_vec = + data_ephemeral_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); From bebec46bcbf0e52460b08234c067d7a2cb0f2246 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Feb 2021 20:08:09 +0100 Subject: [PATCH 1309/1452] * src/comp.c (define_jmp_buf): Use 'jmp_buf' instead of 'sys_jmp_buf'. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index df770c650e6..737e8080201 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2937,7 +2937,7 @@ define_jmp_buf (void) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.char_type, - sizeof (sys_jmp_buf)), + sizeof (jmp_buf)), "stuff"); comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, From 71fc39cbe009fefcb992d8333806a743a3b97243 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Feb 2021 20:19:28 +0100 Subject: [PATCH 1310/1452] Revert "* src/comp.c (define_jmp_buf): Use 'jmp_buf' instead of 'sys_jmp_buf'." This reverts commit bebec46bcbf0e52460b08234c067d7a2cb0f2246. Looking at the git history I realize now the use of 'sys_jmp_buf' was intentional. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 737e8080201..df770c650e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2937,7 +2937,7 @@ define_jmp_buf (void) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.char_type, - sizeof (jmp_buf)), + sizeof (sys_jmp_buf)), "stuff"); comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, From 31416495ad9b2c84473f72ad99e2adc87dd66e5a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Feb 2021 21:14:34 +0100 Subject: [PATCH 1311/1452] * lisp/startup.el (normal-top-level): Use `path-separator' in place of ":". --- lisp/startup.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/startup.el b/lisp/startup.el index ae0ac3cb933..7e8fa47aea7 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -540,7 +540,7 @@ It is the default value of the variable `top-level'." (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env - (dolist (path (split-string path-env ":")) + (dolist (path (split-string path-env path-separator)) (unless (string= "" path) (push path comp-eln-load-path))))) (push (concat user-emacs-directory "eln-cache/") comp-eln-load-path)) From 543e6e664cf1f25fd7df04e75ffb582f5c7feab4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Feb 2021 21:41:36 +0100 Subject: [PATCH 1312/1452] * Sanitize frame slot access in final * src/comp.c (comp_t): Add 'frame_size' field. (emit_mvar_lval): Add sanity check on frame element access. (compile_function): Initialize 'comp.frame_size' and 'comp.frame_size'. --- src/comp.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/comp.c b/src/comp.c index df770c650e6..0ab7ab600a4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -560,6 +560,7 @@ typedef struct { EMACS_INT func_speed; /* From comp-func speed slot. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ + ptrdiff_t frame_size; /* Size of the following array in elements. */ gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */ gcc_jit_rvalue *zero; gcc_jit_rvalue *one; @@ -785,7 +786,9 @@ emit_mvar_lval (Lisp_Object mvar) return comp.scratch; } - return comp.frame[XFIXNUM (mvar_slot)]; + EMACS_INT slot_n = XFIXNUM (mvar_slot); + eassert (slot_n < comp.frame_size); + return comp.frame[slot_n]; } static void @@ -3857,7 +3860,7 @@ static void compile_function (Lisp_Object func) { USE_SAFE_ALLOCA; - EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), comp.exported_funcs_h, Qnil)); @@ -3871,7 +3874,7 @@ compile_function (Lisp_Object func) comp.func_relocs_ptr_type, "freloc"); - comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); + comp.frame = SAFE_ALLOCA (comp.frame_size * sizeof (*comp.frame)); if (comp.func_has_non_local || !comp.func_speed) { /* FIXME: See bug#42360. */ @@ -3882,10 +3885,10 @@ compile_function (Lisp_Object func) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.lisp_obj_type, - frame_size), + comp.frame_size), "frame"); - for (ptrdiff_t i = 0; i < frame_size; ++i) + for (ptrdiff_t i = 0; i < comp.frame_size; ++i) comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, @@ -3896,7 +3899,7 @@ compile_function (Lisp_Object func) i)); } else - for (ptrdiff_t i = 0; i < frame_size; ++i) + for (ptrdiff_t i = 0; i < comp.frame_size; ++i) comp.frame[i] = gcc_jit_function_new_local (comp.func, NULL, From 72e4a22391bcb5d4ef484eb1dd32a614dbdbfd7b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Feb 2021 21:49:32 +0100 Subject: [PATCH 1313/1452] * Better long range check * src/comp.c (emit_rvalue_from_emacs_uint) (emit_rvalue_from_emacs_int, emit_rvalue_from_lisp_word_tag) (emit_rvalue_from_lisp_word): Better long range check. --- src/comp.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/comp.c b/src/comp.c index 0ab7ab600a4..ce9c387568a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1166,7 +1166,7 @@ emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1177,7 +1177,7 @@ emit_rvalue_from_emacs_uint (EMACS_UINT val) static gcc_jit_rvalue * emit_rvalue_from_emacs_int (EMACS_INT val) { - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_long_long (comp.emacs_int_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1187,7 +1187,7 @@ emit_rvalue_from_emacs_int (EMACS_INT val) static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1203,7 +1203,7 @@ emit_rvalue_from_lisp_word (Lisp_Word val) comp.lisp_word_type, val); #else - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, From 7b676861dd1080ac65368d8b975972acb5bb1da8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Feb 2021 22:01:27 +0100 Subject: [PATCH 1314/1452] * src/comp.c (check_comp_unit_relocs): Prefer ptrdiff_t to EMACS_INT. --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index ce9c387568a..dae68ddb2bb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4713,12 +4713,12 @@ check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) + for (ptrdiff_t i = 0; i < d_vec_len; i++) if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i))) return false; d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) + for (ptrdiff_t i = 0; i < d_vec_len; i++) { Lisp_Object x = data_imp_relocs[i]; if (EQ (x, Qlambda_fixup)) From 21858596f0271a2215174d99c9007f6b2f1f5e21 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Feb 2021 22:05:06 +0100 Subject: [PATCH 1315/1452] * Clean-up some signal related dead-code * src/comp.c (restore_sigmask): Remove function. (Fcomp__compile_ctxt_to_file): Remove some dead-code. --- src/comp.c | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/src/comp.c b/src/comp.c index dae68ddb2bb..c9d14958b75 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4331,13 +4331,6 @@ add_driver_options (void) " and above.")); } -static void -restore_sigmask (void) -{ - pthread_sigmask (SIG_SETMASK, &saved_sigset, 0); - unblock_input (); -} - DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -4385,21 +4378,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, ptrdiff_t count = 0; - if (!noninteractive) - { - sigset_t blocked; - /* Gcc doesn't like being interrupted at all. */ - block_input (); - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); -#ifdef USABLE_SIGIO - sigaddset (&blocked, SIGIO); -#endif - pthread_sigmask (SIG_BLOCK, &blocked, &saved_sigset); - count = SPECPDL_INDEX (); - record_unwind_protect_void (restore_sigmask); - } emit_ctxt_code (); /* Define inline functions. */ @@ -4451,9 +4429,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CALL1I (comp-clean-up-stale-eln, filename); CALL2I (comp-delete-or-replace-file, filename, tmp_file); - if (!noninteractive) - unbind_to (count, Qnil); - return filename; } From 0d7c893203087d60f0ce549521f4c715c87a7038 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 17 Feb 2021 15:53:24 +0100 Subject: [PATCH 1316/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Clean-up unused variable. --- src/comp.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index c9d14958b75..5e951610302 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4376,8 +4376,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.d_ephemeral_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); - ptrdiff_t count = 0; - emit_ctxt_code (); /* Define inline functions. */ From 1fe5994bcb8b58012dbba0a5f7d03138c293286f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 17 Feb 2021 21:45:37 +0100 Subject: [PATCH 1317/1452] Fix inverted logic in constraint comparison (bug#46540) * lisp/emacs-lisp/comp-cstr.el (comp-cstr->, comp-cstr->=) (comp-cstr-<, comp-cstr-<=): Fix inverted logic. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add three integer constrain tests. --- lisp/emacs-lisp/comp-cstr.el | 8 ++++---- test/src/comp-tests.el | 29 ++++++++++++++++++++++++++++- 2 files changed, 32 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 1afb928e10c..3c00b68d0f6 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -791,7 +791,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,(1+ src) . +)) (when-let* ((range (range src)) - (low (comp-cstr-greatest-in-range range)) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((,(1+ low) . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -804,7 +804,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,src . +)) (when-let* ((range (range src)) - (low (comp-cstr-greatest-in-range range)) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((,low . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -817,7 +817,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,(1- src))) (when-let* ((range (range src)) - (low (comp-cstr-smallest-in-range range)) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((- . ,(1- low))))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -830,7 +830,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,src)) (when-let* ((range (range src)) - (low (comp-cstr-smallest-in-range range)) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c0325a8d5df..08c18894419 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1211,7 +1211,34 @@ Return a list of results." (= x 3)) (error "Not foo or 3")) x) - (or (member foo) (integer 3 3))))) + (or (member foo) (integer 3 3))) + + ;;58 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (natnump x) + (natnump y) + (<= x y)) + x + (error ""))) + (integer 0 *)) + + ;; 59 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (>= x 3) + (<= y 10) + (<= x y)) + x + (error ""))) + (or float (integer 3 10))) + + ;; 60 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (<= x 10) + (>= y 3) + (>= x y)) + x + (error ""))) + (or float (integer 3 10))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 185121da6978553d538d37d6d0e67dc52e13311f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Feb 2021 21:45:50 +0100 Subject: [PATCH 1318/1452] * Add assertion guarding against emitting a relocation array overflow * src/comp.c (reloc_array_t): New type. (comp_t, imm_reloc_t): Make use of 'reloc_array_t'. (obj_to_reloc): Add an assertion not to overflow relocation arrays. (emit_lisp_obj_reloc_lval, emit_limple_insn) (declare_imported_data_relocs): Make use of 'reloc_array_t'. --- src/comp.c | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/src/comp.c b/src/comp.c index 5e951610302..f3a3e5556f2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -488,6 +488,11 @@ enum cast_kind_of_type kind_pointer }; +typedef struct { + EMACS_INT len; + gcc_jit_rvalue *r_val; +} reloc_array_t; + /* C side of the compiler context. */ typedef struct { @@ -583,11 +588,11 @@ typedef struct { Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; /* Synthesized struct holding data relocs. */ - gcc_jit_rvalue *data_relocs; + reloc_array_t data_relocs; /* Same as before but can't go in pure space. */ - gcc_jit_rvalue *data_relocs_impure; + reloc_array_t data_relocs_impure; /* Same as before but content does not survive load phase. */ - gcc_jit_rvalue *data_relocs_ephemeral; + reloc_array_t data_relocs_ephemeral; /* Global structure holding function relocations. */ gcc_jit_lvalue *func_relocs; gcc_jit_type *func_relocs_ptr_type; @@ -610,7 +615,7 @@ typedef struct { } static_obj_t; typedef struct { - gcc_jit_rvalue *array; + reloc_array_t array; gcc_jit_rvalue *idx; } imm_reloc_t; @@ -827,7 +832,9 @@ obj_to_reloc (Lisp_Object obj) xsignal1 (Qnative_ice, build_string ("cant't find data in relocation containers")); assume (false); + found: + eassert (XFIXNUM (idx) < reloc.array.len); if (!FIXNUMP (idx)) xsignal1 (Qnative_ice, build_string ("inconsistent data relocation container")); @@ -1558,7 +1565,7 @@ emit_lisp_obj_reloc_lval (Lisp_Object obj) imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_context_new_array_access (comp.ctxt, NULL, - reloc.array, + reloc.array.r_val, reloc.idx); } @@ -2270,7 +2277,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - reloc.array, + reloc.array.r_val, reloc.idx))); } else if (EQ (op, Qcomment)) @@ -2608,18 +2615,19 @@ emit_static_object (const char *name, Lisp_Object obj) } #pragma GCC diagnostic pop -static gcc_jit_rvalue * +static reloc_array_t declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, const char *text_symbol) { /* Imported objects. */ - EMACS_INT d_reloc_len = + reloc_array_t res; + res.len = XFIXNUM (CALL1I (hash-table-count, CALL1I (comp-data-container-idx, container))); Lisp_Object d_reloc = CALL1I (comp-data-container-l, container); d_reloc = Fvconcat (1, &d_reloc); - gcc_jit_rvalue *reloc_struct = + res.r_val = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( comp.ctxt, @@ -2628,12 +2636,12 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.lisp_obj_type, - d_reloc_len), + res.len), code_symbol)); emit_static_object (text_symbol, d_reloc); - return reloc_struct; + return res; } static void From b1bab6e07396fb30a7a2ba8cb4fd42f44020f513 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Feb 2021 22:10:20 +0100 Subject: [PATCH 1319/1452] * Add a bunch of assertions for fixnums coming from Lisp later used as int * src/comp.c (emit_limple_insn, declare_lex_function) (compile_function, Fcomp__compile_ctxt_to_file): Add some assertion. --- src/comp.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/comp.c b/src/comp.c index f3a3e5556f2..3b1f3be2682 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2057,6 +2057,7 @@ emit_limple_insn (Lisp_Object insn) */ gcc_jit_lvalue *nargs = gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + eassert (XFIXNUM (arg[0]) < INT_MAX); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2200,6 +2201,7 @@ emit_limple_insn (Lisp_Object insn) { /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */ EMACS_INT param_n = XFIXNUM (arg[1]); + eassert (param_n < INT_MAX); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); @@ -2228,6 +2230,7 @@ emit_limple_insn (Lisp_Object insn) */ EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0])); + eassert (slot_n < INT_MAX); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -3805,6 +3808,7 @@ declare_lex_function (Lisp_Object func) if (!nargs) { EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); + eassert (max_args < INT_MAX); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; @@ -3869,6 +3873,7 @@ compile_function (Lisp_Object func) { USE_SAFE_ALLOCA; comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + eassert (comp.frame_size < INT_MAX); comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), comp.exported_funcs_h, Qnil)); @@ -4353,7 +4358,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.func_relocs_local = NULL; comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); + eassert (comp.speed < INT_MAX); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); + eassert (comp.debug < INT_MAX); if (comp.debug) gcc_jit_context_set_bool_option (comp.ctxt, From 805cae572aa62184c717db593e86e30ea9093059 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Feb 2021 22:32:58 +0100 Subject: [PATCH 1320/1452] * src/emacs.c (syms_of_emacs): Add a FIXME for Windows native-comp. --- src/emacs.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index acf8a17a12a..d541b41f3f1 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3081,9 +3081,9 @@ 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 - /* 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. */ + /* 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"))); From 2110a3faf776c68b2dbe52da3650636aec170269 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 18 Feb 2021 22:35:07 +0100 Subject: [PATCH 1321/1452] * src/pdumper.c (dump_do_dump_relocation): Use emacs_fopen + ENCODE_FILE. --- src/pdumper.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index f053143a9f7..368184b9a6a 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5280,10 +5280,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) { - char *fname = SSDATA (concat2 (Vinvocation_directory, - XCAR (comp_u->file))); + Lisp_Object fname = + concat2 (Vinvocation_directory, XCAR (comp_u->file)); FILE *file; - if ((file = fopen (fname, "r"))) + if ((file = emacs_fopen (SSDATA (ENCODE_FILE (fname)), "r"))) { fclose (file); installation_state = INSTALLED; From 14e6268d141b8c54001d1d5bdcf610313ac9c447 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 19 Feb 2021 15:54:36 +0100 Subject: [PATCH 1322/1452] * Pacify GCC warning on non wide-int configurations * src/comp.c (emit_rvalue_from_emacs_uint) (emit_rvalue_from_lisp_word_tag): Pacify GCC warning. (emit_rvalue_from_unsigned_long_long): Define it only when necessary. --- src/comp.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/comp.c b/src/comp.c index 3b1f3be2682..ca6e990daaf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,6 +1128,7 @@ emit_rvalue_from_long_long (gcc_jit_type *type, long long n) low)); } +#if (EMACS_INT_MAX > LONG_MAX) static gcc_jit_rvalue * emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) { @@ -1169,16 +1170,18 @@ emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) 32)), low)); } +#endif static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { +#ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); - else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_uint_type, - val); +#endif + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); } static gcc_jit_rvalue * @@ -1194,12 +1197,13 @@ emit_rvalue_from_emacs_int (EMACS_INT val) static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { +#ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); - else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.lisp_word_tag_type, - val); +#endif + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); } static gcc_jit_rvalue * From 92fe7a91f4c88bb8661d4f1f15739849ddc01754 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 19 Feb 2021 16:14:31 +0100 Subject: [PATCH 1323/1452] * Remove unnecessary function 'emit_rvalue_from_unsigned_long_long' * src/comp.c (emit_rvalue_from_unsigned_long_long): Remove function. (emit_rvalue_from_emacs_uint, emit_rvalue_from_lisp_word_tag) (emit_rvalue_from_lisp_word): Make use of 'emit_rvalue_from_long_long'. --- src/comp.c | 50 +++----------------------------------------------- 1 file changed, 3 insertions(+), 47 deletions(-) diff --git a/src/comp.c b/src/comp.c index ca6e990daaf..24c40f7c3ed 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,56 +1128,12 @@ emit_rvalue_from_long_long (gcc_jit_type *type, long long n) low)); } -#if (EMACS_INT_MAX > LONG_MAX) -static gcc_jit_rvalue * -emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) -{ - emit_comment (format_string ("emit unsigned long long: %llu", n)); - - gcc_jit_rvalue *high = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.unsigned_long_long_type, - n >> 32); - gcc_jit_rvalue *low = - emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, - comp.unsigned_long_long_type, - emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, - comp.unsigned_long_long_type, - gcc_jit_context_new_rvalue_from_long ( - comp.ctxt, - comp.unsigned_long_long_type, - n), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_long_long_type, - 32)), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_long_long_type, - 32)); - - return emit_coerce ( - type, - emit_binary_op ( - GCC_JIT_BINARY_OP_BITWISE_OR, - comp.unsigned_long_long_type, - emit_binary_op ( - GCC_JIT_BINARY_OP_LSHIFT, - comp.unsigned_long_long_type, - high, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.unsigned_long_long_type, - 32)), - low)); -} -#endif - static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { #ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) - return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); + return emit_rvalue_from_long_long (comp.emacs_uint_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.emacs_uint_type, @@ -1199,7 +1155,7 @@ emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { #ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); + return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.lisp_word_tag_type, @@ -1215,7 +1171,7 @@ emit_rvalue_from_lisp_word (Lisp_Word val) val); #else if (val > LONG_MAX || val < LONG_MIN) - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); + return emit_rvalue_from_long_long (comp.lisp_word_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.lisp_word_type, From 39792cf62987ecc1a772f6a2027d6b32c70e8312 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Feb 2021 22:54:49 +0100 Subject: [PATCH 1324/1452] * Work around bug#46495 (GCC PR99126) * src/comp.c (gcc_jit_context_add_command_line_option): Import for dynamic load. (Fcomp__compile_ctxt_to_file): Disable GCC "isolate-paths" on GCC 10. --- src/comp.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/comp.c b/src/comp.c index 24c40f7c3ed..a8b8ef95fa1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -56,6 +56,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_block_end_with_return #undef gcc_jit_block_end_with_void_return #undef gcc_jit_context_acquire +#undef gcc_jit_context_add_command_line_option #undef gcc_jit_context_add_driver_option #undef gcc_jit_context_compile_to_file #undef gcc_jit_context_dump_reproducer_to_file @@ -124,6 +125,8 @@ DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, (gcc_jit_function *func, const char *name)); DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (void, gcc_jit_context_add_command_line_option, + (gcc_jit_context *ctxt, const char *optname)); DEF_DLL_FN (void, gcc_jit_context_add_driver_option, (gcc_jit_context *ctxt, const char *optname)); DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, @@ -312,6 +315,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_const); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN_OPT (library, gcc_jit_context_add_command_line_option); LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); LOAD_DLL_FN_OPT (library, gcc_jit_version_major); @@ -330,6 +334,7 @@ init_gccjit_functions (void) #define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return #define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return #define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_add_command_line_option fn_gcc_jit_context_add_command_line_option #define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option #define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file #define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file @@ -4375,6 +4380,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (!EQ (HASH_VALUE (func_h, i), Qunbound)) compile_function (HASH_VALUE (func_h, i)); + /* Work around bug#46495 (GCC PR99126). */ +#if defined (WIDE_EMACS_INT) \ + && (defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) \ + || defined (WINDOWSNT)) + Lisp_Object version = Fcomp_libgccjit_version (); + if (!NILP (version) && XFIXNUM (XCAR (version)) == 10) + gcc_jit_context_add_command_line_option (comp.ctxt, + "-fdisable-tree-isolate-paths"); +#endif + add_driver_options (); if (comp.debug) From da4da88c76465e30ce974383b182f191553b470a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Feb 2021 22:20:59 +0100 Subject: [PATCH 1325/1452] * lisp/emacs-lisp/comp.el (comp-spill-lap): Fix doc string. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 40360809765..60c040926e5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1306,7 +1306,7 @@ clashes." (defun comp-spill-lap (input) "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. -If INPUT is a string this is the file path to be compiled." +If INPUT is a string this is the filename to be compiled." (let ((byte-native-compiling t) (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ()) From d6227f6edcff7be05469e99da4ce541bfc474c3d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 13:58:30 +0100 Subject: [PATCH 1326/1452] * Fix union constraint for mixed pos/neg constraints * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Fix neg type shadowing pos values. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add testcase. * test/src/comp-tests.el (comp-tests-type-spec-tests): Fix testcase. --- lisp/emacs-lisp/comp-cstr.el | 6 ++++++ test/lisp/emacs-lisp/comp-cstr-tests.el | 4 +++- test/src/comp-tests.el | 2 +- 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3c00b68d0f6..c294c53b6b0 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -597,6 +597,12 @@ DST is returned." (valset pos))) ;; Pos is a superset of neg. (give-up)) + ((cl-some (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p y x)) + (mapcar #'type-of (valset pos)))) + (typeset neg)) + (give-up)) (t ;; pos is a subset or eq to neg (setf (valset neg) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index b4db54666c7..f2d9bf583e5 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -211,7 +211,9 @@ ;; 85 ((or (not string) t) . t) ;; 86 - ((or (not vector) sequence) . sequence)) + ((or (not vector) sequence) . sequence) + ;; 87 + ((or (not symbol) null) . t)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 08c18894419..f7b5a6bbb4c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1185,7 +1185,7 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (unless (symbolp x) x)) - (not symbol)) + t) ;; 55 ((defun comp-tests-ret-type-spec-f (x) From 81b1013555363be1513a13f5f07ee50041969dfa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 14:31:23 +0100 Subject: [PATCH 1327/1452] * Don't use paths to indicate filenames * lisp/emacs-lisp/comp.el (native--compile-async) (native-compile-async): Replace `paths' argname with `files'. --- lisp/emacs-lisp/comp.el | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60c040926e5..677e6a7b8d3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3943,9 +3943,9 @@ LOAD and SELECTOR work as described in `native--compile-async'." (string-match-p re file)) comp-deferred-compilation-deny-list)))) -(defun native--compile-async (paths &optional recursively load selector) - "Compile PATHS asynchronously. -PATHS is one path or a list of paths to files or directories. +(defun native--compile-async (files &optional recursively load selector) + "Compile FILES asynchronously. +FILES is one path or a list of files to files or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. @@ -3974,10 +3974,10 @@ bytecode definition was not changed in the meanwhile)." (comp-ensure-native-compiler) (unless (member load '(nil t late)) (error "LOAD must be nil, t or 'late")) - (unless (listp paths) - (setf paths (list paths))) + (unless (listp files) + (setf files (list files))) (let (files) - (dolist (path paths) + (dolist (path files) (cond ((file-directory-p path) (dolist (file (if recursively (directory-files-recursively @@ -4057,9 +4057,9 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (rename-file tempfile target-file t)))))) ;;;###autoload -(defun native-compile-async (paths &optional recursively load selector) - "Compile PATHS asynchronously. -PATHS is one path or a list of paths to files or directories. +(defun native-compile-async (files &optional recursively load selector) + "Compile FILES asynchronously. +FILES is one path or a list of files to files or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. @@ -4077,7 +4077,7 @@ The variable `comp-async-jobs-number' specifies the number of (commands) to run simultaneously." ;; Normalize: we only want to pass t or nil, never e.g. `late'. (let ((load (not (not load)))) - (native--compile-async paths recursively load selector))) + (native--compile-async files recursively load selector))) (provide 'comp) From f6c5f0dd5c8167b6f8f724f42632a4b8808efe7a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 14:39:04 +0100 Subject: [PATCH 1328/1452] * configure.ac: Rename configure nativecomp flags into --with-native-comp. Configure now with '--with-native-comp'! --- configure.ac | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index fe0dc921dce..1771171f669 100644 --- a/configure.ac +++ b/configure.ac @@ -484,7 +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([nativecomp],[compile with Emacs Lisp native compiler support]) +OPTION_DEFAULT_OFF([native-comp],[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)])], @@ -3786,7 +3786,7 @@ 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-nativecomp + --without-native-comp to configure.])]) AC_DEFUN([libgccjit_dev_not_found], [ @@ -3808,7 +3808,7 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -if test "${with_nativecomp}" != "no"; then +if test "${with_native_comp}" != "no"; then if test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) fi From 28ce6f980ff9dc022550933f840ab5c8469cc9d1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 15:17:07 +0100 Subject: [PATCH 1329/1452] * Some clean-up in comp.el * lisp/emacs-lisp/comp.el (comp-func): Remove 'array-h'. (comp-spill-lap-function, comp-intern-func-in-ctxt) (comp-spill-lap-function, comp-addr-to-bb-name): Update accordingly. --- lisp/emacs-lisp/comp.el | 9 --------- 1 file changed, 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 677e6a7b8d3..e2b1d04bc2b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -774,8 +774,6 @@ CFG is mutated by a pass.") :documentation "Generates edges numbers.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") - (array-h (make-hash-table) :type hash-table - :documentation "array idx -> array length.") (speed nil :type number :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean @@ -1188,8 +1186,6 @@ clashes." (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-func-def :name function-name :c-name c-name))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) (cl-defmethod comp-spill-lap-function ((form list)) @@ -1227,8 +1223,6 @@ clashes." (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-func-def :name '--anonymous-lambda :c-name c-name))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) (defun comp-intern-func-in-ctxt (_ obj) @@ -1265,8 +1259,6 @@ clashes." (setf (byte-to-native-func-def-c-name top-l-form) c-name)) (unless name (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1 t)))) @@ -2090,7 +2082,6 @@ into the C code forwarding the compilation unit." (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :slot 1))) - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) (defun comp-addr-to-bb-name (addr) From cadb902aa8136d9eff8bb0df39daed840c00e1b6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 21:01:44 +0100 Subject: [PATCH 1330/1452] Revert "* configure.ac: Rename configure nativecomp flags..." This reverts commit f6c5f0dd5c8167b6f8f724f42632a4b8808efe7a. Reason for this is that I overlooked few other suggestions and this change has to be discussed before a final decision is taken. --- configure.ac | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index 1771171f669..fe0dc921dce 100644 --- a/configure.ac +++ b/configure.ac @@ -484,7 +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-comp],[compile with Emacs Lisp native compiler support]) +OPTION_DEFAULT_OFF([nativecomp],[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)])], @@ -3786,7 +3786,7 @@ 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-comp + --without-nativecomp to configure.])]) AC_DEFUN([libgccjit_dev_not_found], [ @@ -3808,7 +3808,7 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -if test "${with_native_comp}" != "no"; then +if test "${with_nativecomp}" != "no"; then if test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) fi From ec88bdba6fea4af18e5662d4d4a4339ebc1f81ff Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 15:07:00 +0100 Subject: [PATCH 1331/1452] * Add a simple growable vector like type * lisp/emacs-lisp/comp.el (comp-vec): Define struct. (comp-vec-copy, comp-vec-length, comp-vec--verify-idx) (comp-vec-aref, comp-vec-append, comp-vec-prepend): New functions. --- lisp/emacs-lisp/comp.el | 53 ++++++++++++++++++++++++++++++++++++++--- 1 file changed, 50 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e2b1d04bc2b..267b67f99ef 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -600,6 +600,53 @@ Useful to hook into pass checkers.") (define-error 'native-compiler-error-empty-byte "empty byte compiler output" 'native-compiler-error) + + +(cl-defstruct (comp-vec (:copier nil)) + "A re-sizable vector like object." + (data (make-hash-table :test #'eql) :type hash-table + :documentation "Payload data.") + (beg 0 :type integer) + (end 0 :type natnum)) + +(defsubst comp-vec-copy (vec) + "Return a copy of VEC." + (make-comp-vec :data (copy-hash-table (comp-vec-data vec)) + :beg (comp-vec-beg vec) + :end (comp-vec-end vec))) + +(defsubst comp-vec-length (vec) + "Return the number of elements of VEC." + (+ (comp-vec-beg vec) (comp-vec-end vec))) + +(defsubst comp-vec--verify-idx (vec idx) + "Check idx is in bounds for VEC." + (cl-assert (and (< idx (comp-vec-end vec)) + (>= idx (comp-vec-beg vec))))) + +(defsubst comp-vec-aref (vec idx) + "Return the element of VEC at index IDX." + (declare (gv-setter (lambda (val) + `(comp-vec--verify-idx ,vec ,idx) + `(puthash ,idx ,val (comp-vec-data ,vec))))) + (comp-vec--verify-idx vec idx) + (gethash idx (comp-vec-data vec))) + +(defsubst comp-vec-append (vec elt) + "Append ELT into VEC. +ELT is returned." + (puthash (comp-vec-end vec) elt (comp-vec-aref vec)) + (cl-incf (comp-vec-end vec)) + elt) + +(defsubst comp-vec-prepend (vec elt) + "Prepend ELT into VEC. +ELT is returned." + (puthash (comp-vec-beg vec) elt (comp-vec-aref vec)) + (cl-decf (comp-vec-beg vec)) + elt) + + (eval-when-compile (defconst comp-op-stack-info @@ -2772,9 +2819,9 @@ blocks." (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) - for b being each hash-value of blocks - when (slot-assigned-p i b) - collect b) + for b being each hash-value of blocks + when (slot-assigned-p i b) + collect b) ;; Set of basic blocks where phi is added. for f = () ;; Worklist, set of basic blocks that contain definitions of v. From 89e9b051809d85d50d67c52d0388f8fffee8ba32 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 22 Feb 2021 17:28:19 +0100 Subject: [PATCH 1332/1452] * Move ssa rename from vector to comp-vec * lisp/emacs-lisp/comp.el (comp-block): Updated `final-frame' slot type. (comp-limplify): Updated `frame' slot type. (comp-slot-n, comp-new-frame, comp-place-phis, comp-ssa) (comp-ssa-rename-insn, comp-ssa-rename, comp-finalize-phis): Use `comp-vec'. --- lisp/emacs-lisp/comp.el | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 267b67f99ef..b6451d591c5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -733,7 +733,7 @@ This is typically for top-level forms other than defun.") :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type (or null number) :documentation "Post order number.") - (final-frame nil :type (or null vector) + (final-frame nil :type (or null comp-vec) :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) @@ -1357,7 +1357,7 @@ If INPUT is a string this is the filename to be compiled." (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during function limplification." - (frame nil :type vector + (frame nil :type (or null comp-vec) :documentation "Meta-stack used to flat LAP.") (curr-block nil :type comp-block :documentation "Current block being limplified.") @@ -1406,7 +1406,7 @@ Restore the original value afterwards." (defsubst comp-slot-n (n) "Slot N into the meta-stack." - (aref (comp-limplify-frame comp-pass) n)) + (comp-vec-aref (comp-limplify-frame comp-pass) n)) (defsubst comp-slot () "Current slot into the meta-stack pointed by sp." @@ -1471,12 +1471,12 @@ STACK-OFF is the index of the first slot frame involved." (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. If SSA non-nil populate it of m-var in ssa form." - (cl-loop with v = (make-vector size nil) + (cl-loop with v = (make-comp-vec) for i below size for mvar = (if ssa (make-comp-ssa-mvar :slot i) (make-comp-mvar :slot i)) - do (aset v i mvar) + do (setf (comp-vec-aref v i) mvar) finally return v)) (defun comp-emit (insn) @@ -2816,7 +2816,7 @@ blocks." (eq op 'fetch-handler)) return t))) - (cl-loop for i from 0 below (comp-func-frame-size comp-func) + (cl-loop for i from 0 below (comp-func-frame-size comp-func) ; FIXME ;; List of blocks with a definition of mvar i for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) for b being each hash-value of blocks @@ -2854,8 +2854,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector - :documentation "Vector of m-vars.")) + (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type comp-vec + :documentation "`comp-vec' of m-vars.")) (defun comp-ssa-rename-insn (insn frame) (dotimes (slot-n (comp-func-frame-size comp-func)) @@ -2866,21 +2866,21 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (aref frame slot-n) mvar + (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) - (let ((mvar (aref frame slot-n))) + (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) (`(fetch-handler . ,_) ;; Clobber all no matter what! - (setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) (_ - (let ((mvar (aref frame slot-n))) + (let ((mvar (comp-vec-aref frame slot-n))) (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () @@ -2900,7 +2900,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for ed in out-edges for child = (comp-edge-dst ed) ;; Provide a copy of the same frame to all children. - do (ssa-rename-rec child (copy-sequence in-frame))))))) + do (ssa-rename-rec child (comp-vec-copy in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) (comp-new-frame frame-size t))))) @@ -2914,7 +2914,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (list (aref in-frame slot-n) + collect (list (comp-vec-aref in-frame slot-n) (comp-block-name b)))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) From bddd7a2d1376d8ee7a318fc837aaaa98b9d9ce49 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 23 Feb 2021 14:35:11 +0100 Subject: [PATCH 1333/1452] Do not emit assumptions referencing clobbered mvars (bug#46670) * lisp/emacs-lisp/comp.el (comp-func): Add `vframe-size' slot. (comp-new-frame): Add `vsize' parameter. (comp-limplify-top-level, comp-limplify-function): Update for new `comp-new-frame'. (comp-maybe-add-vmvar): New function. (comp-add-cond-cstrs): Logic update to emit assumptions not referencing clobbered variables. (comp-place-phis, comp-ssa, comp-ssa-rename-insn) (comp-ssa-rename): Update rename logic to rename also negative slots. (comp-fwprop-insn): Update to handle `(assume mvar mvar)' form. * test/src/comp-tests.el (46670-1): Add testcase. * test/src/comp-test-funcs.el (comp-test-46670-1-f) (comp-test-46670-2-f): New functions. --- lisp/emacs-lisp/comp.el | 102 +++++++++++++++++++++++------------- test/src/comp-test-funcs.el | 7 +++ test/src/comp-tests.el | 6 +++ 3 files changed, 78 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6451d591c5..f18f8e37727 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -809,6 +809,7 @@ non local exit (ends with an `unreachable' insn).")) Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") (frame-size nil :type integer) + (vframe-size 0 :type integer) (blocks (make-hash-table :test #'eq) :type hash-table :documentation "Basic block symbol -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table @@ -1468,11 +1469,11 @@ STACK-OFF is the index of the first slot frame involved." (setf (comp-mvar-typeset mvar) (list type))) mvar)) -(defun comp-new-frame (size &optional ssa) +(defun comp-new-frame (size vsize &optional ssa) "Return a clean frame of meta variables of size SIZE. If SSA non-nil populate it of m-var in ssa form." - (cl-loop with v = (make-comp-vec) - for i below size + (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) + for i from (- vsize) below size for mvar = (if ssa (make-comp-ssa-mvar :slot i) (make-comp-mvar :slot i)) @@ -2116,7 +2117,7 @@ into the C code forwarding the compilation unit." (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) - :frame (comp-new-frame 1)))) + :frame (comp-new-frame 1 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (if for-late-load "Late top level" @@ -2177,7 +2178,7 @@ into the C code forwarding the compilation unit." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size)))) + :frame (comp-new-frame frame-size 0)))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) @@ -2322,6 +2323,18 @@ The assume is emitted at the beginning of the block BB." (_ (cl-assert nil))) (setf (comp-func-ssa-status comp-func) 'dirty))) +(defun comp-maybe-add-vmvar (op cmp-res insns-seq) + "If CMP-RES is clobbering OP emit a new constrained MVAR and return it. +Return OP otherwise." + (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make-comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) + (progn + (push `(assume ,new-mvar ,op) (cdr insns-seq)) + new-mvar) + op)) + (defun comp-add-new-block-between (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop @@ -2427,6 +2440,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (cl-loop named in-the-basic-block + with prev-insns-seq for insns-seq on (comp-block-insns b) do (pcase insns-seq @@ -2452,10 +2466,14 @@ TARGET-BB-SYM is the symbol name of the target block." (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) (when (comp-mvar-used-p target-mvar1) - (comp-emit-assume kind target-mvar1 op2 block-target negated)) + (comp-emit-assume kind target-mvar1 + (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) + block-target negated)) (when (comp-mvar-used-p target-mvar2) (comp-emit-assume (comp-reverse-cmp-fun kind) - target-mvar2 op1 block-target negated))) + target-mvar2 + (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) + block-target negated))) finally (cl-return-from in-the-basic-block))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) @@ -2493,7 +2511,8 @@ TARGET-BB-SYM is the symbol name of the target block." (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) (comp-emit-assume 'and target-mvar cstr block-target negated)) - finally (cl-return-from in-the-basic-block))))))) + finally (cl-return-from in-the-basic-block)))) + (setf prev-insns-seq insns-seq)))) (defsubst comp-insert-insn (insn insn-cell) "Insert INSN as second insn of INSN-CELL." @@ -2816,7 +2835,8 @@ blocks." (eq op 'fetch-handler)) return t))) - (cl-loop for i from 0 below (comp-func-frame-size comp-func) ; FIXME + (cl-loop for i from (- (comp-func-vframe-size comp-func)) + below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) for b being each hash-value of blocks @@ -2854,40 +2874,44 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type comp-vec + (frame (comp-new-frame (comp-func-frame-size comp-func) + (comp-func-vframe-size comp-func) t) + :type comp-vec :documentation "`comp-vec' of m-vars.")) (defun comp-ssa-rename-insn (insn frame) - (dotimes (slot-n (comp-func-frame-size comp-func)) - (cl-flet ((targetp (x) - ;; Ret t if x is an mvar and target the correct slot number. - (and (comp-mvar-p x) - (eql slot-n (comp-mvar-slot x)))) - (new-lvalue () - ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (comp-vec-aref frame slot-n) mvar - (cadr insn) mvar)))) - (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) - (let ((mvar (comp-vec-aref frame slot-n))) - (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) - (new-lvalue)) - (`(fetch-handler . ,_) - ;; Clobber all no matter what! - (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) - (`(phi ,n) - (when (equal n slot-n) - (new-lvalue))) - (_ - (let ((mvar (comp-vec-aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) + (cl-loop + for slot-n from (- (comp-func-vframe-size comp-func)) + below (comp-func-frame-size comp-func) + do + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) mvar + (cadr insn) mvar)))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (let ((mvar (comp-vec-aref frame slot-n))) + (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) + (new-lvalue)) + (`(fetch-handler . ,_) + ;; Clobber all no matter what! + (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) + (_ + (let ((mvar (comp-vec-aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () "Entry point to rename into SSA within the current function." (comp-log "Renaming\n" 2) - (let ((frame-size (comp-func-frame-size comp-func)) - (visited (make-hash-table))) + (let ((visited (make-hash-table))) (cl-labels ((ssa-rename-rec (bb in-frame) (unless (gethash bb visited) (puthash bb t visited) @@ -2903,7 +2927,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (ssa-rename-rec child (comp-vec-copy in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) - (comp-new-frame frame-size t))))) + (comp-new-frame (comp-func-frame-size comp-func) + (comp-func-vframe-size comp-func) + t))))) (defun comp-finalize-phis () "Fixup r-values into phis in all basic blocks." @@ -3094,6 +3120,8 @@ Fold the call in case." (comp-fwprop-call insn lval f args))) (_ (comp-mvar-propagate lval rval)))) + (`(assume ,lval ,(and (pred comp-mvar-p) rval)) + (comp-mvar-propagate lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 694d9d426d5..5bae743d153 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -478,6 +478,13 @@ (eq family 'unspecified)) family))) +(defun comp-test-46670-1-f (x) + "foo") + +(defun comp-test-46670-2-f (s) + (and (equal (comp-test-46670-1-f (length s)) s) + s)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f7b5a6bbb4c..fa84ffbc0bf 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -497,6 +497,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (load (native-compile (concat comp-test-directory "comp-test-45603.el"))) (should (fboundp #'comp-test-45603--file-local-name))) +(comp-deftest 46670-1 () + "" + (should (string= (comp-test-46670-2-f "foo") "foo")) + (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + '(function (t) (or null sequence))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 0ee1a16769bfc8d3e6205e8d8dabc3be34df48b4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 24 Feb 2021 00:03:21 +0100 Subject: [PATCH 1334/1452] Fix async compilation and paramenter naming * lisp/emacs-lisp/comp.el (native--compile-async) (native-compile-async): Fix broken parameter renaming. --- lisp/emacs-lisp/comp.el | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f18f8e37727..9ed92d720cf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4011,7 +4011,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." (defun native--compile-async (files &optional recursively load selector) "Compile FILES asynchronously. -FILES is one path or a list of files to files or directories. +FILES is one filename or a list of filenames or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. @@ -4042,18 +4042,18 @@ bytecode definition was not changed in the meanwhile)." (error "LOAD must be nil, t or 'late")) (unless (listp files) (setf files (list files))) - (let (files) + (let (file-list) (dolist (path files) (cond ((file-directory-p path) (dolist (file (if recursively (directory-files-recursively path comp-valid-source-re) (directory-files path t comp-valid-source-re))) - (push file files))) - ((file-exists-p path) (push path files)) + (push file file-list))) + ((file-exists-p path) (push path file-list)) (t (signal 'native-compiler-error (list "Path not a file nor directory" path))))) - (dolist (file files) + (dolist (file file-list) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) ;; Most likely the byte-compiler has requested a deferred ;; compilation, so update `comp-files-queue' to reflect that. @@ -4125,7 +4125,7 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." ;;;###autoload (defun native-compile-async (files &optional recursively load selector) "Compile FILES asynchronously. -FILES is one path or a list of files to files or directories. +FILES is one file or a list of filenames or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. From 9ae48ae714b03e102957a1e9f9d6430f82c7adaa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 25 Feb 2021 20:25:05 +0100 Subject: [PATCH 1335/1452] * Fix two docstrings in comp.el * lisp/emacs-lisp/comp.el (comp-new-frame, comp-maybe-add-vmvar): Fix docstring. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9ed92d720cf..40c1dfd831b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1470,7 +1470,7 @@ STACK-OFF is the index of the first slot frame involved." mvar)) (defun comp-new-frame (size vsize &optional ssa) - "Return a clean frame of meta variables of size SIZE. + "Return a clean frame of meta variables of size SIZE and VSIZE. If SSA non-nil populate it of m-var in ssa form." (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) for i from (- vsize) below size @@ -2324,7 +2324,7 @@ The assume is emitted at the beginning of the block BB." (setf (comp-func-ssa-status comp-func) 'dirty))) (defun comp-maybe-add-vmvar (op cmp-res insns-seq) - "If CMP-RES is clobbering OP emit a new constrained MVAR and return it. + "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) (new-mvar (make-comp-mvar From 3a31fca5dba41e9905b1293fc73dd1d44abc3138 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 25 Feb 2021 20:46:27 +0100 Subject: [PATCH 1336/1452] * Fix some comp-vec logic * lisp/emacs-lisp/comp.el (comp-vec-length, comp-vec-append) (comp-vec-prepend): Fix logic. (comp-vec-aref): Fix indentation. --- lisp/emacs-lisp/comp.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 40c1dfd831b..ddf3f049e8c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -617,7 +617,7 @@ Useful to hook into pass checkers.") (defsubst comp-vec-length (vec) "Return the number of elements of VEC." - (+ (comp-vec-beg vec) (comp-vec-end vec))) + (- (comp-vec-end vec) (comp-vec-beg vec))) (defsubst comp-vec--verify-idx (vec idx) "Check idx is in bounds for VEC." @@ -628,21 +628,21 @@ Useful to hook into pass checkers.") "Return the element of VEC at index IDX." (declare (gv-setter (lambda (val) `(comp-vec--verify-idx ,vec ,idx) - `(puthash ,idx ,val (comp-vec-data ,vec))))) + `(puthash ,idx ,val (comp-vec-data ,vec))))) (comp-vec--verify-idx vec idx) (gethash idx (comp-vec-data vec))) (defsubst comp-vec-append (vec elt) "Append ELT into VEC. ELT is returned." - (puthash (comp-vec-end vec) elt (comp-vec-aref vec)) + (puthash (comp-vec-end vec) elt (comp-vec-data vec)) (cl-incf (comp-vec-end vec)) elt) (defsubst comp-vec-prepend (vec elt) "Prepend ELT into VEC. ELT is returned." - (puthash (comp-vec-beg vec) elt (comp-vec-aref vec)) + (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec)) (cl-decf (comp-vec-beg vec)) elt) From 54df918ad1e19513768bc27cb3e0a78856d30135 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 26 Feb 2021 08:49:58 +0100 Subject: [PATCH 1337/1452] * Add `comp-async-query-on-exit' customize. * lisp/emacs-lisp/comp.el (comp-async-query-on-exit): New customize. (comp-run-async-workers): Make use of. --- lisp/emacs-lisp/comp.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ddf3f049e8c..6af4ee2beb3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -127,6 +127,10 @@ Usable to modify the compiler environment." "Report warnings and errors from native asynchronous compilation." :type 'boolean) +(defcustom comp-async-query-on-exit nil + "Exiting Emacs, query the user if async compilation process is running." + :type 'boolean) + (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. Note that not all options are meaningful; typically only the options @@ -3928,7 +3932,8 @@ display a message." (native-elisp-load (comp-el-to-eln-filename source-file1) (eq load1 'late))) - (comp-run-async-workers))))) + (comp-run-async-workers)) + :noquery (not comp-async-query-on-exit)))) (puthash source-file process comp-async-compilations)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) From 3266093af97420d2b8b4108f2fc0a7d02d4a34b3 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 26 Feb 2021 16:08:44 +0200 Subject: [PATCH 1338/1452] Improve documentation of last change * lisp/emacs-lisp/comp.el (comp-async-query-on-exit) (comp-async-report-warnings-errors): Improve wording. --- lisp/emacs-lisp/comp.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6af4ee2beb3..c242c5c871e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -124,11 +124,15 @@ Usable to modify the compiler environment." :type 'list) (defcustom comp-async-report-warnings-errors t - "Report warnings and errors from native asynchronous compilation." + "Whether to report warnings and errors from asynchronous native compilation." :type 'boolean) (defcustom comp-async-query-on-exit nil - "Exiting Emacs, query the user if async compilation process is running." + "Whether to query the user about killing async compilations when exiting. +If this is non-nil, Emacs will ask for confirmation to exit and kill the +asynchronous native compilations if any are running. If nil, when you +exit Emacs, it will silently kill those asynchronous compilations even +if `confirm-kill-processes' is non-nil." :type 'boolean) (defcustom comp-native-driver-options nil From ad74b1b2b64cfe989213fc69337dbb0eda858d10 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 26 Feb 2021 15:15:06 +0100 Subject: [PATCH 1339/1452] * Improve `comp-async-report-warnings-errors' docstring * lisp/emacs-lisp/comp.el (comp-async-report-warnings-errors): Improve docstring. --- lisp/emacs-lisp/comp.el | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c242c5c871e..184aef489dc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -124,7 +124,18 @@ Usable to modify the compiler environment." :type 'list) (defcustom comp-async-report-warnings-errors t - "Whether to report warnings and errors from asynchronous native compilation." + "Whether to report warnings and errors from asynchronous native compilation. + +When native compilation happens asynchronously this can produce +warnings and errors, some of these diagnostic messages might not be +emitted by the first synchronous byte-compilation. The typical case +for that is byte-compiling a file that is missing to require a +necessary feature while having it already loaded into the environment. + +As asynchronous native compilation always starts from a fresh +environment it is more sensitive into highlighting issues about non +consistent source files and might not be able to compile correctly +these." :type 'boolean) (defcustom comp-async-query-on-exit nil From 5540d73441a8fb518cc876ba01561d0875739283 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 26 Feb 2021 16:50:41 +0200 Subject: [PATCH 1340/1452] Fix last change * lisp/emacs-lisp/comp.el (comp-async-report-warnings-errors): Improve wording of the doc string. --- lisp/emacs-lisp/comp.el | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 184aef489dc..d559fa02514 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -126,16 +126,18 @@ Usable to modify the compiler environment." (defcustom comp-async-report-warnings-errors t "Whether to report warnings and errors from asynchronous native compilation. -When native compilation happens asynchronously this can produce -warnings and errors, some of these diagnostic messages might not be -emitted by the first synchronous byte-compilation. The typical case -for that is byte-compiling a file that is missing to require a -necessary feature while having it already loaded into the environment. +When native compilation happens asynchronously, it can produce +warnings and errors, some of which might not be emitted by a +byte-compilation. The typical case for that is native-compiling +a file that is missing some `require' of a necessary feature, +while having it already loaded into the environment when +byte-compiling. -As asynchronous native compilation always starts from a fresh -environment it is more sensitive into highlighting issues about non -consistent source files and might not be able to compile correctly -these." +As asynchronous native compilation always starts from a pristine +environment, it is more sensitive to such omissions, and might be +unable to compile such Lisp source files correctly. + +Set this variable to nil if these warnings annoy you." :type 'boolean) (defcustom comp-async-query-on-exit nil From 720bd747a80a5fe2f774997ae85d6607b5627e56 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 26 Feb 2021 17:56:36 +0100 Subject: [PATCH 1341/1452] Add :version tags to defcustoms in comp.el * lisp/emacs-lisp/comp.el (comp-speed, comp-debug, comp-verbose) (comp-never-optimize-functions, comp-async-jobs-number) (comp-async-cu-done-hook, comp-async-all-done-hook) (comp-async-env-modifier-form) (comp-async-report-warnings-errors, comp-native-driver-options) (comp-libgccjit-reproducer): Add :version tags. --- lisp/emacs-lisp/comp.el | 43 +++++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d559fa02514..7c702ca4971 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,7 +54,7 @@ Warning: the compiler is free to perform dangerous optimizations." :type 'number :safe #'numberp - :group 'comp) + :version "28.1") (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. @@ -66,7 +66,7 @@ This intended for debugging the compiler itself. - 3 dump libgccjit reproducers." :type 'number :safe #'numberp - :group 'comp) + :version "28.1") (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. @@ -75,23 +75,27 @@ This intended for debugging the compiler itself. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. - 3 max verbosity." - :type 'number) + :type 'number + :version "28.1") (defcustom comp-always-compile nil "Unconditionally (re-)compile all files." - :type 'boolean) + :type 'boolean + :version "28.1") (defcustom comp-deferred-compilation-deny-list '() "List of regexps to exclude files from deferred native compilation. Skip if any is matching." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-never-optimize-functions '(;; The following two are mandatory for Emacs to be working @@ -99,12 +103,14 @@ Skip if any is matching." ;; REMOVE. macroexpand rename-buffer) "Primitive functions for which we do not perform trampoline optimization." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'number) + :type 'number + :version "28.1") ;; FIXME: This an abnormal hook, and should be renamed to something ;; like `comp-async-cu-done-function'. @@ -112,16 +118,19 @@ When zero use half of the CPUs or at least one." "Hook run after asynchronously compiling a single compilation unit. The argument FILE passed to the function is the filename used as compilation input." - :type 'hook) + :type 'hook + :version "28.1") (defcustom comp-async-all-done-hook nil "Hook run after asynchronously compiling all input files." - :type 'hook) + :type 'hook + :version "28.1") (defcustom comp-async-env-modifier-form nil "Form evaluated before compilation by each asynchronous compilation worker. Usable to modify the compiler environment." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-async-report-warnings-errors t "Whether to report warnings and errors from asynchronous native compilation. @@ -138,7 +147,8 @@ environment, it is more sensitive to such omissions, and might be unable to compile such Lisp source files correctly. Set this variable to nil if these warnings annoy you." - :type 'boolean) + :type 'boolean + :version "28.1") (defcustom comp-async-query-on-exit nil "Whether to query the user about killing async compilations when exiting. @@ -146,7 +156,8 @@ If this is non-nil, Emacs will ask for confirmation to exit and kill the asynchronous native compilations if any are running. If nil, when you exit Emacs, it will silently kill those asynchronous compilations even if `confirm-kill-processes' is non-nil." - :type 'boolean) + :type 'boolean + :version "28.1") (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. @@ -155,13 +166,15 @@ affecting the assembler and linker are likely to be useful. Passing these options is only available in libgccjit version 9 and above." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-libgccjit-reproducer nil "When non-nil produce a libgccjit reproducer. The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in the .eln output directory." - :type 'boolean) + :type 'boolean + :version "28.1") (defvar comp-log-time-report nil "If non-nil, log a time report for each pass.") From cedc55041ea5179dcb389845d2d0e3562060cab9 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 26 Feb 2021 18:03:19 +0100 Subject: [PATCH 1342/1452] Make some defcustom types stricter in comp.el * lisp/emacs-lisp/comp.el (comp-speed, comp-debug, comp-verbose) (comp-async-jobs-number, comp-async-env-modifier-form): Use stricter types. --- lisp/emacs-lisp/comp.el | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7c702ca4971..09ae3834922 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -52,8 +52,8 @@ - 2 max optimization level fully adherent to the language semantic. - 3 max optimization level, to be used only when necessary. Warning: the compiler is free to perform dangerous optimizations." - :type 'number - :safe #'numberp + :type 'integer + :safe #'integerp :version "28.1") (defcustom comp-debug 0 @@ -64,8 +64,8 @@ This intended for debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." - :type 'number - :safe #'numberp + :type 'integer + :safe #'natnump :version "28.1") (defcustom comp-verbose 0 @@ -75,7 +75,8 @@ This intended for debugging the compiler itself. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. - 3 max verbosity." - :type 'number + :type 'integer + :risky t :version "28.1") (defcustom comp-always-compile nil @@ -109,7 +110,8 @@ Skip if any is matching." (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'number + :type 'integer + :risky t :version "28.1") ;; FIXME: This an abnormal hook, and should be renamed to something @@ -130,6 +132,7 @@ compilation input." "Form evaluated before compilation by each asynchronous compilation worker. Usable to modify the compiler environment." :type 'list + :risky t :version "28.1") (defcustom comp-async-report-warnings-errors t From b84c1727ea035cd47ab9ac5cb6627d402896f21d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 26 Feb 2021 19:57:41 +0100 Subject: [PATCH 1343/1452] * Interactive tag native compilation function in emacs-lisp-mode * lisp/progmodes/elisp-mode.el (emacs-lisp-native-compile-and-load): Tag it for `emacs-lisp-mode'. --- lisp/progmodes/elisp-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 408da8a9628..d040fdda28c 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -212,7 +212,7 @@ 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) + (interactive nil emacs-lisp-mode) (emacs-lisp--before-compile-buffer) (load (native-compile buffer-file-name))) From 42fc752a14b23be95f02b598930f13a96883d3a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 26 Feb 2021 20:11:31 +0100 Subject: [PATCH 1344/1452] * Change native compiler configure flag into '--with-native-compilation' * configure.ac: Rename configure nativecomp flags into --with-native-compilation. --- configure.ac | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index fe0dc921dce..3dff9ea2e2d 100644 --- a/configure.ac +++ b/configure.ac @@ -484,7 +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([nativecomp],[compile with Emacs Lisp native compiler 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)])], @@ -3786,7 +3786,7 @@ 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-nativecomp + --without-native-compilation to configure.])]) AC_DEFUN([libgccjit_dev_not_found], [ @@ -3808,7 +3808,7 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -if test "${with_nativecomp}" != "no"; then +if test "${with_native_compilation}" != "no"; then if test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) fi From 312deba5302a8136fa104b054af54572cc64ea5e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 26 Feb 2021 21:27:02 +0100 Subject: [PATCH 1345/1452] * Canonicalize filenames on Windows before hashing (bug#46256) * src/comp.c (Fcomp_el_to_eln_filename): On Windowns canonicalize filenames before hashing. --- src/comp.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index a8b8ef95fa1..1a89e4e62a4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3983,6 +3983,10 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) if (NILP (Ffile_exists_p (filename))) xsignal1 (Qfile_missing, filename); +#ifdef WINDOWSNT + filename = Fw32_long_file_name (filename); +#endif + Lisp_Object content_hash = comp_hash_source_file (filename); if (suffix_p (filename, ".gz")) @@ -4014,8 +4018,11 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) Lisp_Object sys_re = concat2 (build_string ("\\`[[:ascii:]]+"), Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/"))); - loadsearch_re_list = - list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH "/"))); + Lisp_Object dump_load_search = build_string (PATH_DUMPLOADSEARCH "/"); +#ifdef WINDOWSNT + dump_load_search = Fw32_long_file_name (dump_load_search); +#endif + loadsearch_re_list = list2 (sys_re, Fregexp_quote (dump_load_search)); } Lisp_Object lds_re_tail = loadsearch_re_list; From 2acc46b55bdf518ece6301913ffa074f31563fa4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 27 Feb 2021 21:26:41 +0100 Subject: [PATCH 1346/1452] Migrate and rename a bunch of functions from comp.el to comp-cstr.el * lisp/emacs-lisp/comp-cstr.el (comp-cstr-imm-vld-p) (comp-cstr-imm, comp-cstr-fixnum-p, comp-cstr-symbol-p) (comp-cstr-cons-p): Move and rename from 'comp.el'. * lisp/emacs-lisp/comp.el (comp-mvar-type-hint-match-p) (make-comp-mvar, comp-emit-assume, comp-fwprop-prologue) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-fwprop-call, comp-fwprop-insn, comp-call-optim-func) (comp-compute-function-type): Update for renamed functions. * src/comp.c (emit_mvar_rval): Likewise. * test/src/comp-tests.el (comp-tests-mentioned-p-1) (comp-tests-cond-rw-checker-val): Likewise. --- lisp/emacs-lisp/comp-cstr.el | 70 ++++++++++++++++++++++++ lisp/emacs-lisp/comp.el | 100 ++++++----------------------------- src/comp.c | 4 +- test/src/comp-tests.el | 8 +-- 4 files changed, 93 insertions(+), 89 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c294c53b6b0..89815f03b53 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -789,6 +789,76 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;;; Entry points. +(defun comp-cstr-imm-vld-p (cstr) + "Return t if one and only one immediate value can be extracted from CSTR." + (with-comp-cstr-accessors + (when (and (null (typeset cstr)) + (null (neg cstr))) + (let* ((v (valset cstr)) + (r (range cstr)) + (valset-len (length v)) + (range-len (length r))) + (if (and (= valset-len 1) + (= range-len 0)) + t + (when (and (= valset-len 0) + (= range-len 1)) + (let* ((low (caar r)) + (high (cdar r))) + (and (integerp low) + (integerp high) + (= low high))))))))) + +(defun comp-cstr-imm (cstr) + "Return the immediate value of CSTR. +`comp-cstr-imm-vld-p' *must* be satisfied before calling +`comp-cstr-imm'." + (declare (gv-setter + (lambda (val) + `(with-comp-cstr-accessors + (if (integerp ,val) + (setf (typeset ,cstr) nil + (range ,cstr) (list (cons ,val ,val))) + (setf (typeset ,cstr) nil + (valset ,cstr) (list ,val))))))) + (with-comp-cstr-accessors + (let ((v (valset cstr))) + (if (= (length v) 1) + (car v) + (caar (range cstr)))))) + +(defun comp-cstr-fixnum-p (cstr) + "Return t if CSTR is certainly a fixnum." + (with-comp-cstr-accessors + (when (null (neg cstr)) + (when-let (range (range cstr)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t)))))) + +(defun comp-cstr-symbol-p (cstr) + "Return t if CSTR is certainly a symbol." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (or (and (null (valset cstr)) + (equal (typeset cstr) '(symbol))) + (and (or (null (typeset cstr)) + (equal (typeset cstr) '(symbol))) + (cl-every #'symbolp (valset cstr))))))) + +(defsubst comp-cstr-cons-p (cstr) + "Return t if CSTR is certainly a cons." + (with-comp-cstr-accessors + (and (null (valset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (typeset cstr) '(cons))))) + (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. SRC can be either a comp-cstr or an integer." diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 09ae3834922..e71d4abbd53 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -885,78 +885,12 @@ CFG is mutated by a pass.") :documentation "Slot number in the array if a number or 'scratch' for scratch slot.")) -(defun comp-mvar-value-vld-p (mvar) - "Return t if one single value can be extracted by the MVAR constrains." - (when (and (null (comp-mvar-typeset mvar)) - (null (comp-mvar-neg mvar))) - (let* ((v (comp-mvar-valset mvar)) - (r (comp-mvar-range mvar)) - (valset-len (length v)) - (range-len (length r))) - (if (and (= valset-len 1) - (= range-len 0)) - t - (when (and (= valset-len 0) - (= range-len 1)) - (let* ((low (caar r)) - (high (cdar r))) - (and (integerp low) - (integerp high) - (= low high)))))))) - -;; FIXME move these into cstr? - -(defun comp-mvar-value (mvar) - "Return the constant value of MVAR. -`comp-mvar-value-vld-p' *must* be satisfied before calling -`comp-mvar-const'." - (declare (gv-setter - (lambda (val) - `(if (integerp ,val) - (setf (comp-mvar-typeset ,mvar) nil - (comp-mvar-range ,mvar) (list (cons ,val ,val))) - (setf (comp-mvar-typeset ,mvar) nil - (comp-mvar-valset ,mvar) (list ,val)))))) - (let ((v (comp-mvar-valset mvar))) - (if (= (length v) 1) - (car v) - (caar (comp-mvar-range mvar))))) - -(defun comp-mvar-fixnum-p (mvar) - "Return t if MVAR is certainly a fixnum." - (when (null (comp-mvar-neg mvar)) - (when-let (range (comp-mvar-range mvar)) - (let* ((low (caar range)) - (high (cdar (last range)))) - (unless (or (eq low '-) - (< low most-negative-fixnum) - (eq high '+) - (> high most-positive-fixnum)) - t))))) - -(defun comp-mvar-symbol-p (mvar) - "Return t if MVAR is certainly a symbol." - (and (null (comp-mvar-range mvar)) - (null (comp-mvar-neg mvar)) - (or (and (null (comp-mvar-valset mvar)) - (equal (comp-mvar-typeset mvar) '(symbol))) - (and (or (null (comp-mvar-typeset mvar)) - (equal (comp-mvar-typeset mvar) '(symbol))) - (cl-every #'symbolp (comp-mvar-valset mvar)))))) - -(defsubst comp-mvar-cons-p (mvar) - "Return t if MVAR is certainly a cons." - (and (null (comp-mvar-valset mvar)) - (null (comp-mvar-range mvar)) - (null (comp-mvar-neg mvar)) - (equal (comp-mvar-typeset mvar) '(cons)))) - (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. In use by the backend." (cl-ecase type-hint - (cons (comp-mvar-cons-p mvar)) - (fixnum (comp-mvar-fixnum-p mvar)))) + (cons (comp-cstr-cons-p mvar)) + (fixnum (comp-cstr-fixnum-p mvar)))) @@ -1501,7 +1435,7 @@ STACK-OFF is the index of the first slot frame involved." (let ((mvar (make--comp-mvar :slot slot))) (when const-vld (comp-add-const-to-relocs constant) - (setf (comp-mvar-value mvar) constant)) + (setf (comp-cstr-imm mvar) constant)) (when type (setf (comp-mvar-typeset mvar) (list type))) mvar)) @@ -2351,8 +2285,8 @@ The assume is emitted at the beginning of the block BB." kind))) (push `(assume ,(make-comp-mvar :slot lhs-slot) (,kind ,lhs - ,(if-let* ((vld (comp-mvar-value-vld-p rhs)) - (val (comp-mvar-value rhs)) + ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) + (val (comp-cstr-imm rhs)) (ok (integerp val))) val (make-comp-mvar :slot (comp-mvar-slot rhs))))) @@ -3077,7 +3011,7 @@ Forward propagate immediate involed in assignments." for insn in (comp-block-insns b) do (pcase insn (`(setimm ,lval ,v) - (setf (comp-mvar-value lval) v)))))) + (setf (comp-cstr-imm lval) v)))))) (defun comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." @@ -3089,7 +3023,7 @@ Forward propagate immediate involed in assignments." (defun comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." (and (comp-function-pure-p f) - (cl-every #'comp-mvar-value-vld-p args))) + (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call. @@ -3102,10 +3036,10 @@ Return non-nil if the function is folded successfully." (cond ((eq f 'symbol-value) (when-let* ((arg0 (car args)) - (const (comp-mvar-value-vld-p arg0)) - (ok-to-optim (member (comp-mvar-value arg0) + (const (comp-cstr-imm-vld-p arg0)) + (ok-to-optim (member (comp-cstr-imm arg0) comp-symbol-values-optimizable))) - (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-value + (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm (car args)))))) ((comp-function-foldable-p f args) (ignore-errors @@ -3118,7 +3052,7 @@ Return non-nil if the function is folded successfully." ;; and know to be pure. (comp-func-byte-func f-in-ctxt) f)) - (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) + (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args)))) (rewrite-insn-as-setimm insn value))))))) (defun comp-fwprop-call (insn lval f args) @@ -3127,8 +3061,8 @@ F is the function being called with arguments ARGS. Fold the call in case." (unless (comp-function-call-maybe-fold insn f args) (when (and (eq 'funcall f) - (comp-mvar-value-vld-p (car args))) - (setf f (comp-mvar-value (car args)) + (comp-cstr-imm-vld-p (car args))) + (setf f (comp-cstr-imm (car args)) args (cdr args))) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (let ((cstr (comp-cstr-f-ret cstr-f))) @@ -3176,7 +3110,7 @@ Fold the call in case." (<= (comp-cstr-<= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) - (setf (comp-mvar-value lval) v)) + (setf (comp-cstr-imm lval) v)) (`(phi ,lval . ,rest) (let* ((from-latch (cl-some (lambda (x) @@ -3337,11 +3271,11 @@ FUNCTION can be a function-name or byte compiled function." (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-value f) rest))) + (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-value f) rest))) + (comp-cstr-imm f) rest))) (setf insn new-form))))))) (defun comp-call-optim (_) @@ -3539,7 +3473,7 @@ Set it into the `type' slot." ,(comp-cstr-to-type-spec res-mvar)))) (comp-add-const-to-relocs type) ;; Fix it up. - (setf (comp-mvar-value (comp-func-type func)) type)))) + (setf (comp-cstr-imm (comp-func-type func)) type)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/src/comp.c b/src/comp.c index 1a89e4e62a4..21d1c1a23cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1747,11 +1747,11 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_rval (Lisp_Object mvar) { - Lisp_Object const_vld = CALL1I (comp-mvar-value-vld-p, mvar); + Lisp_Object const_vld = CALL1I (comp-cstr-imm-vld-p, mvar); if (!NILP (const_vld)) { - Lisp_Object value = CALL1I (comp-mvar-value, mvar); + Lisp_Object value = CALL1I (comp-cstr-imm, mvar); if (comp.debug > 1) { Lisp_Object func = diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fa84ffbc0bf..402ba7cd8b8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -739,8 +739,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (cl-loop for y in insn when (cond ((consp y) (comp-tests-mentioned-p x y)) - ((and (comp-mvar-p y) (comp-mvar-value-vld-p y)) - (equal (comp-mvar-value y) x)) + ((and (comp-mvar-p y) (comp-cstr-imm-vld-p y)) + (equal (comp-cstr-imm y) x)) (t (equal x y))) return t)) @@ -1313,8 +1313,8 @@ Return a list of results." (lambda (insn) (pcase insn (`(return ,mvar) - (and (comp-mvar-value-vld-p mvar) - (eql (comp-mvar-value mvar) 123))))))))) + (and (comp-cstr-imm-vld-p mvar) + (eql (comp-cstr-imm mvar) 123))))))))) (defvar comp-tests-cond-rw-expected-type nil "Type to expect in `comp-tests-cond-rw-checker-type'.") From 5bc08559e8f171eafc3c034232f8cfd9eaf89862 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 27 Feb 2021 22:00:11 +0100 Subject: [PATCH 1347/1452] Don't treat '=' as simple equality emitting constraints (bug#46812) Extend assumes allowing the following form (assume dst (= src1 src2)) to caputure '=' semanting during fwprop handling float integer conversions. * lisp/emacs-lisp/comp.el (comp-equality-fun-p): Don't treat '=' as simple equality. (comp-arithm-cmp-fun-p, comp-negate-arithm-cmp-fun) (comp-reverse-arithm-fun): Rename and add '=' '!='. (comp-emit-assume, comp-add-cond-cstrs, comp-fwprop-insn): Update for new function nameing and to handle '='. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): New function. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a bunch of '=' specific tests. --- lisp/emacs-lisp/comp-cstr.el | 12 +++++++++ lisp/emacs-lisp/comp.el | 37 ++++++++++++++++------------ test/src/comp-tests.el | 47 +++++++++++++++++++++++++++++++----- 3 files changed, 75 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 89815f03b53..bd1e04fb0bb 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -859,6 +859,18 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +(defun comp-cstr-= (dst old-dst src) + "Constraint DST being = SRC." + (with-comp-cstr-accessors + (comp-cstr-intersection dst old-dst src) + (cl-loop for v in (valset dst) + when (and (floatp v) + (= v (truncate v))) + do (push (cons (truncate v) (truncate v)) (range dst))) + (cl-loop for (l . h) in (range dst) + when (eql l h) + do (push (float l) (valset dst))))) + (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. SRC can be either a comp-cstr or an integer." diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e71d4abbd53..03999d3e66f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -906,11 +906,11 @@ To be used by all entry points." (defun comp-equality-fun-p (function) "Equality functions predicate for FUNCTION." - (when (memq function '(eq eql = equal)) t)) + (when (memq function '(eq eql equal)) t)) -(defun comp-range-cmp-fun-p (function) - "Predicate for range comparision functions." - (when (memq function '(> < >= <=)) t)) +(defun comp-arithm-cmp-fun-p (function) + "Predicate for arithmetic comparision functions." + (when (memq function '(= > < >= <=)) t)) (defun comp-set-op-p (op) "Assignment predicate for OP." @@ -2238,17 +2238,21 @@ into the C code forwarding the compilation unit." else do (comp-collect-mvars args)))) -(defun comp-negate-range-cmp-fun (function) - "Negate FUNCTION." +(defun comp-negate-arithm-cmp-fun (function) + "Negate FUNCTION. +Return nil if we don't want to emit constraints for its +negation." (cl-ecase function + (= nil) (> '<=) (< '>=) (>= '<) (<= '>))) -(defun comp-reverse-cmp-fun (function) +(defun comp-reverse-arithm-fun (function) "Reverse FUNCTION." (cl-case function + (= '=) (> '<) (< '>) (>= '<=) @@ -2279,15 +2283,16 @@ The assume is emitted at the beginning of the block BB." (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) - ((pred comp-range-cmp-fun-p) - (let ((kind (if negated - (comp-negate-range-cmp-fun kind) - kind))) + ((pred comp-arithm-cmp-fun-p) + (when-let ((kind (if negated + (comp-negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make-comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) (val (comp-cstr-imm rhs)) - (ok (integerp val))) + (ok (and (integerp val) + (not (memq kind '(= !=)))))) val (make-comp-mvar :slot (comp-mvar-slot rhs))))) (comp-block-insns bb)))) @@ -2418,7 +2423,7 @@ TARGET-BB-SYM is the symbol name of the target block." (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) ,(and (or (pred comp-equality-fun-p) - (pred comp-range-cmp-fun-p)) + (pred comp-arithm-cmp-fun-p)) fun) ,op1 ,op2)) ;; (comment ,_comment-str) @@ -2441,7 +2446,7 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) block-target negated)) (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume (comp-reverse-cmp-fun kind) + (comp-emit-assume (comp-reverse-arithm-fun kind) target-mvar2 (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) block-target negated))) @@ -3108,7 +3113,9 @@ Fold the call in case." (< (comp-cstr-< lval (car operands) (cadr operands))) (<= - (comp-cstr-<= lval (car operands) (cadr operands))))) + (comp-cstr-<= lval (car operands) (cadr operands))) + (= + (comp-cstr-= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 402ba7cd8b8..0598eeeb05d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -891,24 +891,24 @@ Return a list of results." ;; 10 ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) + (if (eql x 3) x 'foo)) (or (member foo) (integer 3 3))) ;; 11 ((defun comp-tests-ret-type-spec-f (x) - (if (= 3 x) + (if (eql 3 x) x 'foo)) (or (member foo) (integer 3 3))) ;; 12 ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) + (if (eql x 3) 'foo x)) - (or (member foo) marker number)) + (not (integer 3 3))) ;; 13 ((defun comp-tests-ret-type-spec-f (x y) @@ -1214,7 +1214,7 @@ Return a list of results." ;; 57 ((defun comp-tests-ret-type-spec-f (x) (unless (or (eq x 'foo) - (= x 3)) + (eql x 3)) (error "Not foo or 3")) x) (or (member foo) (integer 3 3))) @@ -1244,7 +1244,42 @@ Return a list of results." (>= x y)) x (error ""))) - (or float (integer 3 10))))) + (or float (integer 3 10))) + + ;; 61 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 62 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 63 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.1) + x + (error ""))) + (member 1.1)) + + ;; 64 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 65 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 3d014e1bf48f661f0b229ddf735608ff0ba7cfe6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 1 Mar 2021 19:39:00 +0100 Subject: [PATCH 1348/1452] Fix `eql' `equal' propagation of non hash consed values (bug#46843) Extend assumes allowing the following form: (assume dst (and-nhc src1 src2)) `and-nhc' assume operator allow for constraining correctly intersections where non hash consed values are not propagated as values but rather promoted to their types. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-no-hashcons): New function. * lisp/emacs-lisp/comp.el (comp-emit-assume): Logic update to emit `and-nhc' operator (implemented in fwprop by `comp-cstr-intersection-no-hashcons'). (comp-add-cond-cstrs): Map `eq' to `and' assume operator and `equal' `eql' into `and-nhc'. (comp-fwprop-insn): Update to handle `and-nhc'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests covering `eql' and `equal' propagation of non hash consed values. --- lisp/emacs-lisp/comp-cstr.el | 22 ++++++++++++++++++++++ lisp/emacs-lisp/comp.el | 15 ++++++++++----- test/src/comp-tests.el | 16 +++++++++++++++- 3 files changed, 47 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index bd1e04fb0bb..d98ef681b58 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -968,6 +968,28 @@ DST is returned." (neg dst) (neg res)) res))) +(defun comp-cstr-intersection-no-hashcons (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +Non hash consed values are not propagated as values but rather +promoted to their types. +DST is returned." + (with-comp-cstr-accessors + (apply #'comp-cstr-intersection dst srcs) + (let (strip-values strip-types) + (cl-loop for v in (valset dst) + unless (or (symbolp v) + (fixnump v)) + do (push v strip-values) + (push (type-of v) strip-types)) + (when strip-values + (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) + (valset dst) (cl-set-difference (valset dst) strip-values))) + (cl-loop for (l . h) in (range dst) + when (or (bignump l) (bignump h)) + do (setf (range dst) '((- . +))) + (cl-return)) + dst))) + (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 03999d3e66f..af14afd42bb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2266,20 +2266,20 @@ The assume is emitted at the beginning of the block BB." (let ((lhs-slot (comp-mvar-slot lhs))) (cl-assert lhs-slot) (pcase kind - ('and + ((or 'and 'and-nhc) (if (comp-mvar-p rhs) (let ((tmp-mvar (if negated (make-comp-mvar :slot (comp-mvar-slot rhs)) rhs))) (push `(assume ,(make-comp-mvar :slot lhs-slot) - (and ,lhs ,tmp-mvar)) + (,kind ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated (push `(assume ,tmp-mvar (not ,rhs)) (comp-block-insns bb)))) ;; If is only a constraint we can negate it directly. (push `(assume ,(make-comp-mvar :slot lhs-slot) - (and ,lhs ,(if negated + (,kind ,lhs ,(if negated (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) @@ -2431,11 +2431,14 @@ TARGET-BB-SYM is the symbol name of the target block." (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) - with equality = (comp-equality-fun-p fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) - for kind = (if equality 'and fun) + for kind = (cl-case fun + (equal 'and-nhc) + (eql 'and-nhc) + (eq 'and) + (t fun)) when (or (comp-mvar-used-p target-mvar1) (comp-mvar-used-p target-mvar2)) do @@ -3102,6 +3105,8 @@ Fold the call in case." (cl-case kind (and (apply #'comp-cstr-intersection lval operands)) + (and-nhc + (apply #'comp-cstr-intersection-no-hashcons lval operands)) (not ;; Prevent double negation! (unless (comp-cstr-neg (car operands)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0598eeeb05d..651df332966 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1279,7 +1279,21 @@ Return a list of results." (if (= x 1) x (error ""))) - (or (member 1.0) (integer 1 1))))) + (or (member 1.0) (integer 1 1))) + + ;; 66 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 0.0) + x + (error ""))) + float) + + ;; 67 + ((defun comp-tests-ret-type-spec-f (x) + (if (equal x '(1 2 3)) + x + (error ""))) + cons))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 8c7228e8cde9a33f8128933f991f6432e58cfde3 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Mar 2021 08:43:39 +0100 Subject: [PATCH 1349/1452] Fix = propagation semantic for constrained inputs * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Synthesize `comp-cstr-shallow-copy'. (comp-cstr-=): Relax inputs before intersecting them. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add three tests. --- lisp/emacs-lisp/comp-cstr.el | 41 ++++++++++++++++++++++++++---------- test/src/comp-tests.el | 29 ++++++++++++++++++++++++- 2 files changed, 58 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d98ef681b58..996502b2869 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -71,7 +71,7 @@ (irange &aux (range (list irange)) (typeset ()))) - (:copier nil)) + (:copier comp-cstr-shallow-copy)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -859,17 +859,36 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) -(defun comp-cstr-= (dst old-dst src) - "Constraint DST being = SRC." +(defun comp-cstr-= (dst op1 op2) + "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors - (comp-cstr-intersection dst old-dst src) - (cl-loop for v in (valset dst) - when (and (floatp v) - (= v (truncate v))) - do (push (cons (truncate v) (truncate v)) (range dst))) - (cl-loop for (l . h) in (range dst) - when (eql l h) - do (push (float l) (valset dst))))) + (cl-flet ((relax-cstr (cstr) + (setf cstr (comp-cstr-shallow-copy cstr)) + ;; If can be any float extend it to all integers. + (when (memq 'float (typeset cstr)) + (setf (range cstr) '((- . +)))) + ;; For each float value that can be represented + ;; precisely as an integer add the integer as well. + (cl-loop + for v in (valset cstr) + when (and (floatp v) + (= v (truncate v))) + do (push (cons (truncate v) (truncate v)) (range cstr))) + (cl-loop + with vals-to-add + for (l . h) in (range cstr) + ;; If an integer range reduces to single value add + ;; its float value too. + if (eql l h) + do (push (float l) vals-to-add) + ;; Otherwise can be any float. + else + do (cl-pushnew 'float (typeset cstr)) + (cl-return cstr) + finally (setf (valset cstr) + (append vals-to-add (valset cstr)))) + cstr)) + (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2))))) (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 651df332966..3f007d2a592 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1293,7 +1293,34 @@ Return a list of results." (if (equal x '(1 2 3)) x (error ""))) - cons))) + cons) + + ;; 69 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (floatp x) + (= x 0)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + (or (member 0.0) (integer 0 0))) + + ;; 70 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (integer x) + (= x 0)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + (or (member 0.0) (integer 0 0))) + + ;; 71 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (floatp x) + (integerp y) + (= x y)) + x + (error ""))) + (or float integer)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 4f90b0b6e6249597cf2e1450b5b9d7f6522c049f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 3 Mar 2021 13:59:08 +0200 Subject: [PATCH 1350/1452] Improve NEWS entries about native-compilation * etc/NEWS: Add an entry about native-compilation. Improve wording of the entry about 'package-native-compile'. --- etc/NEWS | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index a37a38c2c66..a5ea7eb07bc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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. @@ -1149,9 +1154,13 @@ key binding / u package-menu-filter-upgradable / / package-menu-filter-clear -*** Option to automatically native compile packages on installation. -Customize the user option `package-native-compile' to enable automatic -native compilation of packages on installation. +*** 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. From e5a0d4c42583fe38e38ab7782b8928ca54f82fad Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 3 Mar 2021 19:58:20 +0200 Subject: [PATCH 1351/1452] Avoid aborting on MS-Windows at startup * src/emacs.c (set_invocation_vars) [WINDOWSNT]: If argv0 is not an absolute file name, obtain the absolute file name of the Emacs executable from 'w32_my_exename'. --- src/emacs.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/emacs.c b/src/emacs.c index d541b41f3f1..ec62c19e388 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -37,6 +37,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include /* for IS_ABSOLUTE_FILE_NAME */ #include "w32.h" #include "w32heap.h" #endif @@ -433,6 +434,12 @@ set_invocation_vars (char *argv0, char const *original_pwd) { char argv0_1[MAX_UTF8_PATH]; + /* Avoid calling 'openp' below, as we aren't ready for that yet: + emacs_dir is not yet defined in the environment, and therefore + emacs_root_dir, called by expand-file-name, will abort. */ + if (!IS_ABSOLUTE_FILE_NAME (argv0)) + argv0 = w32_my_exename (); + if (filename_from_ansi (argv0, argv0_1) == 0) raw_name = build_unibyte_string (argv0_1); else @@ -451,6 +458,11 @@ set_invocation_vars (char *argv0, char const *original_pwd) Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); +#ifdef WINDOWSNT + eassert (!NILP (Vinvocation_directory) + && !NILP (Ffile_name_absolute_p (Vinvocation_directory))); +#endif + /* If we got no directory in argv0, search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) From 30810905de7662b36b7ac9275bb9cbb2a563c277 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 3 Mar 2021 20:15:58 +0200 Subject: [PATCH 1352/1452] Fix compilation warnings in --with-wide-int build on Windows * src/comp.c (emit_rvalue_from_emacs_uint) (emit_rvalue_from_lisp_word_tag): Fix comparison of unsigned values. (gcc_jit_context_new_rvalue_from_ptr): Define only if LISP_WORDS_ARE_POINTERS, to avoid compilation warning. (init_gccjit_functions): Load gcc_jit_context_new_rvalue_from_ptr only if LISP_WORDS_ARE_POINTERS. --- src/comp.c | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index 21d1c1a23cf..d74f8328fda 100644 --- a/src/comp.c +++ b/src/comp.c @@ -179,8 +179,10 @@ DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison, enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); +#if LISP_WORDS_ARE_POINTERS DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +#endif DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal, (gcc_jit_context *ctxt, const char *value)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, @@ -290,7 +292,9 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_context_new_param); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); +#if LISP_WORDS_ARE_POINTERS LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); +#endif LOAD_DLL_FN (library, gcc_jit_context_new_string_literal); LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); @@ -357,7 +361,9 @@ init_gccjit_functions (void) #define gcc_jit_context_new_param fn_gcc_jit_context_new_param #define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int #define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long -#define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#if LISP_WORDS_ARE_POINTERS +# define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#endif #define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal #define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type #define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op @@ -1137,7 +1143,7 @@ static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { #ifdef WIDE_EMACS_INT - if (val > LONG_MAX || val < LONG_MIN) + if (val > ULONG_MAX) return emit_rvalue_from_long_long (comp.emacs_uint_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1159,7 +1165,7 @@ static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { #ifdef WIDE_EMACS_INT - if (val > LONG_MAX || val < LONG_MIN) + if (val > ULONG_MAX) return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, From 0c5ba41b72a19f5353083431a1817d86bc3b7fad Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 2 Mar 2021 17:23:12 +0100 Subject: [PATCH 1353/1452] Fix two compiler ICEs dealing with nan and infinity * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): Don't crash when truncate fails. * test/src/comp-test-funcs.el (comp-test-=-nan): Add two functions to be compiled. --- lisp/emacs-lisp/comp-cstr.el | 9 ++++++--- test/src/comp-test-funcs.el | 8 ++++++++ 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 996502b2869..6a8ec5213d5 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -871,9 +871,12 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;; precisely as an integer add the integer as well. (cl-loop for v in (valset cstr) - when (and (floatp v) - (= v (truncate v))) - do (push (cons (truncate v) (truncate v)) (range cstr))) + do + (when-let* ((ok (floatp v)) + (truncated (ignore-error 'overflow-error + (truncate v))) + (ok (= v truncated))) + (push (cons truncated truncated) (range cstr)))) (cl-loop with vals-to-add for (l . h) in (range cstr) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5bae743d153..a465026fb37 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -667,6 +667,14 @@ (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 From cf37850e2d69eda908495950acf8decb0ecec517 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 3 Mar 2021 20:25:14 +0100 Subject: [PATCH 1354/1452] * src/comp.c (return_nil): Make it not a nested function. --- src/comp.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index d74f8328fda..bcffd426d95 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4506,6 +4506,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) static Lisp_Object all_loaded_comp_units_h; +#ifdef WINDOWSNT +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} +#endif + /* Windows does not let us delete a .eln file that is currently loaded by a process. The strategy is to rename .eln files into .old.eln instead of removing them when this is not possible and clean-up @@ -4517,8 +4525,6 @@ void eln_load_path_final_clean_up (void) { #ifdef WINDOWSNT - Lisp_Object return_nil (Lisp_Object arg) { return Qnil; } - Lisp_Object dir_tail = Vcomp_eln_load_path; FOR_EACH_TAIL (dir_tail) { From 43b40bc880f66cb3f48318ba3a480a76b149b815 Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Sun, 28 Feb 2021 06:31:00 +0000 Subject: [PATCH 1355/1452] Don't call _setjmp through a function pointer (Bug#46824) * src/comp.c (helper_link_table): Don't include SETJMP except on Windows. (emit_setjmp): Don't use function pointers except on Windows. (declare_runtime_imported_funcs): Don't import SETJMP at runtime. (ABI_VERSION): Bump. * test/src/comp-tests.el (46824-1): New test. * test/src/comp-test-funcs.el (comp-test-46824-1-f): New function. --- src/comp.c | 24 +++++++++++++++++------- test/src/comp-test-funcs.el | 18 +++++++++++++++++- test/src/comp-tests.el | 6 +++++- 3 files changed, 39 insertions(+), 9 deletions(-) diff --git a/src/comp.c b/src/comp.c index bcffd426d95..bc458595331 100644 --- a/src/comp.c +++ b/src/comp.c @@ -422,7 +422,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "1" +#define ABI_VERSION "2" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -646,7 +646,9 @@ void *helper_link_table[] = helper_PSEUDOVECTOR_TYPEP_XUNTAG, pure_write_error, push_handler, +#ifdef WINDOWSNT SETJMP_NAME, +#endif record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, @@ -1935,8 +1937,19 @@ emit_setjmp (gcc_jit_rvalue *buf) { #ifndef WINDOWSNT gcc_jit_rvalue *args[] = {buf}; - return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, - false); + gcc_jit_param *params[] = + { + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"), + }; + /* Don't call setjmp through a function pointer (Bug#46824) */ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.int_type, STR (SETJMP_NAME), + ARRAYELTS (params), params, + false); + + return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args); #else /* _setjmp (buf, __builtin_frame_address (0)) */ gcc_jit_rvalue *args[2]; @@ -2668,10 +2681,7 @@ declare_runtime_imported_funcs (void) args[1] = comp.int_type; ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); -#ifndef WINDOWSNT - args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); - ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); -#else +#ifdef WINDOWSNT args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); args[1] = comp.void_ptr_type; ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index a465026fb37..08aa6bb472e 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -1,6 +1,6 @@ ;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo @@ -485,6 +485,22 @@ (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)))) ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 3f007d2a592..dae2abca7e7 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1,6 +1,6 @@ ;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo @@ -503,6 +503,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) '(function (t) (or null sequence))))) +(comp-deftest 46824-1 () + "" + (should (equal (comp-test-46824-1-f) nil))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From 6444f69de277454491367b74434ac6d9fd122f50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 4 Mar 2021 09:03:26 +0100 Subject: [PATCH 1356/1452] * src/comp.c (hash_native_abi): Account for `system-configuraton-options'. --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index bc458595331..1e50b4fe8f7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -724,7 +724,8 @@ hash_native_abi (void) Vcomp_abi_hash = comp_hash_string ( concat3 (build_string (ABI_VERSION), - concat2 (Vemacs_version, Vsystem_configuration), + concat3 (Vemacs_version, Vsystem_configuration, + Vsystem_configuration_options), Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string ("")))); Vcomp_native_version_dir = From b456b19ec4e517cca53e4c6865059443300ae820 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 4 Mar 2021 20:36:43 +0200 Subject: [PATCH 1357/1452] Fix typos and doc strings in native-compilation files * lisp/emacs-lisp/comp.el (comp-speed, comp-debug, comp-verbose) (comp-always-compile, comp-deferred-compilation-deny-list) (comp-bootstrap-deny-list, comp-never-optimize-functions) (comp-async-jobs-number, comp-async-cu-done-hook) (comp-async-all-done-hook, comp-async-env-modifier-form) (comp-pass, comp-native-compiling, comp-post-pass-hooks) (comp-known-predicate-p, comp-pred-to-cstr) (comp-symbol-values-optimizable, comp-limple-assignments) (comp-limple-calls, comp-limple-branches, comp-block) (comp-vec--verify-idx, comp-vec-aref, comp-vec-append) (comp-vec-prepend, comp-block-preds) (comp-ensure-native-compiler, comp-log, comp-log-func) (comp-loop-insn-in-block, comp-byte-frame-size) (comp-add-func-to-ctxt, comp-spill-lap-function, comp-spill-lap) (comp-lap-fall-through-p, comp-new-frame, comp-emit-set-call) (comp-copy-slot, comp-latch-make-fill, comp-emit-cond-jump) (comp-body-eff, comp-op-case, comp-prepare-args-for-top-level) (comp-limplify-top-level, comp-negate-arithm-cmp-fun) (comp-emit-assume, comp-cond-cstrs-target-mvar) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-form-tco-call-seq, comp-clean-up-stale-eln) (comp-delete-or-replace-file, comp--native-compile) (native--compile-async, native-compile) (batch-byte-native-compile-for-bootstrap): Fix typos, wording, and punctuation in doc strings. * lisp/loadup.el: Fix typos. * src/lread.c (syms_of_lread): Doc fix. --- lisp/emacs-lisp/comp.el | 207 ++++++++++++++++++++-------------------- lisp/loadup.el | 13 +-- src/lread.c | 3 +- 3 files changed, 112 insertions(+), 111 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index af14afd42bb..4a418c1aade 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -45,56 +45,57 @@ :group 'lisp) (defcustom comp-speed 2 - "Compiler optimization level. From -1 to 3. -- -1 functions are kept in bytecode form and no native compilation is performed. -- 0 native compilation is performed with no optimizations. -- 1 lite optimizations. -- 2 max optimization level fully adherent to the language semantic. -- 3 max optimization level, to be used only when necessary. - Warning: the compiler is free to perform dangerous optimizations." + "Optimization level for native compilation, a number between -1 and 3. + -1 functions are kept in bytecode form and no native compilation is performed. + 0 native compilation is performed with no optimizations. + 1 light optimizations. + 2 max optimization level fully adherent to the language semantic. + 3 max optimization level, to be used only when necessary. + Warning: with 3, the compiler is free to perform dangerous optimizations." :type 'integer :safe #'integerp :version "28.1") (defcustom comp-debug 0 - "Compiler debug level. From 0 to 3. -This intended for debugging the compiler itself. -- 0 no debug facility. + "Debug level for native compilation, a number between 0 and 3. +This is intended for debugging the compiler itself. + 0 no debugging output. This is the recommended value unless you are debugging the compiler itself. -- 1 emit debug symbols and dump pseudo C code. -- 2 dump gcc passes and libgccjit log file. -- 3 dump libgccjit reproducers." + 1 emit debug symbols and dump pseudo C code. + 2 dump gcc passes and libgccjit log file. + 3 dump libgccjit reproducers." :type 'integer :safe #'natnump :version "28.1") (defcustom comp-verbose 0 - "Compiler verbosity. From 0 to 3. -This intended for debugging the compiler itself. -- 0 no logging. -- 1 final limple is logged. -- 2 LAP and final limple and some pass info are logged. -- 3 max verbosity." + "Compiler verbosity for native compilation, a number between 0 and 3. +This is intended for debugging the compiler itself. + 0 no logging. + 1 final LIMPLE is logged. + 2 LAP, final LIMPLE, and some pass info are logged. + 3 max verbosity." :type 'integer :risky t :version "28.1") (defcustom comp-always-compile nil - "Unconditionally (re-)compile all files." + "Non-nil means unconditionally (re-)compile all files." :type 'boolean :version "28.1") (defcustom comp-deferred-compilation-deny-list '() - "List of regexps to exclude files from deferred native compilation. -Skip if any is matching." + "List of regexps to exclude matching files from deferred native compilation. +Files whose names match any regexp is excluded from native compilation." :type 'list :version "28.1") (defcustom comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. -Skip if any is matching." +Files whose names match any regexp is excluded from native compilation +during bootstrap." :type 'list :version "28.1") @@ -103,13 +104,14 @@ Skip if any is matching." ;; correctly (see comment in `advice--add-function'). DO NOT ;; REMOVE. macroexpand rename-buffer) - "Primitive functions for which we do not perform trampoline optimization." + "Primitive functions to exclude from trampoline optimization." :type 'list :version "28.1") (defcustom comp-async-jobs-number 0 - "Default number of processes used for async compilation. -When zero use half of the CPUs or at least one." + "Default number of subprocesses used for async native compilation. +Value of zero means to use half the number of the CPU's execution units, +or one if there's just one execution unit." :type 'integer :risky t :version "28.1") @@ -118,19 +120,18 @@ When zero use half of the CPUs or at least one." ;; like `comp-async-cu-done-function'. (defcustom comp-async-cu-done-hook nil "Hook run after asynchronously compiling a single compilation unit. -The argument FILE passed to the function is the filename used as -compilation input." +Called with one argument FILE, the filename used as input to compilation." :type 'hook :version "28.1") (defcustom comp-async-all-done-hook nil - "Hook run after asynchronously compiling all input files." + "Hook run after completing asynchronous compilation of all input files." :type 'hook :version "28.1") (defcustom comp-async-env-modifier-form nil - "Form evaluated before compilation by each asynchronous compilation worker. -Usable to modify the compiler environment." + "Form evaluated before compilation by each asynchronous compilation subprocess. +Used to modify the compiler environment." :type 'list :risky t :version "28.1") @@ -195,11 +196,12 @@ the .eln output directory." "Name of the async compilation buffer log.") (defvar comp-native-compiling nil - "This gets bound to t while native compilation. -Can be used by code that wants to expand differently in this case.") + "This gets bound to t during native compilation. +Intended to be used by code that needs to work differently when +native compilation runs.") (defvar comp-pass nil - "Every pass has the right to bind what it likes here.") + "Every native-compilation pass can bind this to whatever it likes.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. @@ -223,7 +225,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") For internal use only by the testsuite.") (defvar comp-post-pass-hooks '() - "Alist PASS FUNCTIONS. + "Alist whose elements are of the form (PASS FUNCTIONS...). Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") @@ -583,16 +585,16 @@ Useful to hook into pass checkers.") "Hash table function -> `comp-constraint'") (defun comp-known-predicate-p (predicate) - "Predicate matching if PREDICATE is known." + "Return t if PREDICATE is known." (when (gethash predicate comp-known-predicates-h) t)) (defun comp-pred-to-cstr (predicate) - "Given PREDICATE return the correspondig constraint." + "Given PREDICATE, return the correspondig constraint." (gethash predicate comp-known-predicates-h)) (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) - "Symbol values we can resolve in the compile-time.") + "Symbol values we can resolve at compile-time.") (defconst comp-type-hints '(comp-hint-fixnum comp-hint-cons) @@ -608,16 +610,16 @@ Useful to hook into pass checkers.") (defconst comp-limple-assignments `(assume fetch-handler ,@comp-limple-sets) - "Limple operators that clobbers the first m-var argument.") + "Limple operators that clobber the first m-var argument.") (defconst comp-limple-calls '(call callref direct-call direct-callref) - "Limple operators use to call subrs.") + "Limple operators used to call subrs.") (defconst comp-limple-branches '(jump cond-jump) - "Limple operators use for conditional and unconditional branches.") + "Limple operators used for conditional and unconditional branches.") (defconst comp-limple-ops `(,@comp-limple-calls ,@comp-limple-assignments @@ -629,7 +631,7 @@ Useful to hook into pass checkers.") "Bound to the current function by most passes.") (defvar comp-block nil - "Bound to the current basic block by some pass.") + "Bound to the current basic block by some passes.") (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" @@ -657,12 +659,12 @@ Useful to hook into pass checkers.") (- (comp-vec-end vec) (comp-vec-beg vec))) (defsubst comp-vec--verify-idx (vec idx) - "Check idx is in bounds for VEC." + "Check whether idx is in bounds for VEC." (cl-assert (and (< idx (comp-vec-end vec)) (>= idx (comp-vec-beg vec))))) (defsubst comp-vec-aref (vec idx) - "Return the element of VEC at index IDX." + "Return the element of VEC whose index is IDX." (declare (gv-setter (lambda (val) `(comp-vec--verify-idx ,vec ,idx) `(puthash ,idx ,val (comp-vec-data ,vec))))) @@ -671,14 +673,14 @@ Useful to hook into pass checkers.") (defsubst comp-vec-append (vec elt) "Append ELT into VEC. -ELT is returned." +Returns ELT." (puthash (comp-vec-end vec) elt (comp-vec-data vec)) (cl-incf (comp-vec-end vec)) elt) (defsubst comp-vec-prepend (vec elt) "Prepend ELT into VEC. -ELT is returned." +Returns ELT." (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec)) (cl-decf (comp-vec-beg vec)) elt) @@ -818,7 +820,7 @@ non local exit (ends with an `unreachable' insn).")) (comp-func-edges-h comp-func)))) (defun comp-block-preds (basic-block) - "Given BASIC-BLOCK return the list of its predecessors." + "Return the list of predecessors of BASIC-BLOCK." (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) (defun comp-gen-counter () @@ -895,14 +897,14 @@ In use by the backend." (defun comp-ensure-native-compiler () - "Make sure Emacs has native compiler support and libgccjit is loadable. + "Make sure Emacs has native compiler support and libgccjit can be loaded. Signal an error otherwise. To be used by all entry points." (cond ((null (featurep 'nativecomp)) - (error "Emacs not compiled with native compiler support (--with-nativecomp)")) + (error "Emacs was not compiled with native compiler support (--with-native-compilation)")) ((null (native-comp-available-p)) - (error "Cannot find libgccjit")))) + (error "Cannot find libgccjit library")))) (defun comp-equality-fun-p (function) "Equality functions predicate for FUNCTION." @@ -997,9 +999,9 @@ Assume allocation class 'd-default as default." (cl-defun comp-log (data &optional (level 1) quoted) "Log DATA at LEVEL. -LEVEL is a number from 1-3; if it is less than `comp-verbose', do -nothing. If `noninteractive', log with `message'. Otherwise, -log with `comp-log-to-buffer'." +LEVEL is a number from 1-3, and defaults to 1; if it is less +than `comp-verbose', do nothing. If `noninteractive', log +with `message'. Otherwise, log with `comp-log-to-buffer'." (when (>= comp-verbose level) (if noninteractive (cl-typecase data @@ -1050,7 +1052,7 @@ log with `comp-log-to-buffer'." (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")))) (defun comp-log-func (func verbosity) - "Log function FUNC. + "Log function FUNC at VERBOSITY. VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) @@ -1080,7 +1082,7 @@ VERBOSITY is a number between 0 and 3." (defmacro comp-loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executing BODY. -Inside BODY `insn' and `insn-cell'can be used to read or set the +Inside BODY, `insn' and `insn-cell'can be used to read or set the current instruction or its cell." (declare (debug (form body)) (indent defun)) @@ -1157,11 +1159,11 @@ clashes." :rest rest)))) (defsubst comp-byte-frame-size (byte-compiled-func) - "Given BYTE-COMPILED-FUNC return the frame size to be allocated." + "Return the frame size to be allocated for BYTE-COMPILED-FUNC." (aref byte-compiled-func 3)) (defun comp-add-func-to-ctxt (func) - "Add FUNC to the current compiler contex." + "Add FUNC to the current compiler context." (let ((name (comp-func-name func)) (c-name (comp-func-c-name func))) (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) @@ -1171,7 +1173,7 @@ clashes." "Byte-compile INPUT and spill lap for further stages.") (cl-defmethod comp-spill-lap-function ((function-name symbol)) - "Byte-compile FUNCTION-NAME spilling data from the byte compiler." + "Byte-compile FUNCTION-NAME, spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file (comp-c-func-name function-name "freefn-") @@ -1208,10 +1210,10 @@ clashes." (comp-add-func-to-ctxt func)))) (cl-defmethod comp-spill-lap-function ((form list)) - "Byte-compile FORM spilling data from the byte compiler." + "Byte-compile FORM, spilling data from the byte compiler." (unless (eq (car-safe form) 'lambda) (signal 'native-compiler-error - "Cannot native compile, form is not a lambda")) + "Cannot native-compile, form is not a lambda")) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) @@ -1283,7 +1285,7 @@ clashes." (comp-log lap 1 t)))) (cl-defmethod comp-spill-lap-function ((filename string)) - "Byte-compile FILENAME spilling data from the byte compiler." + "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) @@ -1316,8 +1318,8 @@ clashes." (defun comp-spill-lap (input) "Byte-compile and spill the LAP representation for INPUT. -If INPUT is a symbol this is the function-name to be compiled. -If INPUT is a string this is the filename to be compiled." +If INPUT is a symbol, it is the function-name to be compiled. +If INPUT is a string, it is the filename to be compiled." (let ((byte-native-compiling t) (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ()) @@ -1355,7 +1357,7 @@ Points to the next slot to be filled.") t)) (defun comp-lap-fall-through-p (inst) - "Return t if INST fall through, nil otherwise." + "Return t if INST falls through, nil otherwise." (when (not (memq (car inst) '(byte-goto byte-return))) t)) @@ -1442,7 +1444,7 @@ STACK-OFF is the index of the first slot frame involved." (defun comp-new-frame (size vsize &optional ssa) "Return a clean frame of meta variables of size SIZE and VSIZE. -If SSA non-nil populate it of m-var in ssa form." +If SSA is non-nil, populate it with m-var in ssa form." (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) for i from (- vsize) below size for mvar = (if ssa @@ -1459,13 +1461,13 @@ If SSA non-nil populate it of m-var in ssa form." (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. -If the callee function is known to have a return type propagate it." +If the callee function is known to have a return type, propagate it." (cl-assert call) (comp-emit (list 'set (comp-slot) call))) (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. -If DST-N is specified use it otherwise assume it to be the current slot." +If DST-N is specified, use it; otherwise assume it to be the current slot." (comp-with-sp (or dst-n (comp-sp)) (let ((src-slot (comp-slot-n src-n))) (cl-assert src-slot) @@ -1496,7 +1498,7 @@ Add block to the current function and return it." (defun comp-latch-make-fill (target) "Create a latch pointing to TARGET and fill it. -Return the created latch" +Return the created latch." (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) (curr-bb (comp-limplify-curr-block comp-pass))) ;; See `comp-make-curr-block'. @@ -1530,8 +1532,8 @@ Return the created latch" "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non null negate the tested condition. -Return value is the fall through block name." +If NEGATED is non null, negate the tested condition. +Return value is the fall-through block name." (cl-destructuring-bind (label-num . label-sp) lap-label (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) @@ -1682,8 +1684,8 @@ SP-DELTA is the stack adjustment." (intern (replace-regexp-in-string "byte-" "" x))) (defun comp-body-eff (body op-name sp-delta) - "Given the original body BODY compute the effective one. -When BODY is auto guess function name form the LAP byte-code + "Given the original BODY, compute the effective one. +When BODY is `auto', guess function name from the LAP byte-code name. Otherwise expect lname fnname." (pcase (car body) ('auto @@ -1694,8 +1696,8 @@ name. Otherwise expect lname fnname." (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding `pcase' expansion. -This is responsible for generating the proper stack adjustment when known and -the annotation emission." +This is responsible for generating the proper stack adjustment, when known, +and the annotation emission." (declare (debug (body)) (indent defun)) `(pcase op @@ -1963,7 +1965,7 @@ the annotation emission." func) (cl-defgeneric comp-prepare-args-for-top-level (function) - "Given FUNCTION, return the two args arguments for comp--register-...") + "Given FUNCTION, return the two arguments for comp--register-...") (cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) "Lexically-scoped FUNCTION." @@ -1974,7 +1976,7 @@ the annotation emission." 'many))))) (cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) - "Dynamic scoped FUNCTION." + "Dynamically scoped FUNCTION." (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) (let ((comp-curr-allocation-class 'd-default)) ;; Lambda-lists must stay in the same relocation class of @@ -2060,15 +2062,15 @@ These are stored in the reloc data array." (defun comp-limplify-top-level (for-late-load) "Create a limple function to modify the global environment at load. -When FOR-LATE-LOAD is non-nil the emitted function modifies only +When FOR-LATE-LOAD is non-nil, the emitted function modifies only function definition. -Synthesize a function called 'top_level_run' that gets one single -parameter (the compilation unit it-self). To define native -functions 'top_level_run' will call back `comp--register-subr' +Synthesize a function called `top_level_run' that gets one single +parameter (the compilation unit itself). To define native +functions, `top_level_run' will call back `comp--register-subr' into the C code forwarding the compilation unit." ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no - ;; reasons to be execute ever again. Therefore all objects can be + ;; reasons to be executed ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) (func (make-comp-func-l :name (if for-late-load @@ -2240,8 +2242,7 @@ into the C code forwarding the compilation unit." (defun comp-negate-arithm-cmp-fun (function) "Negate FUNCTION. -Return nil if we don't want to emit constraints for its -negation." +Return nil if we don't want to emit constraints for its negation." (cl-ecase function (= nil) (> '<=) @@ -2261,7 +2262,7 @@ negation." (defun comp-emit-assume (kind lhs rhs bb negated) "Emit an assume of kind KIND for mvar LHS being RHS. -When NEGATED is non-nil the assumption is negated. +When NEGATED is non-nil, the assumption is negated. The assume is emitted at the beginning of the block BB." (let ((lhs-slot (comp-mvar-slot lhs))) (cl-assert lhs-slot) @@ -2335,7 +2336,7 @@ Return OP otherwise." ;; Cheap substitute to a copy propagation pass... (defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB the original mvar MVAR got assigned from. + "Given MVAR, search in BB the original mvar MVAR got assigned from. Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. @@ -3029,12 +3030,12 @@ Forward propagate immediate involed in assignments." (comp-mvar-neg lval) (comp-mvar-neg rval))) (defun comp-function-foldable-p (f args) - "Given function F called with ARGS return non-nil when optimizable." + "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) - "Given INSN when F is pure if all ARGS are known remove the function call. + "Given INSN, when F is pure if all ARGS are known, remove the function call. Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. @@ -3372,7 +3373,7 @@ Return the list of m-var ids nuked." ;;; Tail Call Optimization pass specific code. (defun comp-form-tco-call-seq (args) - "Generate a tco sequence for ARGS." + "Generate a TCO sequence for ARGS." `(,@(cl-loop for arg in args for i from 0 collect `(set ,(make-comp-mvar :slot i) ,arg)) @@ -3747,7 +3748,7 @@ Return the trampoline if found or nil otherwise." ;;;###autoload (defun comp-clean-up-stale-eln (file) - "Given FILE remove all the .eln files in `comp-eln-load-path' + "Given FILE remove all its *.eln files in `comp-eln-load-path' sharing the original source filename (including FILE)." (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) file) @@ -3765,7 +3766,7 @@ sharing the original source filename (including FILE)." "Replace OLDFILE with NEWFILE. When NEWFILE is nil just delete OLDFILE. Takes the necessary steps when dealing with OLDFILE being a -shared libraries that may be currently loaded by a running Emacs +shared library that might be currently loaded into a running Emacs session." (cond ((eq 'windows-nt system-type) (ignore-errors (delete-file oldfile)) @@ -3929,8 +3930,8 @@ display a message." (defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. This serves as internal implementation of `native-compile'. -When WITH-LATE-LOAD non-nil mark the compilation unit for late -load once finished compiling." +When WITH-LATE-LOAD is non-nil, mark the compilation unit for late +load once it finishes compiling." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -3975,7 +3976,7 @@ load once finished compiling." (native-elisp-load data)))) (defun native-compile-async-skip-p (file load selector) - "Return non-nil when FILE compilation should be skipped. + "Return non-nil if FILE's compilation should be skipped. LOAD and SELECTOR work as described in `native--compile-async'." ;; Make sure we are not already compiling `file' (bug#40838). @@ -4014,13 +4015,13 @@ of (commands) to run simultaneously. LOAD can also be the symbol `late'. This is used internally if the byte code has already been loaded when this function is -called. It means that we requests the special kind of load, +called. It means that we request the special kind of load necessary in that situation, called \"late\" loading. -During a \"late\" load instead of executing all top level forms +During a \"late\" load, instead of executing all top-level forms of the original files, only function definitions are loaded (paying attention to have these effective only if the -bytecode definition was not changed in the meanwhile)." +bytecode definition was not changed in the meantime)." (comp-ensure-native-compiler) (unless (member load '(nil t late)) (error "LOAD must be nil, t or 'late")) @@ -4068,13 +4069,13 @@ bytecode definition was not changed in the meanwhile)." "Compile FUNCTION-OR-FILE into native code. This is the synchronous entry-point for the Emacs Lisp native compiler. -FUNCTION-OR-FILE is a function symbol, a form or the filename of +FUNCTION-OR-FILE is a function symbol, a form, or the filename of an Emacs Lisp source file. -When OUTPUT is non-nil use it as filename for the compiled +If OUTPUT is non-nil, use it as the filename for the compiled object. -If FUNCTION-OR-FILE is a filename return the filename of the +If FUNCTION-OR-FILE is a filename, return the filename of the compiled object. If FUNCTION-OR-FILE is a function symbol or a -form return the compiled function." +form, return the compiled function." (comp--native-compile function-or-file nil output)) ;;;###autoload @@ -4092,9 +4093,9 @@ Ultra cheap impersonation of `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () - "As `batch-byte-compile' but used for booststrap. -Generate .elc files in addition to the .eln one. If the -environment variable 'NATIVE_DISABLED' is set byte compile only." + "Like `batch-native-compile', but used for booststrap. +Generate *.elc files in addition to the *.eln files. If the +environment variable 'NATIVE_DISABLED' is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) diff --git a/lisp/loadup.el b/lisp/loadup.el index 526f7c33281..98d4e4fe673 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -450,8 +450,9 @@ lost after dumping"))) (when (featurep 'nativecomp) ;; Fix the compilation unit filename to have it working when - ;; when installed or if the source directory got moved. This is set to be - ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). + ;; installed or if the source directory got moved. This is set to be + ;; a cons cell of the form: + ;; (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)))) @@ -466,12 +467,12 @@ lost after dumping"))) (native-comp-unit-set-file cu (cons - ;; Relative path from the installed binary. + ;; Relative filename from the installed binary. (file-relative-name (concat eln-dest-dir (file-name-nondirectory (native-comp-unit-file cu))) bin-dest-dir) - ;; Relative path from the built uninstalled binary. + ;; Relative filename from the built uninstalled binary. (file-relative-name (native-comp-unit-file cu) invocation-directory)))) h)))) @@ -536,8 +537,8 @@ lost after dumping"))) (t (error "unrecognized dump mode %s" dump-mode))))) (when (and (featurep 'nativecomp) (equal dump-mode "pdump")) - ;; Don't enable this before bootstrap is completed the as the - ;; compiler infrastructure may not be usable. + ;; 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 () diff --git a/src/lread.c b/src/lread.c index d947c4e519a..989b55c88f9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -5200,8 +5200,7 @@ that are loaded before your customizations are read! */); load_prefer_newer = 0; DEFVAR_BOOL ("load-no-native", load_no_native, - doc: /* Do not try to load the a .eln file in place of - a .elc one. */); + 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. */ From b9ccbac7685620d4624f55b9de361c610ede8aa4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 4 Mar 2021 21:43:59 +0100 Subject: [PATCH 1358/1452] * Makefile.in (ELN_DESTDIR): Remove unnecessary double quoting. --- Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.in b/Makefile.in index e3bbbec92a9..691a955c540 100644 --- a/Makefile.in +++ b/Makefile.in @@ -336,7 +336,7 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" -ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/${version}/" +ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ all: ${SUBDIR} info From 260617ddc2e8e46a741e6843f97c7ffbc5222ed0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 5 Mar 2021 10:45:09 +0100 Subject: [PATCH 1359/1452] * Harden `comp-abi-hash' computation Account for subr arity in `comp-abi-hash' computation as that's part of the ABI exposed to .eln files. * src/comp.c (Fcomp__subr_signature): New support function. (hash_native_abi): Make use of. (syms_of_comp): Register 'Scomp__subr_signature'. --- src/comp.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 1e50b4fe8f7..17dc4cbc132 100644 --- a/src/comp.c +++ b/src/comp.c @@ -713,6 +713,16 @@ comp_hash_source_file (Lisp_Object filename) return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); } +DEFUN ("comp--subr-signature", Fcomp__subr_signature, + Scomp__subr_signature, 1, 1, 0, + doc: /* Support function to 'hash_native_abi'. +For internal use. */) + (Lisp_Object subr) +{ + return concat2 (Fsubr_name (subr), + Fprin1_to_string (Fsubr_arity (subr), Qnil)); +} + /* Produce a key hashing Vcomp_subr_list. */ void @@ -726,7 +736,7 @@ hash_native_abi (void) concat3 (build_string (ABI_VERSION), concat3 (Vemacs_version, Vsystem_configuration, Vsystem_configuration_options), - Fmapconcat (intern_c_string ("subr-name"), + Fmapconcat (intern_c_string ("comp--subr-signature"), Vcomp_subr_list, build_string ("")))); Vcomp_native_version_dir = concat3 (Vemacs_version, build_string ("-"), Vcomp_abi_hash); @@ -5199,6 +5209,7 @@ compiled one. */); build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + defsubr (&Scomp__subr_signature); defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp_native_driver_options_effective_p); defsubr (&Scomp__install_trampoline); From 552ef6d6c0733b864bcb14eeb6183d7e64df3b80 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 5 Mar 2021 16:39:10 +0200 Subject: [PATCH 1360/1452] Fix some unsafe uses of SSDATA in comp.c * src/comp.c (comp_hash_source_file) (Fcomp__compile_ctxt_to_file, Fnative_elisp_load): Encode file names before passing them to library APIs. (Fcomp__compile_ctxt_to_file): use emacs_fopen instead of fopen. (declare_lex_function): Avoid keeping a 'char *' pointer around while calling Lisp, which could trigger GC, which could relocate string data. --- src/comp.c | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 17dc4cbc132..94d3fa99a33 100644 --- a/src/comp.c +++ b/src/comp.c @@ -36,6 +36,7 @@ along with GNU Emacs. If not, see . */ #include "dynlib.h" #include "buffer.h" #include "blockinput.h" +#include "coding.h" #include "md5.h" #include "sysstdio.h" #include "zlib.h" @@ -693,7 +694,8 @@ comp_hash_source_file (Lisp_Object filename) /* Can't use Finsert_file_contents + Fbuffer_hash as this is called by Fcomp_el_to_eln_filename too early during bootstrap. */ bool is_gz = suffix_p (filename, ".gz"); - FILE *f = emacs_fopen (SSDATA (filename), is_gz ? "rb" : "r"); + Lisp_Object encoded_filename = ENCODE_FILE (filename); + FILE *f = emacs_fopen (SSDATA (encoded_filename), is_gz ? "rb" : "r"); if (!f) report_file_error ("Opening source file", filename); @@ -3792,7 +3794,7 @@ static gcc_jit_function * declare_lex_function (Lisp_Object func) { gcc_jit_function *res; - char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); + Lisp_Object c_name = CALL1I (comp-func-c-name, func); Lisp_Object args = CALL1I (comp-func-l-args, func); bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -3814,7 +3816,7 @@ declare_lex_function (Lisp_Object func) res = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, + SSDATA (c_name), max_args, params, 0); @@ -3835,7 +3837,8 @@ declare_lex_function (Lisp_Object func) NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, ARRAYELTS (params), params, 0); + SSDATA (c_name), + ARRAYELTS (params), params, 0); } SAFE_FREE (); return res; @@ -4332,6 +4335,10 @@ add_driver_options (void) if (!NILP (Fcomp_native_driver_options_effective_p ())) FOR_EACH_TAIL (options) gcc_jit_context_add_driver_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ SSDATA (XCAR (options))); return; #endif @@ -4353,6 +4360,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CHECK_STRING (filename); Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + Lisp_Object ebase_name = ENCODE_FILE (base_name); comp.func_relocs_local = NULL; @@ -4367,7 +4375,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, 1); if (comp.debug > 2) { - logfile = fopen ("libgccjit.log", "w"); + logfile = emacs_fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, logfile, 0, 0); @@ -4428,18 +4436,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (comp.debug) gcc_jit_context_dump_to_file (comp.ctxt, - format_string ("%s.c", SSDATA (base_name)), + format_string ("%s.c", SSDATA (ebase_name)), 1); if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) gcc_jit_context_dump_reproducer_to_file ( comp.ctxt, - format_string ("%s_libgccjit_repro.c", SSDATA (base_name))); + format_string ("%s_libgccjit_repro.c", SSDATA (ebase_name))); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - SSDATA (tmp_file)); + SSDATA (ENCODE_FILE (tmp_file))); const char *err = gcc_jit_context_get_first_error (comp.ctxt); if (err) @@ -5043,28 +5051,29 @@ LATE_LOAD has to be non-nil when loading for deferred compilation. */) xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), filename); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); + Lisp_Object encoded_filename = ENCODE_FILE (filename); if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil)) && !file_in_eln_sys_dir (filename) && !NILP (Ffile_writable_p (filename))) { /* If in this session there was ever a file loaded with this - name rename before loading it to make sure we always get a + name, rename it before loading, to make sure we always get a new handle! */ Lisp_Object tmp_filename = Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"), Qnil); if (NILP (Ffile_writable_p (tmp_filename))) - comp_u->handle = dynlib_open (SSDATA (filename)); + comp_u->handle = dynlib_open (SSDATA (encoded_filename)); else { Frename_file (filename, tmp_filename, Qt); - comp_u->handle = dynlib_open (SSDATA (tmp_filename)); + comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (tmp_filename))); Frename_file (tmp_filename, filename, Qnil); } } else - comp_u->handle = dynlib_open (SSDATA (filename)); + comp_u->handle = dynlib_open (SSDATA (encoded_filename)); if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, filename, From 05259c4a238efa40fa66ac51844aa5227b9c576b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Mar 2021 20:38:00 +0100 Subject: [PATCH 1361/1452] Fix `=' propagation to handle -0.0 0.0 case * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-homogeneous): Fix indent + use `memql'. (comp-cstr-=): Handle 0.0 -0.0 idiosyncrasy * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests and fix enumeration. --- lisp/emacs-lisp/comp-cstr.el | 8 ++++++-- test/src/comp-tests.el | 32 ++++++++++++++++++++++++-------- 2 files changed, 30 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6a8ec5213d5..d6423efa0d6 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -664,7 +664,7 @@ DST is returned." (cl-return-from comp-cstr-intersection-homogeneous dst)) (setf (neg dst) (when srcs - (neg (car srcs)))) + (neg (car srcs)))) ;; Type propagation. (setf (typeset dst) @@ -682,7 +682,7 @@ DST is returned." ;; If (member value) is subtypep of all other sources then ;; is good to be colleted. when (cl-every (lambda (s) - (or (memq val (valset s)) + (or (memql val (valset s)) (cl-some (lambda (type) (cl-typep val type)) (typeset s)))) @@ -890,6 +890,10 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-return cstr) finally (setf (valset cstr) (append vals-to-add (valset cstr)))) + (when (memql 0.0 (valset cstr)) + (cl-pushnew -0.0 (valset cstr))) + (when (memql -0.0 (valset cstr)) + (cl-pushnew 0.0 (valset cstr))) cstr)) (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2))))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dae2abca7e7..cd1c2e0735e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1299,32 +1299,48 @@ Return a list of results." (error ""))) cons) - ;; 69 + ;; 68 ((defun comp-tests-ret-type-spec-f (x) (if (and (floatp x) - (= x 0)) + (= x 1)) x (error ""))) ;; Conservative (see cstr relax in `comp-cstr-='). - (or (member 0.0) (integer 0 0))) + (or (member 1.0) (integer 1 1))) - ;; 70 + ;; 69 ((defun comp-tests-ret-type-spec-f (x) (if (and (integer x) - (= x 0)) + (= x 1)) x (error ""))) ;; Conservative (see cstr relax in `comp-cstr-='). - (or (member 0.0) (integer 0 0))) + (or (member 1.0) (integer 1 1))) - ;; 71 + ;; 70 ((defun comp-tests-ret-type-spec-f (x y) (if (and (floatp x) (integerp y) (= x y)) x (error ""))) - (or float integer)))) + (or float integer)) + + ;; 71 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 0.0) + x + (error ""))) + (or (member -0.0 0.0) (integer 0 0))) + + ;; 72 + ((defun comp-tests-ret-type-spec-f (x) + (unless (= x 0.0) + (error "")) + (unless (eql x -0.0) + (error "")) + x) + float))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 3848f3bff0d39e21ee016ea9c3fae4bf07fc0a57 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Mar 2021 20:51:11 +0100 Subject: [PATCH 1362/1452] * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs-simple): Suppress warning. --- lisp/emacs-lisp/comp.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4a418c1aade..8a6e761fe40 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2384,8 +2384,7 @@ TARGET-BB-SYM is the symbol name of the target block." for insn-seq on (comp-block-insns b) do (pcase insn-seq - (`((set ,(and (pred comp-mvar-p) tmp-mvar) - ,(and (pred comp-mvar-p) obj1)) + (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(pred comp-mvar-p)) ;; (comment ,_comment-str) (cond-jump ,tmp-mvar ,obj2 . ,blocks)) (cl-loop From 6c73418c95ae5aca7e63d8d5703a90e178350527 Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Sat, 6 Mar 2021 20:53:57 +0000 Subject: [PATCH 1363/1452] Fix miscompilation of funcall forms in some cases (bug#46974) * lisp/emacs-lisp/comp.el (comp-call-optim-func): Call comp-cstr-imm-vld-p before relying on comp-cstr-imm to return the right value. --- lisp/emacs-lisp/comp.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8a6e761fe40..134b5a28086 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3282,11 +3282,13 @@ FUNCTION can be a function-name or byte compiled function." do (comp-loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((new-form (comp-call-optim-form-call + (when-let ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp-call-optim-form-call (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) - (when-let ((new-form (comp-call-optim-form-call + (when-let ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp-call-optim-form-call (comp-cstr-imm f) rest))) (setf insn new-form))))))) From c60f2f458a63a8ae4288652228f24e43fdc7bba7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 6 Mar 2021 22:36:50 +0100 Subject: [PATCH 1364/1452] Fix `comp-cstr-intersection-no-hashcons' for negated result cstr * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-no-hashcons): When negated and necessary relax dst to t. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test. --- lisp/emacs-lisp/comp-cstr.el | 32 +++++++++++++++++++------------- test/src/comp-tests.el | 9 ++++++++- 2 files changed, 27 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d6423efa0d6..4397a914981 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -1001,20 +1001,26 @@ promoted to their types. DST is returned." (with-comp-cstr-accessors (apply #'comp-cstr-intersection dst srcs) - (let (strip-values strip-types) - (cl-loop for v in (valset dst) - unless (or (symbolp v) - (fixnump v)) - do (push v strip-values) - (push (type-of v) strip-types)) - (when strip-values - (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) - (valset dst) (cl-set-difference (valset dst) strip-values))) - (cl-loop for (l . h) in (range dst) - when (or (bignump l) (bignump h)) + (if (and (neg dst) + (valset dst) + (cl-notevery #'symbolp (valset dst))) + (setf (valset dst) () + (typeset dst) '(t) + (range dst) () + (neg dst) nil) + (let (strip-values strip-types) + (cl-loop for v in (valset dst) + unless (symbolp v) + do (push v strip-values) + (push (type-of v) strip-types)) + (when strip-values + (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) + (valset dst) (cl-set-difference (valset dst) strip-values))) + (cl-loop for (l . h) in (range dst) + when (or (bignump l) (bignump h)) do (setf (range dst) '((- . +))) - (cl-return)) - dst))) + (cl-return)))) + dst)) (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index cd1c2e0735e..f60e4ab0497 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1340,7 +1340,14 @@ Return a list of results." (unless (eql x -0.0) (error "")) x) - float))) + float) + + ;; 73 + ((defun comp-tests-ret-type-spec-f (x) + (when (eql x 1.0) + (error "")) + x) + t))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () From 7a13a0d616cde9f0f2a6fe217144e9891e769b61 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 7 Mar 2021 12:49:05 +0200 Subject: [PATCH 1365/1452] Fix libgccjit PROGNAME on MS-Windows * src/comp.c [WINDOWSNT]: Import gcc_jit_context_set_str_option. (init_gccjit_functions): Load gcc_jit_context_set_str_option. (gcc_jit_context_set_str_option) [WINDOWSNT]: New macro. (Fcomp__compile_ctxt_to_file) [WINDOWSNT]: Pass the actual name of the libgccjit DLL to the library, to be used as PROGNAME. --- src/comp.c | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/comp.c b/src/comp.c index 94d3fa99a33..d9ad623ec79 100644 --- a/src/comp.c +++ b/src/comp.c @@ -89,6 +89,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_context_set_bool_option #undef gcc_jit_context_set_int_option #undef gcc_jit_context_set_logfile +#undef gcc_jit_context_set_str_option #undef gcc_jit_function_get_param #undef gcc_jit_function_new_block #undef gcc_jit_function_new_local @@ -248,6 +249,9 @@ DEF_DLL_FN (void, gcc_jit_context_set_int_option, (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value)); DEF_DLL_FN (void, gcc_jit_context_set_logfile, (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity)); +DEF_DLL_FN (void, gcc_jit_context_set_str_option, + (gcc_jit_context *ctxt, enum gcc_jit_str_option opt, + const char *value)); DEF_DLL_FN (void, gcc_jit_struct_set_fields, (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, gcc_jit_field **fields)); @@ -304,6 +308,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_context_set_bool_option); LOAD_DLL_FN (library, gcc_jit_context_set_int_option); LOAD_DLL_FN (library, gcc_jit_context_set_logfile); + LOAD_DLL_FN (library, gcc_jit_context_set_str_option); LOAD_DLL_FN (library, gcc_jit_function_get_param); LOAD_DLL_FN (library, gcc_jit_function_new_block); LOAD_DLL_FN (library, gcc_jit_function_new_local); @@ -373,6 +378,7 @@ init_gccjit_functions (void) #define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option #define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option #define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile +#define gcc_jit_context_set_str_option fn_gcc_jit_context_set_str_option #define gcc_jit_function_get_param fn_gcc_jit_function_get_param #define gcc_jit_function_new_block fn_gcc_jit_function_new_block #define gcc_jit_function_new_local fn_gcc_jit_function_new_local @@ -4364,6 +4370,30 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.func_relocs_local = NULL; +#ifdef WINDOWSNT + /* Tell libgccjit the actual file name of the loaded DLL, otherwise + it will use 'libgccjit.so', which is not useful. */ + Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from); + Lisp_Object libgccjit_fname; + + if (CONSP (libgccjit_loaded_from)) + { + /* Use the absolute file name if available, otherwise the name + we looked for in w32_delayed_load. */ + libgccjit_fname = XCDR (libgccjit_loaded_from); + if (NILP (libgccjit_fname)) + libgccjit_fname = XCAR (libgccjit_loaded_from); + /* Must encode to ANSI, as libgccjit will not be able to handle + UTF-8 encoded file names. */ + libgccjit_fname = ansi_encode_filename (libgccjit_fname); + gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, + SSDATA (libgccjit_fname)); + } + else /* this should never happen */ + gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, + "libgccjit-0.dll"); +#endif + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); eassert (comp.speed < INT_MAX); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); From 99638d128ee07fa35525ac47217f68dd518e9175 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 7 Mar 2021 12:53:51 +0200 Subject: [PATCH 1366/1452] ; * src/comp.c (Fcomp__compile_ctxt_to_file) [WINDOWSNT]: Fix last change. --- src/comp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/comp.c b/src/comp.c index d9ad623ec79..7927448d5f0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4385,6 +4385,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, libgccjit_fname = XCAR (libgccjit_loaded_from); /* Must encode to ANSI, as libgccjit will not be able to handle UTF-8 encoded file names. */ + libgccjit_fname = ENCODE_FILE (libgccjit_fname); libgccjit_fname = ansi_encode_filename (libgccjit_fname); gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, SSDATA (libgccjit_fname)); From 619f66f423c76d94b2bca728f9c22b536e909108 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 7 Mar 2021 15:32:55 +0200 Subject: [PATCH 1367/1452] Use MS-Windows system APIs to get number of processors * lisp/emacs-lisp/comp.el: Use 'w32-get-nproc' instead of the environment variable NUMBER_OF_PROCESSORS. * src/w32proc.c (Fw32_get_nproc): New primitive. * src/w32.c (w32_get_nproc): New function. (sample_system_load): Call w32_get_nproc to initialize the number of processors on this system. * src/w32.h (w32_get_nproc): Add prototype. --- lisp/emacs-lisp/comp.el | 3 +-- src/w32.c | 14 +++++++++++--- src/w32.h | 3 +++ src/w32proc.c | 10 ++++++++++ 4 files changed, 25 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 134b5a28086..70e10644ca8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3824,8 +3824,7 @@ processes from `comp-async-compilations'" ;; the number of processors, see get_native_system_info in w32.c. ;; The result needs to be exported to Lisp. (max 1 (/ (cond ((eq 'windows-nt system-type) - (string-to-number (getenv - "NUMBER_OF_PROCESSORS"))) + (w32-get-nproc)) ((executable-find "nproc") (string-to-number (shell-command-to-string "nproc"))) diff --git a/src/w32.c b/src/w32.c index 96eba1e5681..7ce907d0adb 100644 --- a/src/w32.c +++ b/src/w32.c @@ -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 diff --git a/src/w32.h b/src/w32.h index 3f8eb250cc1..a382dbe791a 100644 --- a/src/w32.h +++ b/src/w32.h @@ -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); diff --git a/src/w32proc.c b/src/w32proc.c index 2b6cb9c1e1d..a50c87777fa 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -3877,6 +3877,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 +3919,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, From f89e70a7041b061eb40f2b5e0c58a28bfb84920f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 7 Mar 2021 15:52:20 +0200 Subject: [PATCH 1368/1452] Fix encoding of file names in comp.c * src/comp.c (Fcomp__compile_ctxt_to_file) [WINDOWSNT]: Fix encoding of file names passed to libgccjit. --- src/comp.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 7927448d5f0..2322ce001b9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4371,6 +4371,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.func_relocs_local = NULL; #ifdef WINDOWSNT + ebase_name = ansi_encode_filename (ebase_name); /* Tell libgccjit the actual file name of the loaded DLL, otherwise it will use 'libgccjit.so', which is not useful. */ Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from); @@ -4476,9 +4477,13 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); + Lisp_Object encoded_tmp_file = ENCODE_FILE (tmp_file); +#ifdef WINDOWSNT + encoded_tmp_file = ansi_encode_filename (encoded_tmp_file); +#endif gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - SSDATA (ENCODE_FILE (tmp_file))); + SSDATA (encoded_tmp_file)); const char *err = gcc_jit_context_get_first_error (comp.ctxt); if (err) From 948e6609b11b0203d6e1d0fdfdcc23b8538f3e98 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 7 Mar 2021 16:31:35 +0200 Subject: [PATCH 1369/1452] Avoid aborts in native-comp subprocesses when exiting Emacs on Windows * src/w32.c (shutdown_handler): Clear the message stack when being shut down in noninteractive mode, to avoid aborting in shut_down_emacs when a native-compilation subprocess is killed because the parent Emacs exits. --- src/w32.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/w32.c b/src/w32.c index 7ce907d0adb..14b8b11da00 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10447,6 +10447,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); } From 38b4ac3e6b5ac7e88003e02b30bbe2bdb82e6e6a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Mar 2021 19:48:04 +0100 Subject: [PATCH 1370/1452] * Work around GCC PR99126 on all libgccjit < 11 * src/comp.c (Fcomp__compile_ctxt_to_file): Work around GCC PR99126 on all libgccjit < 11. --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 2322ce001b9..bea9945bbfe 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4459,7 +4459,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, && (defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) \ || defined (WINDOWSNT)) Lisp_Object version = Fcomp_libgccjit_version (); - if (!NILP (version) && XFIXNUM (XCAR (version)) == 10) + if (NILP (version) + || XFIXNUM (XCAR (version)) < 11) gcc_jit_context_add_command_line_option (comp.ctxt, "-fdisable-tree-isolate-paths"); #endif From dbdc44db15ef9daa24d92c59d4e158f3963a172f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Mar 2021 20:19:20 +0100 Subject: [PATCH 1371/1452] Allow for `comp-native-driver-options' to work as a file-local variable. --- lisp/emacs-lisp/bytecomp.el | 5 ++++- lisp/emacs-lisp/comp.el | 4 ++++ src/comp.c | 4 +++- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4169b0756df..3ee8113c4f4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2272,7 +2272,10 @@ With argument ARG, insert value in current buffer after the form." (defvar comp-speed) (push `(comp-speed . ,comp-speed) byte-native-qualities) (defvar comp-debug) - (push `(comp-debug . ,comp-debug) byte-native-qualities)) + (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)) ;; Compile the forms from the input buffer. (while (progn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 70e10644ca8..cedbb786237 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -712,6 +712,8 @@ Returns ELT." :documentation "Default speed for this compilation unit.") (debug comp-debug :type number :documentation "Default debug level for this compilation unit.") + (driver-options comp-native-driver-options :type list + :documentation "Options for the GCC driver.") (top-level-forms () :type list :documentation "List of spilled top level forms.") (funcs-h (make-hash-table :test #'equal) :type hash-table @@ -1298,6 +1300,8 @@ clashes." byte-native-qualities) (comp-ctxt-debug comp-ctxt) (alist-get 'comp-debug byte-native-qualities) + (comp-ctxt-driver-options comp-ctxt) (alist-get 'comp-native-driver-options + byte-native-qualities) (comp-ctxt-top-level-forms comp-ctxt) (cl-loop for form in (reverse byte-to-native-top-level-forms) diff --git a/src/comp.c b/src/comp.c index bea9945bbfe..b2d8b8ec987 100644 --- a/src/comp.c +++ b/src/comp.c @@ -516,6 +516,7 @@ typedef struct { typedef struct { EMACS_INT speed; EMACS_INT debug; + Lisp_Object driver_options; gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *bool_type; @@ -4333,7 +4334,7 @@ DEFUN ("comp-native-driver-options-effective-p", static void add_driver_options (void) { - Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); + Lisp_Object options = comp.driver_options; #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) @@ -4400,6 +4401,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, eassert (comp.speed < INT_MAX); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); eassert (comp.debug < INT_MAX); + comp.driver_options = CALL1I (comp-ctxt-driver-options, Vcomp_ctxt); if (comp.debug) gcc_jit_context_set_bool_option (comp.ctxt, From b6f06c32b47be265865949e1f09df4768d5a87e1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Mar 2021 20:25:28 +0100 Subject: [PATCH 1372/1452] * lisp/emacs-lisp/comp.el (w32-get-nproc): Suppress warning declaring it. For non Windows system. --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cedbb786237..7b2883b293b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3818,6 +3818,7 @@ processes from `comp-async-compilations'" do (remhash file-name comp-async-compilations)) (hash-table-count comp-async-compilations)) +(declare-function w32-get-nproc "w32.c") (defvar comp-num-cpus nil) (defun comp-effective-async-max-jobs () "Compute the effective number of async jobs." From dcf2be69711be1240c09ba6f6f0482a7fcf4e21b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Mar 2021 21:01:35 +0100 Subject: [PATCH 1373/1452] ; * src/comp.c (load_comp_unit): Fix a comment. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index b2d8b8ec987..b68adf31d68 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4814,7 +4814,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* 'dlopen' returns the same handle when trying to load two times the same shared. In this case touching 'd_reloc' etc leads to fails in case a frame with a reference to it in a live reg is - active (comp-speed >= 0). + active (comp-speed > 0). We must *never* mess with static pointers in an already loaded eln. */ From 9809f7ed2c639bd51abd4a28bd5d1a37f0d46a3d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Mar 2021 21:26:55 +0100 Subject: [PATCH 1374/1452] Use `length=' and family where possible in native comp code * lisp/emacs-lisp/comp-cstr.el (comp-intersect-typesets) (comp-cstr-imm): Use Use `length=' and family where possible. * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs-target-block) (comp-compute-dominator-frontiers) (batch-byte-native-compile-for-bootstrap): Likewise. --- lisp/emacs-lisp/comp-cstr.el | 4 ++-- lisp/emacs-lisp/comp.el | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 4397a914981..d0b842e7c37 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -287,7 +287,7 @@ Return them as multiple value." (defun comp-intersect-typesets (&rest typesets) "Intersect types present into TYPESETS." (unless (cl-some #'null typesets) - (if (= (length typesets) 1) + (if (length= typesets 1) (car typesets) (comp-normalize-typeset (cl-reduce #'comp-intersect-two-typesets typesets))))) @@ -823,7 +823,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (valset ,cstr) (list ,val))))))) (with-comp-cstr-accessors (let ((v (valset cstr))) - (if (= (length v) 1) + (if (length= v 1) (car v) (caar (range cstr)))))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7b2883b293b..81ab361fff7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2364,7 +2364,7 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-func-blocks comp-func))) (target-bb-in-edges (comp-block-in-edges target-bb))) (cl-assert target-bb-in-edges) - (if (= (length target-bb-in-edges) 1) + (if (length= target-bb-in-edges 1) ;; If block has only one predecessor is already suitable for ;; adding constraint assumptions. target-bb @@ -2780,7 +2780,7 @@ blocks." for b-name being each hash-keys of blocks using (hash-value b) for preds = (comp-block-preds b) - when (>= (length preds) 2) ; All joins + when (length> preds 1) ; All joins do (cl-loop for p in preds for runner = p do (while (not (eq runner (comp-block-idom b))) @@ -4104,7 +4104,7 @@ environment variable 'NATIVE_DISABLED' is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) - (cl-assert (= 1 (length command-line-args-left))) + (cl-assert (length= command-line-args-left 1)) (let ((byte-native-for-bootstrap t) (byte-to-native-output-file nil)) (batch-native-compile) From 15aa239ba058ef02544e5dfaf066bd985d9b2f4f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 7 Mar 2021 21:56:06 +0100 Subject: [PATCH 1375/1452] * Handle `comp-native-driver-options' both as file-local both as global * src/comp.c (add_driver_options): Throw an error if `comp-native-driver-options' is set globally but 'gcc_jit_context_add_driver_option' is not available, ignore for the file-local case. --- src/comp.c | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src/comp.c b/src/comp.c index b68adf31d68..e6f672de254 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4334,9 +4334,9 @@ DEFUN ("comp-native-driver-options-effective-p", static void add_driver_options (void) { - Lisp_Object options = comp.driver_options; + Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); -#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) load_gccjit_if_necessary (true); if (!NILP (Fcomp_native_driver_options_effective_p ())) @@ -4347,7 +4347,6 @@ add_driver_options (void) ENCODE_FILE or ENCODE_SYSTEM. */ SSDATA (XCAR (options))); - return; #endif if (CONSP (options)) xsignal1 (Qnative_compiler_error, @@ -4355,6 +4354,20 @@ add_driver_options (void) " via `comp-native-driver-options' is" " only available on libgccjit version 9" " and above.")); + + /* Captured `comp-native-driver-options' because file-local. */ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + || defined (WINDOWSNT) + options = comp.driver_options; + if (!NILP (Fcomp_native_driver_options_effective_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ + SSDATA (XCAR (options))); +#endif } DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, From 93f92cf1ba37f8b9abaee4b9487705bae464c4e0 Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Sun, 7 Mar 2021 21:26:29 +0000 Subject: [PATCH 1376/1452] Zero stale pointer when unloading comp units (bug#46256) * src/alloc.c (cleanup_vector): Call unload_comp_unit. * src/comp.c (unload_comp_unit): New function. --- src/alloc.c | 3 +-- src/comp.c | 14 ++++++++++++++ src/comp.h | 2 ++ 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index af083361770..fee8cc08aa4 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3157,8 +3157,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - eassert (cu->handle); - dynlib_close (cu->handle); + unload_comp_unit (cu); } else if (NATIVE_COMP_FLAG && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) diff --git a/src/comp.c b/src/comp.c index e6f672de254..e1809785410 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4949,6 +4949,20 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, return res; } +void +unload_comp_unit (struct Lisp_Native_Comp_Unit *cu) +{ + if (cu->handle == NULL) + return; + + Lisp_Object *saved_cu = dynlib_sym (cu->handle, COMP_UNIT_SYM); + Lisp_Object this_cu; + XSETNATIVE_COMP_UNIT (this_cu, cu); + if (EQ (this_cu, *saved_cu)) + *saved_cu = Qnil; + dynlib_close (cu->handle); +} + Lisp_Object native_function_doc (Lisp_Object function) { diff --git a/src/comp.h b/src/comp.h index f7d17f398c7..d01bc17565d 100644 --- a/src/comp.h +++ b/src/comp.h @@ -78,6 +78,8 @@ 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); From 380ba045c48bfbb160da288b1bd50f82d3f999f0 Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Mon, 8 Mar 2021 20:49:59 +0000 Subject: [PATCH 1377/1452] * Fix comp unit type decl in eln files to fix GC crash (bug#46256) * src/comp.c (emit_ctxt_code): Allocate comp_unit as a Lisp_Object, not a pointer to pointer to Lisp_Object. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index e1809785410..9b7be5cce71 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2774,7 +2774,7 @@ emit_ctxt_code (void) comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), + comp.lisp_obj_type, COMP_UNIT_SYM); declare_imported_data (); From 7672b15c2730d55cfc3aba1b83986721f932ba50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Mar 2021 12:06:28 +0100 Subject: [PATCH 1378/1452] * test/src/comp-test-funcs.el (comp-test-46670-1-f): Remove a warning. --- test/src/comp-test-funcs.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 08aa6bb472e..cbd0e5747e8 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -478,7 +478,7 @@ (eq family 'unspecified)) family))) -(defun comp-test-46670-1-f (x) +(defun comp-test-46670-1-f (_) "foo") (defun comp-test-46670-2-f (s) From 79c83f79c5b618cb9ef5eca7be2245f15ff54626 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 9 Mar 2021 16:35:13 +0100 Subject: [PATCH 1379/1452] * src/comp.c (ABI_VERSION): Bump following-up 380ba045c4. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 9b7be5cce71..2ed893cbe04 100644 --- a/src/comp.c +++ b/src/comp.c @@ -429,7 +429,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "2" +#define ABI_VERSION "3" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 From fe1c081c3881421841b1e1ce4847035fdcdd457b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Mar 2021 15:50:58 +0100 Subject: [PATCH 1380/1452] * Fix truncated warnings (bug#47024) * lisp/emacs-lisp/comp.el (comp-run-async-workers): Bind `warning-fill-column' to `most-positive-fixnum'. --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 81ab361fff7..3d2a345e210 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3882,7 +3882,8 @@ display a message." comp-eln-load-path ',comp-eln-load-path comp-native-driver-options ',comp-native-driver-options - load-path ',load-path) + load-path ',load-path + warning-fill-column most-positive-fixnum) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) (comp--native-compile ,source-file ,(and load t)))) From 711b2c834976e41ca2c9c36dafcc9977eb4f398b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 10 Mar 2021 15:56:05 +0100 Subject: [PATCH 1381/1452] * lisp/loadup.el: Don't load pcase on native builds (bug#47025). --- lisp/loadup.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/loadup.el b/lisp/loadup.el index 5b39152482e..f65f7f1d30a 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -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 From 0144764d1dde8a2f1d413d042d46cea3e10a7d0a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 12 Mar 2021 08:59:55 +0100 Subject: [PATCH 1382/1452] * Fix error reporting for async native compilation (bug#47024) * lisp/emacs-lisp/comp.el (comp--native-compile): During async compilation if we catch an error print it in a parsable way so we can report it to the user. --- lisp/emacs-lisp/comp.el | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3d2a345e210..98f4dd6e1f6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3970,12 +3970,24 @@ load once it finishes compiling." (comp-log (format "Done compiling %s" data) 0) (cl-loop for (pass . time) in (reverse report) do (comp-log (format "Pass %s took: %fs." pass time) 0)))) - (native-compiler-error - ;; Add source input. + (t (let ((err-val (cdr err))) - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val)))))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) (if (stringp function-or-file) data ;; So we return the compiled function. From d9cd55a4f1c3f391b996dfbe77ed24306b37ac9f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 12 Mar 2021 10:24:29 +0100 Subject: [PATCH 1383/1452] Implement `no-native-compile' (bug#46983) * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Capture `no-native-compile'. * lisp/emacs-lisp/comp.el (no-native-compile): Define new variable. (comp-spill-lap-function): Throw when `no-native-compile' was captured non-nil. (comp--native-compile): Catch `no-native-compile' if necessary and return nil in case. --- lisp/emacs-lisp/bytecomp.el | 3 ++ lisp/emacs-lisp/comp.el | 97 +++++++++++++++++++++---------------- 2 files changed, 57 insertions(+), 43 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 94424fc38af..8ca4adc6a96 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2275,6 +2275,9 @@ With argument ARG, insert value in current buffer after the form." (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. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98f4dd6e1f6..a62efc7e025 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -180,6 +180,13 @@ the .eln output directory." :type 'boolean :version "28.1") +(defvar no-native-compile nil + "Non-nil to prevent native-compiling of Emacs Lisp code. +This is normally set in local file variables at the end of the elisp file: + +\;; Local Variables:\n;; no-native-compile: t\n;; End: ") +;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp) + (defvar comp-log-time-report nil "If non-nil, log a time report for each pass.") @@ -1289,6 +1296,8 @@ clashes." (cl-defmethod comp-spill-lap-function ((filename string)) "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) + (when (alist-get 'no-native-compile byte-native-qualities) + (throw 'no-native-compile nil)) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) (unless (comp-ctxt-output comp-ctxt) @@ -3943,55 +3952,57 @@ load once it finishes compiling." (stringp function-or-file)) (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) - (let* ((data function-or-file) - (comp-native-compiling t) - (byte-native-qualities nil) - ;; Have byte compiler signal an error when compilation fails. - (byte-compile-debug t) - (comp-ctxt (make-comp-ctxt :output output - :with-late-load with-late-load))) - (comp-log "\n \n" 1) - (condition-case err - (cl-loop - with report = nil - for t0 = (current-time) - for pass in comp-passes - unless (memq pass comp-disabled-passes) + (catch 'no-native-compile + (let* ((data function-or-file) + (comp-native-compiling t) + (byte-native-qualities nil) + ;; Have byte compiler signal an error when compilation fails. + (byte-compile-debug t) + (comp-ctxt (make-comp-ctxt :output output + :with-late-load with-late-load))) + (comp-log "\n \n" 1) + (condition-case err + (cl-loop + with report = nil + for t0 = (current-time) + for pass in comp-passes + unless (memq pass comp-disabled-passes) do (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) + function-or-file pass) + 2) (setf data (funcall pass data)) (push (cons pass (float-time (time-since t0))) report) (cl-loop for f in (alist-get pass comp-post-pass-hooks) do (funcall f data)) - finally - (when comp-log-time-report - (comp-log (format "Done compiling %s" data) 0) - (cl-loop for (pass . time) in (reverse report) - do (comp-log (format "Pass %s took: %fs." pass time) 0)))) - (t - (let ((err-val (cdr err))) - ;; If we are doing an async native compilation print the - ;; error in the correct format so is parsable and abort. - (if (and comp-async-compilation - (not (eq (car err) 'native-compiler-error))) - (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") - function-or-file - (get (car err) 'error-message) - (car-safe err-val)) - (kill-emacs -1)) - ;; Otherwise re-signal it adding the compilation input. - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data)))) + finally + (when comp-log-time-report + (comp-log (format "Done compiling %s" data) 0) + (cl-loop for (pass . time) in (reverse report) + do (comp-log (format "Pass %s took: %fs." pass time) 0)))) + (native-compiler-skip) + (t + (let ((err-val (cdr err))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. From d018584814e0c15f13bc458ba54491239b584069 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 12 Mar 2021 22:19:51 +0100 Subject: [PATCH 1384/1452] * Fix circular dependecy when loading a modified comp.el (bug#47049) * lisp/emacs-lisp/comp.el (comp-subr-trampoline-install): Move it before other functional code. --- lisp/emacs-lisp/comp.el | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a62efc7e025..866ee8dcf73 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -648,6 +648,23 @@ Useful to hook into pass checkers.") 'native-compiler-error) +;; Moved early to avoid circularity when comp.el is loaded and +;; `macroexpand' needs to be advised (bug#47049). +;;;###autoload +(defun comp-subr-trampoline-install (subr-name) + "Make SUBR-NAME effectively advice-able when called from native code." + (unless (or (null comp-enable-subr-trampolines) + (memq subr-name comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (comp--install-trampoline + subr-name + (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name) + ;; Should never happen. + (cl-assert nil))))) + + (cl-defstruct (comp-vec (:copier nil)) "A re-sizable vector like object." (data (make-hash-table :test #'eql) :type hash-table @@ -3743,20 +3760,6 @@ Return the trampoline if found or nil otherwise." finally (error "Cannot find suitable directory for output in \ `comp-eln-load-path'"))))) -;;;###autoload -(defun comp-subr-trampoline-install (subr-name) - "Make SUBR-NAME effectively advice-able when called from native code." - (unless (or (null comp-enable-subr-trampolines) - (memq subr-name comp-never-optimize-functions) - (gethash subr-name comp-installed-trampolines-h)) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (comp--install-trampoline - subr-name - (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name) - ;; Should never happen. - (cl-assert nil))))) - ;; Some entry point support code. From f142f5ba46abed95c99e5dd55fb6f3a1af544148 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 14 Mar 2021 15:36:39 +0200 Subject: [PATCH 1385/1452] Fix hang due to failure to clean up *.eln.old files at exit * src/comp.c (eln_load_path_final_clean_up): Call internal_delete_file, not Fdelete_file, to ignore any errors. (Bug#46972) --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 2ed893cbe04..970c8022678 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4616,7 +4616,7 @@ eln_load_path_final_clean_up (void) Qt, build_string ("\\.eln\\.old\\'"), Qnil, Qnil, Qt, return_nil); FOR_EACH_TAIL (files_in_dir) - Fdelete_file (XCAR (files_in_dir), Qnil); + internal_delete_file (XCAR (files_in_dir)); } #endif } From 472cd53d935a8dea3f15161287d27ee272345300 Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Sun, 14 Mar 2021 12:13:40 +0000 Subject: [PATCH 1386/1452] Don't call setjmp through a function pointer on Windows (bug#47067) * src/comp.c (ABI_VERSION): Bump. (emit_setjmp): Call setjmp directly. (declare_runtime_imported_funcs): Remove setjmp. (helper_link_table): Remove entry for setjmp. --- src/comp.c | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/comp.c b/src/comp.c index 970c8022678..a79ee4ad87b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -429,7 +429,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "3" +#define ABI_VERSION "4" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -654,9 +654,6 @@ void *helper_link_table[] = helper_PSEUDOVECTOR_TYPEP_XUNTAG, pure_write_error, push_handler, -#ifdef WINDOWSNT - SETJMP_NAME, -#endif record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, @@ -1972,6 +1969,11 @@ emit_setjmp (gcc_jit_rvalue *buf) return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args); #else /* _setjmp (buf, __builtin_frame_address (0)) */ + gcc_jit_param *params[] = + { + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "frame"), + }; gcc_jit_rvalue *args[2]; args[0] = @@ -1985,8 +1987,14 @@ emit_setjmp (gcc_jit_rvalue *buf) "__builtin_frame_address"), 1, args); args[0] = buf; - return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, - false); + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.int_type, STR (SETJMP_NAME), + ARRAYELTS (params), params, + false); + + return gcc_jit_context_new_call (comp.ctxt, NULL, f, 2, args); #endif } @@ -2701,12 +2709,6 @@ declare_runtime_imported_funcs (void) args[1] = comp.int_type; ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); -#ifdef WINDOWSNT - args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); - args[1] = comp.void_ptr_type; - ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); -#endif - ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); args[0] = comp.lisp_obj_type; From 5e4ec4d3c944f586892e08ea4fb7715e0f6ac365 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 14 Mar 2021 21:54:06 +0100 Subject: [PATCH 1387/1452] Fix some entry in `comp-known-type-specifiers' (bug#46847) * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Some fix. * test/src/comp-tests.el (comp-tests-46670-1): Update test. --- lisp/emacs-lisp/comp.el | 16 ++++++++-------- test/src/comp-tests.el | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 866ee8dcf73..97efd1ab0c7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -258,8 +258,8 @@ Useful to hook into pass checkers.") (>= (function ((or number marker) &rest (or number marker)) boolean)) (abs (function (number) number)) (acos (function (number) float)) - (append (function (&rest list) list)) - (aref (function (array fixnum) t)) + (append (function (&rest t) t)) + (aref (function (t fixnum) t)) (arrayp (function (t) boolean)) (ash (function (integer integer) integer)) (asin (function (number) float)) @@ -269,7 +269,7 @@ Useful to hook into pass checkers.") (bignump (function (t) boolean)) (bobp (function () boolean)) (bolp (function () boolean)) - (bool-vector-count-consecutive (function (bool-vector bool-vector integer) fixnum)) + (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum)) (bool-vector-count-population (function (bool-vector) fixnum)) (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) (bool-vector-p (function (t) boolean)) @@ -384,7 +384,7 @@ Useful to hook into pass checkers.") (integer-or-marker-p (function (t) boolean)) (integerp (function (t) boolean)) (interactive-p (function () boolean)) - (intern-soft (function (string &optional vector) symbol)) + (intern-soft (function ((or string symbol) &optional vector) symbol)) (invocation-directory (function () string)) (invocation-name (function () string)) (isnan (function (float) boolean)) @@ -394,7 +394,7 @@ Useful to hook into pass checkers.") (last (function (list &optional integer) list)) (lax-plist-get (function (list t) t)) (ldexp (function (number integer) float)) - (length (function (sequence) integer)) + (length (function (t) (integer 0 *))) (length< (function (sequence fixnum) boolean)) (length= (function (sequence fixnum) boolean)) (length> (function (sequence fixnum) boolean)) @@ -441,7 +441,7 @@ Useful to hook into pass checkers.") (nlistp (function (t) boolean)) (not (function (t) boolean)) (nth (function (integer list) t)) - (nthcdr (function (integer list) list)) + (nthcdr (function (integer t) t)) (null (function (t) boolean)) (number-or-marker-p (function (t) boolean)) (number-to-string (function (number) string)) @@ -481,7 +481,7 @@ Useful to hook into pass checkers.") (sqrt (function (number) float)) (standard-case-table (function () char-table)) (standard-syntax-table (function () char-table)) - (string (function (&rest fixnum) strng)) + (string (function (&rest fixnum) string)) (string-as-multibyte (function (string) string)) (string-as-unibyte (function (string) string)) (string-equal (function ((or string symbol) (or string symbol)) boolean)) @@ -519,7 +519,7 @@ Useful to hook into pass checkers.") (type-of (function (t) symbol)) (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum (upcase (function ((or fixnum string)) (or fixnum string))) - (user-full-name (function (&optional integer) string)) + (user-full-name (function (&optional integer) (or string null))) (user-login-name (function (&optional integer) (or string null))) (user-original-login-name (function (&optional integer) (or string null))) (user-real-login-name (function () string)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f60e4ab0497..b618110bbe4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -501,7 +501,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "" (should (string= (comp-test-46670-2-f "foo") "foo")) (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) - '(function (t) (or null sequence))))) + '(function (t) t)))) (comp-deftest 46824-1 () "" From aabda4263bc2000a69e61e93a232e71f8afedec9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 15 Mar 2021 16:56:08 +0200 Subject: [PATCH 1388/1452] Prefer expand-file-name to concat in native-compilation code * lisp/emacs-lisp/comp.el (comp-eln-load-path-eff): * src/comp.c (Fcomp_el_to_eln_filename) (eln_load_path_final_clean_up): Prefer expand-file-name to concat. (Bug#43725) --- lisp/emacs-lisp/comp.el | 6 +++--- src/comp.c | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 97efd1ab0c7..5a4a2f6ef15 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3691,9 +3691,9 @@ Prepare every function for final compilation and drive the C back-end." "Return a list of effective eln load directories. Account for `comp-load-path' and `comp-native-version-dir'." (mapcar (lambda (dir) - (concat (file-name-as-directory - (expand-file-name dir invocation-directory)) - comp-native-version-dir)) + (expand-file-name comp-native-version-dir + (file-name-as-directory + (expand-file-name dir invocation-directory)))) comp-eln-load-path)) (defun comp-trampoline-filename (subr-name) diff --git a/src/comp.c b/src/comp.c index a79ee4ad87b..29b16c78ac0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4121,8 +4121,8 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); return Fexpand_file_name (filename, - concat2 (Ffile_name_as_directory (base_dir), - Vcomp_native_version_dir)); + Fexpand_file_name (Vcomp_native_version_dir, + base_dir)); } DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, @@ -4613,8 +4613,8 @@ eln_load_path_final_clean_up (void) { Lisp_Object files_in_dir = internal_condition_case_5 (Fdirectory_files, - concat2 (XCAR (dir_tail), - Vcomp_native_version_dir), + Fexpand_file_name (Vcomp_native_version_dir, + XCAR (dir_tail)), Qt, build_string ("\\.eln\\.old\\'"), Qnil, Qnil, Qt, return_nil); FOR_EACH_TAIL (files_in_dir) From 7f74ed4912d845551209a5541c8919afbe19b884 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 15 Mar 2021 16:46:16 +0100 Subject: [PATCH 1389/1452] * lisp/emacs-lisp/bytecomp.el: Fix native re-compilation (bug#47161). --- lisp/emacs-lisp/bytecomp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 921a25b35c9..b04286c34ae 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5423,6 +5423,7 @@ 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)) From 6810635bdd109d3df5b6b946e8c9eb11035b579c Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 15 Mar 2021 19:24:20 +0200 Subject: [PATCH 1390/1452] * lisp/emacs-lisp/byte-opt.el: Fix native re-compilation (bug#47161). --- lisp/emacs-lisp/byte-opt.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index db8d825cfec..436f5e48ae1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2350,6 +2350,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)) From f3abb1711811f43d1504d8e48f0d27e015b46d6c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Mar 2021 09:10:31 +0100 Subject: [PATCH 1391/1452] Have `no-byte-compile' implies also `no-native-compile'. * lisp/emacs-lisp/comp.el (no-native-compile): Update doctring. * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): when `no-byte-compile' is set to non-nil it overrides this. --- lisp/emacs-lisp/bytecomp.el | 3 ++- lisp/emacs-lisp/comp.el | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b04286c34ae..6b874b69167 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2277,7 +2277,8 @@ With argument ARG, insert value in current buffer after the form." (push `(comp-native-driver-options . ,comp-native-driver-options) byte-native-qualities) (defvar no-native-compile) - (push `(no-native-compile . ,no-native-compile) + ;; `no-byte-compile' implies also `no-native-compile'. + (push `(no-native-compile . ,(or no-byte-compile no-native-compile)) byte-native-qualities)) ;; Compile the forms from the input buffer. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5a4a2f6ef15..a3a481cd36a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -182,6 +182,8 @@ the .eln output directory." (defvar no-native-compile nil "Non-nil to prevent native-compiling of Emacs Lisp code. +Note that when `no-byte-compile' is set to non-nil it overrides the value of +`no-native-compile'. This is normally set in local file variables at the end of the elisp file: \;; Local Variables:\n;; no-native-compile: t\n;; End: ") From 3e133cc050926284109fe61f4789f67676491ffa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 16 Mar 2021 18:56:34 +0100 Subject: [PATCH 1392/1452] Fix `no-byte-compile' native compilation interaction (bug#47169) * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Throw no-native-compile when `byte-native-qualities' are null. * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): No need to consider `no-byte-compile'. --- lisp/emacs-lisp/bytecomp.el | 3 +-- lisp/emacs-lisp/comp.el | 3 ++- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6b874b69167..b04286c34ae 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2277,8 +2277,7 @@ With argument ARG, insert value in current buffer after the form." (push `(comp-native-driver-options . ,comp-native-driver-options) byte-native-qualities) (defvar no-native-compile) - ;; `no-byte-compile' implies also `no-native-compile'. - (push `(no-native-compile . ,(or no-byte-compile no-native-compile)) + (push `(no-native-compile . ,no-native-compile) byte-native-qualities)) ;; Compile the forms from the input buffer. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a3a481cd36a..6da1a7979c3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1315,7 +1315,8 @@ clashes." (cl-defmethod comp-spill-lap-function ((filename string)) "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) - (when (alist-get 'no-native-compile byte-native-qualities) + (when (or (null byte-native-qualities) + (alist-get 'no-native-compile byte-native-qualities)) (throw 'no-native-compile nil)) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) From b3ad62f8a35617366886be2a86e8641282824adf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 19 Mar 2021 10:23:41 +0100 Subject: [PATCH 1393/1452] Do not load native code when `load' is explicitly called on a .elc file * src/lread.c (Fload): Do not load native code when `load' is explicitly called on a .elc file. (Flocate_file_internal): Update 'openp' call sites. (maybe_swap_for_eln): Add new 'no_native' parameter. (openp): Likewise + update 'maybe_swap_for_eln' and 'openp' call sites. * src/lisp.h: Update 'openp' signature. * src/w32proc.c (sys_spawnve): Update 'openp' call sites. * src/w32.c (check_windows_init_file): Likewise. * src/sound.c (Fplay_sound_internal): Likewise. * src/process.c (Fmake_process): Likewise. * src/image.c (image_create_bitmap_from_file) (image_find_image_fd): Likewise. * src/emacs.c (set_invocation_vars): Likewise. * src/charset.c (load_charset_map_from_file): Likewise. * src/callproc.c (call_process): Likewise. --- src/callproc.c | 2 +- src/charset.c | 2 +- src/emacs.c | 5 +++-- src/image.c | 4 ++-- src/lisp.h | 2 +- src/lread.c | 24 ++++++++++++++++-------- src/process.c | 2 +- src/sound.c | 5 +++-- src/w32.c | 3 ++- src/w32proc.c | 3 ++- 10 files changed, 32 insertions(+), 20 deletions(-) diff --git a/src/callproc.c b/src/callproc.c index cd0f67fe29b..5aa2cbafb4c 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -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]); } diff --git a/src/charset.c b/src/charset.c index eb388d1868b..7cd0fa78f04 100644 --- a/src/charset.c +++ b/src/charset.c @@ -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) { diff --git a/src/emacs.c b/src/emacs.c index ec62c19e388..d353679b0f0 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -468,8 +468,9 @@ set_invocation_vars (char *argv0, 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 diff --git a/src/image.c b/src/image.c index 6d493f6cdd4..2f85e3035e8 100644 --- a/src/image.c +++ b/src/image.c @@ -519,7 +519,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; @@ -3128,7 +3128,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); diff --git a/src/lisp.h b/src/lisp.h index fcdf8e27181..4004b535cdf 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4087,7 +4087,7 @@ 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), diff --git a/src/lread.c b/src/lread.c index 989b55c88f9..3bf31500065 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1240,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) @@ -1280,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) @@ -1635,7 +1639,7 @@ 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; @@ -1645,12 +1649,13 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) If found replace the content of FILENAME and FD. */ static void -maybe_swap_for_eln (Lisp_Object *filename, int *fd) +maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) { #ifdef HAVE_NATIVE_COMP struct stat eln_st; - if (load_no_native + if (no_native + || load_no_native || !suffix_p (*filename, ".elc")) return; @@ -1714,11 +1719,14 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd) 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]; @@ -1928,7 +1936,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - maybe_swap_for_eln (&string, &fd); + maybe_swap_for_eln (no_native, &string, &fd); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; @@ -1940,7 +1948,7 @@ 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 (&save_string, &save_fd); + maybe_swap_for_eln (no_native, &save_string, &save_fd); if (storeptr) *storeptr = save_string; SAFE_FREE (); diff --git a/src/process.c b/src/process.c index b98bc297a3f..84e301a87a5 100644 --- a/src/process.c +++ b/src/process.c @@ -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); diff --git a/src/sound.c b/src/sound.c index e5f66f8f529..9041076bdc0 100644 --- a/src/sound.c +++ b/src/sound.c @@ -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"); diff --git a/src/w32.c b/src/w32.c index 14b8b11da00..467e6cb4271 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10255,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); diff --git a/src/w32proc.c b/src/w32proc.c index a50c87777fa..ffa56e135d0 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -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; From be22cda7be9e77e67f224f6f07cca9dd44aaa078 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 09:15:25 +0100 Subject: [PATCH 1394/1452] * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Clean-up all .eln dirs. --- lisp/emacs-lisp/comp.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6da1a7979c3..ca4be0fe976 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3776,11 +3776,14 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. + for dir in (comp-eln-load-path-eff) do (cl-loop for f in (when (file-exists-p dir) (directory-files dir t regexp t)) - do (comp-delete-or-replace-file f))))) + ;; We may not be able to delete de file if we have no write + ;; permisison. + do (ignore-error file-error + (comp-delete-or-replace-file f)))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. From 08682ccc3154eaae993dbcb71a6498d1c06d80ae Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 09:28:25 +0100 Subject: [PATCH 1395/1452] ; Remove two unnecessary quotes * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): Remove unnecessary quote. * lisp/emacs-lisp/comp.el (comp-compile-ctxt-to-file): Likewise. --- lisp/emacs-lisp/comp-cstr.el | 2 +- lisp/emacs-lisp/comp.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d0b842e7c37..7f5d34b45c3 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -873,7 +873,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." for v in (valset cstr) do (when-let* ((ok (floatp v)) - (truncated (ignore-error 'overflow-error + (truncated (ignore-error overflow-error (truncate v))) (ok (= v truncated))) (push (cons truncated truncated) (range cstr)))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ca4be0fe976..76b4733cfaa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3606,7 +3606,7 @@ Prepare every function for final compilation and drive the C back-end." (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. - (ignore-error 'file-already-exists + (ignore-error file-already-exists (make-directory dir t))) (comp--compile-ctxt-to-file name))) From d0280ce1b160ddc440d4ecac0397c50d2f5235eb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 15:32:52 +0100 Subject: [PATCH 1396/1452] Revert "* lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Clean-up all..." This reverts commit be22cda7be9e77e67f224f6f07cca9dd44aaa078. Older binaries might still need those .eln if they where preloaded. --- lisp/emacs-lisp/comp.el | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 76b4733cfaa..37b61edeb0c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3776,14 +3776,11 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (comp-eln-load-path-eff) + for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. do (cl-loop for f in (when (file-exists-p dir) (directory-files dir t regexp t)) - ;; We may not be able to delete de file if we have no write - ;; permisison. - do (ignore-error file-error - (comp-delete-or-replace-file f)))))) + do (comp-delete-or-replace-file f))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. From af739863b0a5fd3bbff048faef59b8feef45cca6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 16:55:19 +0100 Subject: [PATCH 1397/1452] Add a tmp dir to `comp-eln-load-path' when running the testsuite. * lisp/startup.el (normal-top-level): Tweak `comp-eln-load-path' adding a temp directory when running the testsuite. --- lisp/startup.el | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lisp/startup.el b/lisp/startup.el index 7e8fa47aea7..3e39ebc6e22 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -537,13 +537,19 @@ It is the default value of the variable `top-level'." (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 (concat user-emacs-directory "eln-cache/") comp-eln-load-path)) + (push (concat user-emacs-directory "eln-cache/") 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 From ec12cdd19732d9ad2be313cc93c17766ec62118f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 19:39:52 +0100 Subject: [PATCH 1398/1452] ; * test/Makefile.in (TEST_HOME): Add a note. --- test/Makefile.in | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Makefile.in b/test/Makefile.in index cb86f8e2973..3cfd60d46c0 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -120,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 From 5aa42f686c635e3b3f6cea8270e3c6fc2e4270f9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 20:40:45 +0100 Subject: [PATCH 1399/1452] Prevent unnecessary multiple .el hashing in 'maybe_swap_for_eln' * src/comp.c (Fcomp_el_to_eln_rel_filename): New function. (Fcomp_el_to_eln_filename): Make use of. (syms_of_comp): Register 'Scomp_el_to_eln_rel_filename'. * src/lread.c (maybe_swap_for_eln): Make use of 'Fcomp_el_to_eln_rel_filename' to hash prevent unnecessary multiple hashing. --- src/comp.c | 21 +++++++++++++++------ src/lread.c | 22 ++++++++++++---------- 2 files changed, 27 insertions(+), 16 deletions(-) diff --git a/src/comp.c b/src/comp.c index 29b16c78ac0..4e2b941b670 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4001,11 +4001,10 @@ make_directory_wrapper_1 (Lisp_Object ignore) return Qt; } -DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, - Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Return the corresponding .eln filename for source FILENAME. -If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) - (Lisp_Object filename, Lisp_Object base_dir) +DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename, + Scomp_el_to_eln_rel_filename, 1, 1, 0, + doc: /* Return the corresponding .eln relative filename. */) + (Lisp_Object filename) { CHECK_STRING (filename); @@ -4082,7 +4081,16 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) make_fixnum (-3))), separator); Lisp_Object hash = concat3 (path_hash, separator, content_hash); - filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); + return concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); +} + +DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, + Scomp_el_to_eln_filename, 1, 2, 0, + doc: /* Return the corresponding .eln filename for source FILENAME. +If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) + (Lisp_Object filename, Lisp_Object base_dir) +{ + filename = Fcomp_el_to_eln_rel_filename (filename); /* If base_dir was not specified search inside Vcomp_eln_load_path for the first directory where we have write access. */ @@ -5287,6 +5295,7 @@ compiled one. */); "configuration, please recompile")); defsubr (&Scomp__subr_signature); + defsubr (&Scomp_el_to_eln_rel_filename); defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp_native_driver_options_effective_p); defsubr (&Scomp__install_trampoline); diff --git a/src/lread.c b/src/lread.c index 3bf31500065..5fd52feb376 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1661,19 +1661,21 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) /* 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))) + /* Can't find the corresponding source file. */ + return; + } + Lisp_Object eln_rel_name = Fcomp_el_to_eln_rel_filename (src_name); + FOR_EACH_TAIL_SAFE (eln_path_tail) { - 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))) - /* Can't find the corresponding source file. */ - return; - } Lisp_Object eln_name = - Fcomp_el_to_eln_filename (src_name, XCAR (eln_path_tail)); + Fexpand_file_name (eln_rel_name, XCAR (eln_path_tail)); int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); if (eln_fd > 0) From 6351953dcd162d46fcccfaeb0076d22e2a390951 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 21:24:26 +0100 Subject: [PATCH 1400/1452] * lisp/emacs-lisp/comp.el (comp-lookup-eln): Add new function. --- lisp/emacs-lisp/comp.el | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 37b61edeb0c..e688d41f5d9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4099,6 +4099,20 @@ bytecode definition was not changed in the meantime)." ;;; Compiler entry points. +(defun comp-lookup-eln (filename) + "Given a Lisp source FILENAME return the corresponding .eln file if found. +Search happens in `comp-eln-load-path'." + (cl-loop + with eln-filename = (comp-el-to-eln-rel-filename filename) + for dir in comp-eln-load-path + for f = (expand-file-name eln-filename + (expand-file-name comp-native-version-dir + (expand-file-name + dir + invocation-directory))) + when (file-exists-p f) + do (cl-return f))) + ;;;###autoload (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. From 5ae0a728c02045d274e61cc8c9290e827b0fadb8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 21:49:03 +0100 Subject: [PATCH 1401/1452] ; * src/comp.c (Fcomp_el_to_eln_filename): Improve docstring. --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 4e2b941b670..5eb7bf21066 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4086,7 +4086,8 @@ DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename, DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Return the corresponding .eln filename for source FILENAME. + doc: /* Return the .eln filename for source FILENAME to used +for new compilations. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { From 7ba816ee1cba00cf29cc79f60e731d86c8dc3a07 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 21:55:13 +0100 Subject: [PATCH 1402/1452] * lisp/emacs-lisp/comp.el (comp-lookup-eln): Add autoload cookie. --- lisp/emacs-lisp/comp.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e688d41f5d9..90e127d6323 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4099,6 +4099,7 @@ bytecode definition was not changed in the meantime)." ;;; Compiler entry points. +;;;###autoload (defun comp-lookup-eln (filename) "Given a Lisp source FILENAME return the corresponding .eln file if found. Search happens in `comp-eln-load-path'." From 4a3b43f55cfa96f5dd42e360eb4577750e97dbf0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 24 Mar 2021 11:23:00 +0100 Subject: [PATCH 1403/1452] * src/lread.c (maybe_swap_for_eln): Fix eln filename (bug#bug#47337). --- src/lread.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/lread.c b/src/lread.c index 5fd52feb376..56717dba810 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1675,7 +1675,9 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) FOR_EACH_TAIL_SAFE (eln_path_tail) { Lisp_Object eln_name = - Fexpand_file_name (eln_rel_name, XCAR (eln_path_tail)); + Fexpand_file_name (eln_rel_name, + Fexpand_file_name (Vcomp_native_version_dir, + XCAR (eln_path_tail))); int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); if (eln_fd > 0) From 92914ade6d3c74ab0a1a7b3820e4707fb0679977 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 24 Mar 2021 16:59:52 +0100 Subject: [PATCH 1404/1452] Improve two native compiler related docstrings. * lisp/emacs-lisp/comp.el (comp-eln-load-path-eff): Improve docstring. * src/comp.c (comp-eln-load-path): Likewise. --- lisp/emacs-lisp/comp.el | 2 +- src/comp.c | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 90e127d6323..0597837ebd0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3692,7 +3692,7 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-eln-load-path-eff () "Return a list of effective eln load directories. -Account for `comp-load-path' and `comp-native-version-dir'." +Account for `comp-eln-load-path' and `comp-native-version-dir'." (mapcar (lambda (dir) (expand-file-name comp-native-version-dir (file-name-as-directory diff --git a/src/comp.c b/src/comp.c index 5eb7bf21066..857f798a8d8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5354,6 +5354,8 @@ For internal use. */); If a directory is non absolute is assumed to be relative to `invocation-directory'. +`comp-native-version-dir' value is used as a sub-folder name inside +each eln cache directory. The last directory of this list is assumed to be the system one. */); /* Temporary value in use for bootstrap. We can't do better as From 79b8b6ca45ad707d86244882430e275efd95cdb9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 26 Mar 2021 08:06:09 +0100 Subject: [PATCH 1405/1452] * Prevent stale eln loading checking file timestamp before load (bug#46617) * src/lread.c (maybe_swap_for_eln): Add file timestamp check. (openp): Update 'maybe_swap_for_eln' call sites. --- src/lread.c | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/src/lread.c b/src/lread.c index 56717dba810..e8c257a13cc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1649,7 +1649,8 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) If found replace the content of FILENAME and FD. */ static void -maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) +maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, + struct timespec mtime) { #ifdef HAVE_NATIVE_COMP struct stat eln_st; @@ -1686,13 +1687,19 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) emacs_close (eln_fd); else { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - src_name, Vcomp_eln_to_el_h); - return; + struct timespec eln_mtime = get_stat_mtime (&eln_st); + if (timespec_cmp (eln_mtime, mtime) >= 0) + { + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + src_name, Vcomp_eln_to_el_h); + return; + } + else + emacs_close (eln_fd); } } } @@ -1940,7 +1947,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - maybe_swap_for_eln (no_native, &string, &fd); + maybe_swap_for_eln (no_native, &string, &fd, + get_stat_mtime (&st)); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; @@ -1952,7 +1960,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); + maybe_swap_for_eln (no_native, &save_string, &save_fd, + save_mtime); if (storeptr) *storeptr = save_string; SAFE_FREE (); From aa159bf6963ef3f741bfbd787507405c02cc4974 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 31 Mar 2021 10:24:55 +0200 Subject: [PATCH 1406/1452] * lisp/emacs-lisp/comp.el (comp-debug): Fix docstring. --- lisp/emacs-lisp/comp.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0597837ebd0..2f9738a7e20 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -62,8 +62,8 @@ This is intended for debugging the compiler itself. 0 no debugging output. This is the recommended value unless you are debugging the compiler itself. 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." + 2 dump gcc passes. + 3 dump libgccjit log file." :type 'integer :safe #'natnump :version "28.1") From 613caa9527ef56fb9b810d2b9478cbe9784baca0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 31 Mar 2021 14:49:36 +0200 Subject: [PATCH 1407/1452] Do not defer compilation when bytecode is explicitly requested (bug#46617) * src/comp.c (maybe_defer_native_compilation): Check if the file is registered in 'V_comp_no_native_file_h'. (syms_of_comp): 'V_comp_no_native_file_h' new global. * src/lread.c (maybe_swap_for_eln): Register files in 'V_comp_no_native_file_h'. * lisp/faces.el (tty-run-terminal-initialization): Do not explicitly load .elc file to not exclude .eln being loaded in place. --- lisp/faces.el | 3 ++- src/comp.c | 10 +++++++++- src/lread.c | 6 ++++++ 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/lisp/faces.el b/lisp/faces.el index 42f4cddfb1b..68bfbbae384 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -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) diff --git a/src/comp.c b/src/comp.c index 857f798a8d8..b286f6077f3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4689,7 +4689,8 @@ maybe_defer_native_compilation (Lisp_Object function_name, || !NILP (Vpurify_flag) || !COMPILEDP (definition) || !STRINGP (Vload_true_file_name) - || !suffix_p (Vload_true_file_name, ".elc")) + || !suffix_p (Vload_true_file_name, ".elc") + || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil))) return; Lisp_Object src = @@ -5373,6 +5374,13 @@ This is used to prevent double trampoline instantiation but also to protect the trampolines against GC. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + DEFVAR_LISP ("comp-no-native-file-h", V_comp_no_native_file_h, + doc: /* Files for which no deferred compilation has to +be performed because the bytecode version was explicitly requested by +the user during load. +For internal use. */); + V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal); + Fprovide (intern_c_string ("nativecomp"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ diff --git a/src/lread.c b/src/lread.c index e8c257a13cc..ec6f09238ba 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1655,6 +1655,12 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, #ifdef HAVE_NATIVE_COMP struct stat eln_st; + 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")) From 53ca0d98441da75be49111a3a88c1a7629f27d6d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 31 Mar 2021 20:13:46 +0200 Subject: [PATCH 1408/1452] Rework native compilation `comp-debug' (bug#46495) * lisp/emacs-lisp/comp.el (comp-debug): Update docstring and move default on Windows systems from 0 to 1. * src/comp.c (Fcomp__compile_ctxt_to_file): Tweak debug levels. --- lisp/emacs-lisp/comp.el | 12 ++++++------ src/comp.c | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f9738a7e20..59e9dbc0138 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -56,14 +56,14 @@ :safe #'integerp :version "28.1") -(defcustom comp-debug 0 +(defcustom comp-debug (if (eq 'windows-nt system-type) 1 0) "Debug level for native compilation, a number between 0 and 3. This is intended for debugging the compiler itself. - 0 no debugging output. - This is the recommended value unless you are debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes. - 3 dump libgccjit log file." + 0 no debug output. + 1 emit debug symbols. + 2 emit debug symbols and dump pseudo C code. + 3 emit debug symbols and dump: pseudo C code, GCC intermediate + passes and libgccjit log file." :type 'integer :safe #'natnump :version "28.1") diff --git a/src/comp.c b/src/comp.c index b286f6077f3..a87a8f30c35 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4431,7 +4431,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); - if (comp.debug > 2) + if (comp.debug >= 3) { logfile = emacs_fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, @@ -4493,7 +4493,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, add_driver_options (); - if (comp.debug) + if (comp.debug >= 1) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (ebase_name)), 1); From 8e524f459149dfd83e2205d24c174074b10d5c6a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 31 Mar 2021 20:29:32 +0200 Subject: [PATCH 1409/1452] * lisp/emacs-lisp/comp.el (comp-final): Clean-up temporary file. --- lisp/emacs-lisp/comp.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 59e9dbc0138..213eb7b4126 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3666,7 +3666,9 @@ Prepare every function for final compilation and drive the C back-end." (call-process (expand-file-name invocation-name invocation-directory) nil t t "--batch" "-l" temp-file)) - output + (progn + (delete-file temp-file) + output) (signal 'native-compiler-error (buffer-string))) (comp-log-to-buffer (buffer-string)))))))) From 8d550700c535dbcd4721cc65c0a11decbf070abb Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 31 Mar 2021 22:11:08 +0300 Subject: [PATCH 1410/1452] * src/comp.c (Fcomp__compile_ctxt_to_file): Fix debug level 1. --- src/comp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index a87a8f30c35..eb734d5833d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4493,7 +4493,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, add_driver_options (); - if (comp.debug >= 1) + if (comp.debug > 1) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (ebase_name)), 1); From dc393517ca1cfef7770bffdfe2b7fd3c2c5e7bbf Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 1 Apr 2021 14:27:12 +0200 Subject: [PATCH 1411/1452] Issue a warning when eln look-up fails due to missing .el source file. * lisp/emacs-lisp/comp.el (comp-warning-on-missing-source): New customize. * src/lread.c (maybe_swap_for_eln): Issue a warning when eln look-up fails due to missing .el source file. * src/comp.c (syms_of_comp): Define 'Qcomp_warning_on_missing_source'. --- lisp/emacs-lisp/comp.el | 7 +++++++ src/comp.c | 3 ++- src/lread.c | 12 ++++++++++-- 3 files changed, 19 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 213eb7b4126..7f41a97f6b9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -180,6 +180,13 @@ the .eln output directory." :type 'boolean :version "28.1") +(defcustom comp-warning-on-missing-source t + "Emit a warning if a byte-code file being loaded has no corresponding source. +The source file is necessary for native code file look-up and deferred +compilation mechanism." + :type 'boolean + :version "28.1") + (defvar no-native-compile nil "Non-nil to prevent native-compiling of Emacs Lisp code. Note that when `no-byte-compile' is set to non-nil it overrides the value of diff --git a/src/comp.c b/src/comp.c index eb734d5833d..67c8e39315b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5254,7 +5254,8 @@ compiled one. */); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); DEFSYM (Qgccjit, "gccjit"); - DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install") + DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install"); + DEFSYM (Qcomp_warning_on_missing_source, "comp-warning-on-missing-source"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); diff --git a/src/lread.c b/src/lread.c index ec6f09238ba..156df73de82 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1674,8 +1674,16 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, { src_name = concat2 (src_name, build_string (".gz")); if (NILP (Ffile_exists_p (src_name))) - /* Can't find the corresponding source file. */ - return; + { + 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); From 978afd788fd0496540f715b83f18ed390ca8d5a4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 1 Apr 2021 22:15:08 +0200 Subject: [PATCH 1412/1452] * src/comp.h (unload_comp_unit): Define for vanilla build (warning removal). --- src/comp.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/comp.h b/src/comp.h index d01bc17565d..e17b843d139 100644 --- a/src/comp.h +++ b/src/comp.h @@ -98,6 +98,10 @@ 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 */ From 6f8ec1449197f1fcd730df91dddf6f7750284593 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Apr 2021 17:10:08 +0200 Subject: [PATCH 1413/1452] Output native compiled preloaded files into the 'preloaded' subfolder * src/comp.c (fixup_eln_load_path): Account the fact that the file can be dumped in the 'preloaded' subfolder. * lisp/loadup.el: Likewise. * src/lread.c (maybe_swap_for_eln1): New function. (maybe_swap_for_eln): Handle 'preloaded' subfolder. * src/Makefile.in (LISP_PRELOADED): Export preloaded files. --- lisp/loadup.el | 30 ++++++++++++-------- src/Makefile.in | 1 + src/comp.c | 29 +++++++++++++++----- src/lread.c | 73 +++++++++++++++++++++++++++++++------------------ 4 files changed, 89 insertions(+), 44 deletions(-) diff --git a/lisp/loadup.el b/lisp/loadup.el index 57058ac4aa1..c3948e465f2 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -465,17 +465,25 @@ lost after dumping"))) (when (subr-native-elisp-p f) (puthash (subr-native-comp-unit f) nil h))))) (maphash (lambda (cu _) - (native-comp-unit-set-file - cu - (cons - ;; Relative filename from the installed binary. - (file-relative-name (concat eln-dest-dir - (file-name-nondirectory - (native-comp-unit-file cu))) - bin-dest-dir) - ;; Relative filename from the built uninstalled binary. - (file-relative-name (native-comp-unit-file cu) - invocation-directory)))) + (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) diff --git a/src/Makefile.in b/src/Makefile.in index c6b1f556440..b8bad73b006 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -500,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. diff --git a/src/comp.c b/src/comp.c index 67c8e39315b..9bad9b9667f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4091,6 +4091,7 @@ for new compilations. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { + Lisp_Object source_filename = filename; filename = Fcomp_el_to_eln_rel_filename (filename); /* If base_dir was not specified search inside Vcomp_eln_load_path @@ -4129,9 +4130,18 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); - return Fexpand_file_name (filename, - Fexpand_file_name (Vcomp_native_version_dir, - base_dir)); + /* In case the file being compiled is found in 'LISP_PRELOADED' + target for output the 'preloaded' subfolder. */ + Lisp_Object lisp_preloaded = + Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil); + base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir); + if (!NILP (lisp_preloaded) + && !NILP (Fmember (CALL1I (file-name-base, source_filename), + Fmapcar (intern_c_string ("file-name-base"), + CALL1I (split-string, lisp_preloaded))))) + base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); + + return Fexpand_file_name (filename, base_dir); } DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, @@ -4750,10 +4760,15 @@ fixup_eln_load_path (Lisp_Object directory) Lisp_Object eln_cache_sys = Ffile_name_directory (concat2 (Vinvocation_directory, directory)); - /* One directory up... */ - eln_cache_sys = - Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, - make_fixnum (-1))); + bool preloaded = + !NILP (Fequal (Fsubstring (eln_cache_sys, make_fixnum (-10), + make_fixnum (-1)), + build_string ("preloaded"))); + /* One or two directories up... */ + for (int i = 0; i < (preloaded ? 2 : 1); i++) + eln_cache_sys = + Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, + make_fixnum (-1))); Fsetcar (last_cell, eln_cache_sys); } diff --git a/src/lread.c b/src/lread.c index 156df73de82..e53e1f65ab9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1645,6 +1645,40 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) 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. */ @@ -1653,7 +1687,6 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, struct timespec mtime) { #ifdef HAVE_NATIVE_COMP - struct stat eln_st; if (no_native || load_no_native) @@ -1687,36 +1720,24 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, } 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, - XCAR (eln_path_tail))); - 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) - { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - src_name, Vcomp_eln_to_el_h); - return; - } - else - emacs_close (eln_fd); - } - } + 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 } From 1ad0ecea2bbdfad9b543315a0ab28abcbfb1272f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 21 Mar 2021 09:15:25 +0100 Subject: [PATCH 1414/1452] * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Clean-up all .eln dirs. --- lisp/emacs-lisp/comp.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7f41a97f6b9..dfb945bb58d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3785,11 +3785,14 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. + for dir in (comp-eln-load-path-eff) do (cl-loop for f in (when (file-exists-p dir) (directory-files dir t regexp t)) - do (comp-delete-or-replace-file f))))) + ;; We may not be able to delete the file if we have no write + ;; permisison. + do (ignore-error file-error + (comp-delete-or-replace-file f)))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. From 9333bc48638127899dddc7796afd2df80441f494 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Apr 2021 20:54:55 +0200 Subject: [PATCH 1415/1452] * src/comp.c (Fcomp_el_to_eln_filename): Fix doc. --- src/comp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/comp.c b/src/comp.c index 9bad9b9667f..c167aaa9444 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4088,7 +4088,8 @@ DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, doc: /* Return the .eln filename for source FILENAME to used for new compilations. -If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) +If BASE-DIR is non-nil use it as a base directory, look for a suitable +directory in `comp-eln-load-path' otherwise. */) (Lisp_Object filename, Lisp_Object base_dir) { Lisp_Object source_filename = filename; From 39bc9bc77066c0c40d2e5fd0769ce3701055a10b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 4 Apr 2021 22:45:36 +0200 Subject: [PATCH 1416/1452] * src/comp.c (fixup_eln_load_path): Fix parameter name. --- src/comp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/comp.c b/src/comp.c index c167aaa9444..6817fe2f92e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4750,7 +4750,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Fixup the system eln-cache dir. This is the last entry in `comp-eln-load-path'. */ void -fixup_eln_load_path (Lisp_Object directory) +fixup_eln_load_path (Lisp_Object eln_filename) { Lisp_Object last_cell = Qnil; Lisp_Object tmp = Vcomp_eln_load_path; @@ -4760,7 +4760,7 @@ fixup_eln_load_path (Lisp_Object directory) Lisp_Object eln_cache_sys = Ffile_name_directory (concat2 (Vinvocation_directory, - directory)); + eln_filename)); bool preloaded = !NILP (Fequal (Fsubstring (eln_cache_sys, make_fixnum (-10), make_fixnum (-1)), From 0a3e715e1f5e13874139b4678375b8f5704b800b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 5 Apr 2021 20:56:28 +0200 Subject: [PATCH 1417/1452] * Introduce `comp-file-preloaded-p' * src/comp.c (syms_of_comp): Define `comp-file-preloaded-p'. (Fcomp_el_to_eln_filename): Account for `comp-file-preloaded-p'. --- src/comp.c | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 6817fe2f92e..c4b9b4b6c10 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4131,16 +4131,18 @@ directory in `comp-eln-load-path' otherwise. */) if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); - /* In case the file being compiled is found in 'LISP_PRELOADED' - target for output the 'preloaded' subfolder. */ + /* In case the file being compiled is found in 'LISP_PRELOADED' or + `comp-file-preloaded-p' is non-nil target for output the + 'preloaded' subfolder. */ Lisp_Object lisp_preloaded = Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil); base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir); - if (!NILP (lisp_preloaded) - && !NILP (Fmember (CALL1I (file-name-base, source_filename), - Fmapcar (intern_c_string ("file-name-base"), - CALL1I (split-string, lisp_preloaded))))) - base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); + if (comp_file_preloaded_p + || (!NILP (lisp_preloaded) + && !NILP (Fmember (CALL1I (file-name-base, source_filename), + Fmapcar (intern_c_string ("file-name-base"), + CALL1I (split-string, lisp_preloaded)))))) + base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); return Fexpand_file_name (filename, base_dir); } @@ -5398,6 +5400,10 @@ the user during load. For internal use. */); V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal); + DEFVAR_BOOL ("comp-file-preloaded-p", comp_file_preloaded_p, + doc: /* When non-nil assume the file being compiled to +be preloaded. */); + Fprovide (intern_c_string ("nativecomp"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ From 7bf141e944583929a77baf859cc711ba7c80f91e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Apr 2021 16:19:58 +0200 Subject: [PATCH 1418/1452] ; * Add myself to MAINTAINERS file --- admin/MAINTAINERS | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index 53afe87a0f8..5dc88719edc 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -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. From 320f5390567016b5287d15416853e5421e9c2f3a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Apr 2021 17:01:25 +0200 Subject: [PATCH 1419/1452] ; * etc/TODO (pdump): Add a note about native compiler and re-dumping. --- etc/TODO | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/etc/TODO b/etc/TODO index 9448617626d..f806b6ca4f1 100644 --- a/etc/TODO +++ b/etc/TODO @@ -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. From 02724cc2fc606c583faf33ae58ea7c67bfc1485f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Apr 2021 18:27:04 +0200 Subject: [PATCH 1420/1452] ; * admin/MAINTAINERS: Tabify last change. --- admin/MAINTAINERS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index 5dc88719edc..02b8cf39bd6 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -132,8 +132,8 @@ Amin Bandali doc/misc/erc.texi Andrea Corallo - Lisp native compiler - src/comp.c + Lisp native compiler + src/comp.c lisp/emacs-lisp/comp.el lisp/emacs-lisp/comp-cstr.el test/src/comp-*.el From b77575198c4395b9345ad6694d7fb1fe23aeace6 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Apr 2021 21:02:58 +0200 Subject: [PATCH 1421/1452] ; * lisp/loadup.el: Fix comment. --- lisp/loadup.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/loadup.el b/lisp/loadup.el index c3948e465f2..650288f9f86 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -452,7 +452,7 @@ lost after dumping"))) (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 cons cell of the form: + ;; 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))) From 65681982134d973ee6bc78b627866e2ca4e242e7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Apr 2021 21:13:47 +0200 Subject: [PATCH 1422/1452] * src/pdumper.c (dump_do_dump_relocation): Use `expand-file-name'. --- src/pdumper.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index e266b35ca67..9b750a33f36 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5277,7 +5277,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (installation_state == UNKNOWN) { Lisp_Object fname = - concat2 (Vinvocation_directory, XCAR (comp_u->file)); + Fexpand_file_name (XCAR (comp_u->file), Vinvocation_directory); FILE *file; if ((file = emacs_fopen (SSDATA (ENCODE_FILE (fname)), "r"))) { @@ -5293,9 +5293,9 @@ dump_do_dump_relocation (const uintptr_t dump_base, } comp_u->file = - concat2 (Vinvocation_directory, - installation_state == INSTALLED - ? XCAR (comp_u->file) : XCDR (comp_u->file)); + Fexpand_file_name (installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file), + Vinvocation_directory); comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); From 208ffc284c7f492151c1d2f76845cefea7a35341 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 6 Apr 2021 21:40:15 +0200 Subject: [PATCH 1423/1452] * .gitlab-ci.yml: Move native-comp tests into 'slow' stage. --- .gitlab-ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index acc1649bdab..cf2cf3e3599 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -136,7 +136,7 @@ test-filenotify-gio: test-native-bootstrap-speed0: # Test a full native bootstrap # Run for now only speed 0 to limit memory usage and compilation time. - stage: test + stage: slow # Uncomment the following to run it only when sceduled. # only: # - schedules @@ -148,7 +148,7 @@ test-native-bootstrap-speed0: timeout: 8 hours test-native-bootstrap-speed1: - stage: test + stage: slow script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf @@ -157,7 +157,7 @@ test-native-bootstrap-speed1: timeout: 8 hours test-native-bootstrap-speed2: - stage: test + stage: slow script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf From ce15b23846cd82acccb6ce5dd13b0a42f487296b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Apr 2021 09:50:02 +0200 Subject: [PATCH 1424/1452] * Makefile.in (BIN_DESTDIR, src): Fix 'BIN_DESTDIR' on MacOS. --- Makefile.in | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Makefile.in b/Makefile.in index aa32ec8bc5e..e318db746d6 100644 --- a/Makefile.in +++ b/Makefile.in @@ -321,6 +321,11 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" +ifeq (${ns_self_contained},no) +BIN_DESTDIR='$(DESTDIR)${bindir}/' +else +BIN_DESTDIR='${ns_appbindir}/' +endif ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ all: ${SUBDIR} info @@ -416,7 +421,7 @@ lib lib-src lisp nt: Makefile dirstate = .git/logs/HEAD VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate)) src: Makefile - $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(DESTDIR)${bindir}/' \ + $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(BIN_DESTDIR)' \ ELN_DESTDIR='$(ELN_DESTDIR)' all blessmail: Makefile src From c35a515a2f7045f004299f601f6d1927ea16cd47 Mon Sep 17 00:00:00 2001 From: Alan Third Date: Fri, 2 Apr 2021 18:06:59 +0100 Subject: [PATCH 1425/1452] Fix install with NS app bundle * configure.ac: Set up CFLAGS and LDFLAGS to find a Homebrew installation of libgccjit. * Makefile.in (ELN_DESTDIR): Set to the app bundle resource dir when required. (install-eln): macOS install doesn't support the -D flag, so make the directories separately. --- Makefile.in | 6 ++++-- configure.ac | 10 ++++++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/Makefile.in b/Makefile.in index e318db746d6..efe89b9b93e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -323,10 +323,11 @@ 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 -ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ all: ${SUBDIR} info @@ -752,7 +753,8 @@ install-etc: ### Install native compiled Lisp files. install-eln: ifeq ($(HAVE_NATIVE_COMP),yes) - find native-lisp -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; + 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. diff --git a/configure.ac b/configure.ac index 4284c997141..698e8affb51 100644 --- a/configure.ac +++ b/configure.ac @@ -3801,6 +3801,16 @@ if test "${with_native_compilation}" != "no"; then 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 + CFLAGS="$CFLAGS -I${BREW_LIBGCCJIT_PREFIX}/include" + LDFLAGS="$LDFLAGS -L${BREW_LIBGCCJIT_PREFIX}/lib/gcc/10 -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]) From db2a226fc4ec6cfb28663774aee66793eb6f6224 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Apr 2021 14:09:44 +0200 Subject: [PATCH 1426/1452] Move gitlab-ci native-comp tests into '/test/infra/gitlab-ci.yml' * .gitlab-ci.yml: Fix incorrect b8d3ae78c5 merge. * test/infra/gitlab-ci.yml (test-native-bootstrap-speed0) (test-native-bootstrap-speed1, test-native-bootstrap-speed2): Move from .gitlab-ci.yml. --- .gitlab-ci.yml | 170 --------------------------------------- test/infra/gitlab-ci.yml | 32 ++++++++ 2 files changed, 32 insertions(+), 170 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index cf2cf3e3599..3138f4184e6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -24,175 +24,5 @@ # Maintainer: Ted Zlatanov # URL: https://emba.gnu.org/emacs/emacs -# Never run merge request pipelines, they usually duplicate push pipelines -# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules -workflow: - rules: - - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' - when: never - - when: always - -variables: - GIT_STRATEGY: fetch - EMACS_EMBA_CI: 1 - -default: - image: docker:19.03.12 - timeout: 3 hours - before_script: - - docker info - -.job-template: - # these will be cached across builds - cache: - key: ${CI_COMMIT_REF_SLUG} - paths: [] - policy: pull-push - # these will be saved for followup builds - artifacts: - expire_in: 24 hrs - paths: [] - # - "test/**/*.log" - # - "**/*.log" - -.test-template: - rules: - - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**/*.el - - src/*.{h,c} - - test/infra/* - - test/lisp/**/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**/w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - - # using the variables for each job - script: - - docker build --target ${target} -t ${target}:${CI_COMMIT_REF_SLUG} -t ${target}:${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba . - # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${target}:${CI_COMMIT_SHA} make ${make_params} - -stages: - - fast - - normal - - slow - -test-fast: - stage: fast - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check" - -test-lisp: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp" - -test-net: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-net" - -test-filenotify-gio: - # This tests file monitor libraries gfilemonitor and gio. - stage: normal - extends: [.job-template, .test-template] - rules: - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/infra/* - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el - variables: - target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests filenotify-tests" - -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: normal - extends: [.job-template, .test-template] - rules: - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - configure.ac - - src/ns*.{h,m} - - src/macfont.{h,m} - - lisp/term/ns-win.el - - nextstep/**/* - - test/infra/* - variables: - target: emacs-gnustep - make_params: install - -test-all: - # This tests also file monitor libraries inotify and inotifywatch. - stage: slow - extends: [.job-template, .test-template] - rules: - # note there's no "changes" section, so this always runs on a schedule - - if: '$CI_PIPELINE_SOURCE == "schedule"' - variables: - target: emacs-inotify - make_params: check-expensive # Just load from test/infra, to keep build automation files there. include: '/test/infra/gitlab-ci.yml' diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 6355513cc9f..b740f43402d 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -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 From 1f8d75160a27396da363384018a362e04aaea0bd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 7 Apr 2021 15:25:57 +0200 Subject: [PATCH 1427/1452] * Improve some docstring in comp.el * lisp/emacs-lisp/comp.el (comp--native-compile) (batch-native-compile, batch-byte-native-compile-for-bootstrap): Improve docstring. --- lisp/emacs-lisp/comp.el | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dfb945bb58d..b5c9cb58260 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3962,9 +3962,11 @@ display a message." (defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. -This serves as internal implementation of `native-compile'. When WITH-LATE-LOAD is non-nil, mark the compilation unit for late -load once it finishes compiling." +load once it finishes compiling. +This serves as internal implementation of `native-compile' but +allowing for WITH-LATE-LOAD to be controlled is in use also for +the deferred compilation mechanism." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -4142,8 +4144,10 @@ form, return the compiled function." ;;;###autoload (defun batch-native-compile () - "Run `native-compile' on remaining command-line arguments. -Ultra cheap impersonation of `batch-byte-compile'." + "Perform native compilation on remaining command-line arguments. +Use this from the command line, with ‘-batch’; +it won’t work in an interactive Emacs. +Native compilation equivalent to `batch-byte-compile'." (comp-ensure-native-compiler) (cl-loop for file in command-line-args-left if (or (null byte-native-for-bootstrap) @@ -4156,8 +4160,11 @@ Ultra cheap impersonation of `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () "Like `batch-native-compile', but used for booststrap. -Generate *.elc files in addition to the *.eln files. If the -environment variable 'NATIVE_DISABLED' is set, only byte compile." +Generate .elc files in addition to the .eln files. +Force the produced .eln to be outputted in the eln system +directory (the last entry in `comp-eln-load-path'). +If the environment variable 'NATIVE_DISABLED' is set, only byte +compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) From a9b9ada6bf5e07da75ddeba6fd985e28987b767b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 7 Apr 2021 19:43:59 +0300 Subject: [PATCH 1428/1452] Fix crash on MS-Windows caused by recent changes * src/pdumper.c (dump_do_dump_relocation): Don't use expand-file-name, as this crashes on MS-Windows. Use file_access_p instead of emacs_fopen. --- src/pdumper.c | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 9b750a33f36..dc893c59bfa 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5276,12 +5276,13 @@ dump_do_dump_relocation (const uintptr_t dump_base, /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) { + /* Can't use expand-file-name here, because we are too + early in the startup, and we will crash at least on + WINDOWSNT. */ Lisp_Object fname = - Fexpand_file_name (XCAR (comp_u->file), Vinvocation_directory); - FILE *file; - if ((file = emacs_fopen (SSDATA (ENCODE_FILE (fname)), "r"))) + concat2 (Vinvocation_directory, XCAR (comp_u->file)); + if (file_access_p (SSDATA (ENCODE_FILE (fname)), F_OK)) { - fclose (file); installation_state = INSTALLED; fixup_eln_load_path (XCAR (comp_u->file)); } @@ -5293,10 +5294,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } comp_u->file = - Fexpand_file_name (installation_state == INSTALLED - ? XCAR (comp_u->file) : XCDR (comp_u->file), - Vinvocation_directory); - comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + concat2 (Vinvocation_directory, + installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file)); + comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (comp_u->file))); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); From 8ed46b7646de7166aa8bbd3b5d29a4947316c900 Mon Sep 17 00:00:00 2001 From: Alan Third Date: Wed, 7 Apr 2021 19:02:56 +0100 Subject: [PATCH 1429/1452] Remove hardcoded gcc version * configure.ac: Use 'find' to find the brew installed libgccjit libs instead of a hardcoded path. --- configure.ac | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 698e8affb51..3892eaed64b 100644 --- a/configure.ac +++ b/configure.ac @@ -3806,8 +3806,10 @@ if test "${with_native_compilation}" != "no"; then 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_LIBGCCJIT_PREFIX}/lib/gcc/10 -I${BREW_LIBGCCJIT_PREFIX}/include" + LDFLAGS="$LDFLAGS -L${brew_libdir} -I${BREW_LIBGCCJIT_PREFIX}/include" fi fi From 3062480309b0d3bd66370265ed1a1dc79b6edeed Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 12 Apr 2021 16:42:01 +0200 Subject: [PATCH 1430/1452] * lisp/emacs-lisp/comp-cstr.el (comp-normalize-valset): Remove duplicates. --- lisp/emacs-lisp/comp-cstr.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 7f5d34b45c3..b2d34af66b4 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -186,12 +186,14 @@ Return them as multiple value." ;;; Value handling. (defun comp-normalize-valset (valset) - "Sort VALSET and return it." - (cl-sort valset (lambda (x y) - ;; We might want to use `sxhash-eql' for speed but - ;; this is safer to keep tests stable. - (< (sxhash-equal x) - (sxhash-equal y))))) + "Sort and remove duplicates from VALSET then return it." + (cl-remove-duplicates + (cl-sort valset (lambda (x y) + ;; We might want to use `sxhash-eql' for speed but + ;; this is safer to keep tests stable. + (< (sxhash-equal x) + (sxhash-equal y)))) + :test #'eq)) (defun comp-union-valsets (&rest valsets) "Union values present into VALSETS." From 70adc28e9798abede5dd8c137c1543b46af6eacc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 13 Apr 2021 10:38:00 +0200 Subject: [PATCH 1431/1452] * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): (not null) => t. --- lisp/emacs-lisp/comp-cstr.el | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index b2d34af66b4..5b189e70bef 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -631,7 +631,15 @@ DST is returned." (setf (typeset dst) (typeset neg) (valset dst) (valset neg) (range dst) (range neg) - (neg dst) (neg neg)))))) + (neg dst) (neg neg))))) + + ;; (not null) => t + (when (and (neg dst) + (null (typeset dst)) + (null (valset dst)) + (null (range dst))) + (give-up))) + dst))) (defun comp-cstr-union-1 (range dst &rest srcs) From 2d23f19e7d5ff8a1ec1a188dcd530c185029d1f8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 13 Apr 2021 10:38:14 +0200 Subject: [PATCH 1432/1452] * Fix two comp-cstr tests * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Fix test 53 70. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index f2d9bf583e5..c2492b93f6f 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -147,7 +147,7 @@ ;; 52 Conservative. ((or (member foo) (not string)) . (not string)) ;; 53 - ((or (not (integer 1 2)) integer) . integer) + ((or (not (integer 1 2)) integer) . t) ;; 54 ((or (not (integer 1 2)) (not integer)) . (not integer)) ;; 55 @@ -181,7 +181,7 @@ ;; 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 b a))) + ((and (not (member a)) (not (member b))) . (not (member a b))) ;; 71 ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) ;; 72 From 0c1fc9d581ad64efc96c1efccbb4d057796ef807 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 14 Apr 2021 15:04:19 +0200 Subject: [PATCH 1433/1452] * Fix native-comp startup for symliked binary (bug#44128) * src/emacs.c (real_filename): New function. (set_invocation_vars, load_pdump): Make use of. --- src/emacs.c | 36 +++++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index e5940ce1de6..f0d75f5c20d 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -440,6 +440,28 @@ terminate_due_to_signal (int sig, int backtrace_limit) exit (1); } +/* Return the real filename following symlinks in case. + The caller should deallocate the returned buffer. */ + +static char * +real_filename (char *filename) +{ + char *real_name; +#ifdef WINDOWSNT + /* w32_my_exename resolves symlinks internally, so no need to + call realpath. */ + real_name = xmalloc (strlen (filename)); + strcpy (real_name, filename); + return real_name; +#else + real_name = realpath (filename, NULL); + if (!real_name) + fatal ("could not resolve realpath of \"%s\": %s", + filename, strerror (errno)); + return real_name; +#endif +} + /* Set `invocation-name' `invocation-directory'. */ static void @@ -475,6 +497,10 @@ set_invocation_vars (char *argv0, char const *original_pwd) if (! NILP (handler)) raw_name = concat2 (slash_colon, raw_name); + char *filename = real_filename (SSDATA (raw_name)); + raw_name = build_unibyte_string (filename); + xfree (filename); + Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); @@ -888,17 +914,9 @@ load_pdump (int argc, char **argv, char const *original_pwd) the dump in the hardcoded location. */ if (dump_file && *dump_file) { -#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)); + char *real_exename = real_filename (dump_file); xfree (dump_file); dump_file = real_exename; -#endif ptrdiff_t exenamelen = strlen (dump_file); #ifndef WINDOWSNT bufsize = exenamelen + 1; From 95dd6bb08038e31515568943dcfae13afac8ff70 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 14 Apr 2021 17:28:19 +0300 Subject: [PATCH 1434/1452] Fix MS-Windows build following last change * src/emacs.c (real_filename) [WINDOWSNT]: Fix off-by-one error when allocating storage for a file name. --- src/emacs.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index f0d75f5c20d..a2565645c6c 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -450,16 +450,14 @@ real_filename (char *filename) #ifdef WINDOWSNT /* w32_my_exename resolves symlinks internally, so no need to call realpath. */ - real_name = xmalloc (strlen (filename)); - strcpy (real_name, filename); - return real_name; + real_name = xstrdup (filename); #else real_name = realpath (filename, NULL); if (!real_name) fatal ("could not resolve realpath of \"%s\": %s", filename, strerror (errno)); - return real_name; #endif + return real_name; } /* Set `invocation-name' `invocation-directory'. */ From bfaa6df492c85d7de007cf69316cbdeea653d703 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 14 Apr 2021 20:00:04 +0200 Subject: [PATCH 1435/1452] * configure.ac: Fix native-comp FreeBSD build. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index a47871fbd89..0e91a49488c 100644 --- a/configure.ac +++ b/configure.ac @@ -3826,7 +3826,7 @@ if test "${with_native_compilation}" != "no"; then # mingw32 loads the library dynamically. mingw32) ;; # OpenBSD doesn't have libdl, all the functions are in libc - openbsd) + freebsd|openbsd) LIBGCCJIT_LIB="-lgccjit" ;; *) LIBGCCJIT_LIB="-lgccjit -ldl" ;; From 686259e65aa7121683c0c65e45ce48adb08ddb58 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 14 Apr 2021 23:58:23 +0200 Subject: [PATCH 1436/1452] * configure.ac: Revert prev commit and fix native-comp NetBSD build. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 0e91a49488c..3298032311f 100644 --- a/configure.ac +++ b/configure.ac @@ -3826,7 +3826,7 @@ if test "${with_native_compilation}" != "no"; then # mingw32 loads the library dynamically. mingw32) ;; # OpenBSD doesn't have libdl, all the functions are in libc - freebsd|openbsd) + netbsd|openbsd) LIBGCCJIT_LIB="-lgccjit" ;; *) LIBGCCJIT_LIB="-lgccjit -ldl" ;; From f9c1008ced59f003d48dd7be39e9ec4aa0f02484 Mon Sep 17 00:00:00 2001 From: Ashish SHUKLA Date: Fri, 16 Apr 2021 11:13:09 +0200 Subject: [PATCH 1437/1452] * lisp/emacs-lisp/comp.el (comp-effective-async-max-jobs): Handle BSD. --- lisp/emacs-lisp/comp.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5c9cb58260..0122008fc9e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3860,6 +3860,9 @@ processes from `comp-async-compilations'" ((executable-find "nproc") (string-to-number (shell-command-to-string "nproc"))) + ((eq 'berkeley-unix system-type) + (string-to-number + (shell-command-to-string "sysctl -n hw.ncpu"))) (t 1)) 2)))) comp-async-jobs-number)) From 9aa5203b542f0c9ea7d074c6cfde2a28b466f5d1 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Apr 2021 16:49:16 +0300 Subject: [PATCH 1438/1452] Fix loading *.eln files when Emacs is installed via symlinks * src/emacs.c (real_filename, set_invocation_vars) (init_vars_for_load): Functions deleted; callers adjusted. (init_cmdargs): Put back all the code which was extracted into set_invocation_vars. (load_pdump_find_executable): Make sure the return value has any symlinks in it expanded. (load_pdump): Accept only 2 arguments, not 3. Determine both the file name of the Emacs executable and of the dump file in synchronized manner, so that if we decided to look for the dump file in its hardcoded installation directory, the directory of the Emacs executable will also be where we expect it to be installed. Pass only 2 arguments to pdumper_load. (Bug#47800) (Bug#44128) * src/pdumper.c (dump_do_dump_relocation): Use emacs_execdir instead of Vinvocation_directory to produce absolute file names of *.eln files that are recorded in the pdumper file. Pass the full .eln file name to fixup_eln_load_path. (pdumper_set_emacs_execdir) [HAVE_NATIVE_COMP]: New function. (pdumper_load) [HAVE_NATIVE_COMP]: Call pdumper_set_emacs_execdir. * src/comp.c (fixup_eln_load_path): Use Fsubstring_no_properties instead of Fsubstring. No need to cons a file name, as the caller already did that. Use explicit const string to avoid "magic" values. * lisp/startup.el (normal-top-level): Use expand-file-name instead of concat. Decode comp-eln-load-path and expand-file-name its members. --- lisp/startup.el | 13 ++- src/comp.c | 33 ++++---- src/comp.h | 6 +- src/emacs.c | 217 ++++++++++++++++++++---------------------------- src/lisp.h | 1 - src/pdumper.c | 93 ++++++++++++++++----- src/pdumper.h | 3 +- 7 files changed, 196 insertions(+), 170 deletions(-) diff --git a/lisp/startup.el b/lisp/startup.el index 6e0faf3f68a..01d28141654 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -544,7 +544,8 @@ It is the default value of the variable `top-level'." (dolist (path (split-string path-env path-separator)) (unless (string= "" path) (push path comp-eln-load-path))))) - (push (concat user-emacs-directory "eln-cache/") 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. @@ -636,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 diff --git a/src/comp.c b/src/comp.c index c4b9b4b6c10..50947316df8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4749,29 +4749,30 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Functions used to load eln files. */ /**************************************/ -/* Fixup the system eln-cache dir. This is the last entry in - `comp-eln-load-path'. */ +/* Fixup the system eln-cache directory, which is the last entry in + `comp-eln-load-path'. Argument is a .eln file in that directory. */ void fixup_eln_load_path (Lisp_Object eln_filename) { Lisp_Object last_cell = Qnil; - Lisp_Object tmp = Vcomp_eln_load_path; - FOR_EACH_TAIL (tmp) - if (CONSP (tmp)) - last_cell = tmp; + Lisp_Object tem = Vcomp_eln_load_path; + FOR_EACH_TAIL (tem) + if (CONSP (tem)) + last_cell = tem; - Lisp_Object eln_cache_sys = - Ffile_name_directory (concat2 (Vinvocation_directory, - eln_filename)); - bool preloaded = - !NILP (Fequal (Fsubstring (eln_cache_sys, make_fixnum (-10), - make_fixnum (-1)), - build_string ("preloaded"))); + const char preloaded[] = "preloaded"; + ptrdiff_t preloaded_len = sizeof (preloaded) - 1; + Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename); + bool preloaded_p = + !NILP (Fequal (Fsubstring_no_properties (eln_cache_sys, + make_fixnum (-preloaded_len - 1), + make_fixnum (-1)), + build_string (preloaded))); /* One or two directories up... */ - for (int i = 0; i < (preloaded ? 2 : 1); i++) + for (int i = 0; i < (preloaded_p ? 2 : 1); i++) eln_cache_sys = - Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, - make_fixnum (-1))); + Ffile_name_directory (Fsubstring_no_properties (eln_cache_sys, Qnil, + make_fixnum (-1))); Fsetcar (last_cell, eln_cache_sys); } diff --git a/src/comp.h b/src/comp.h index e17b843d139..03d22dfaa0e 100644 --- a/src/comp.h +++ b/src/comp.h @@ -34,7 +34,11 @@ enum { struct Lisp_Native_Comp_Unit { union vectorlike_header header; - /* Original eln file loaded. */ + /* 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 diff --git a/src/emacs.c b/src/emacs.c index a2565645c6c..d27b1c1351d 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -440,53 +440,33 @@ terminate_due_to_signal (int sig, int backtrace_limit) exit (1); } -/* Return the real filename following symlinks in case. - The caller should deallocate the returned buffer. */ - -static char * -real_filename (char *filename) -{ - char *real_name; -#ifdef WINDOWSNT - /* w32_my_exename resolves symlinks internally, so no need to - call realpath. */ - real_name = xstrdup (filename); -#else - real_name = realpath (filename, NULL); - if (!real_name) - fatal ("could not resolve realpath of \"%s\": %s", - filename, strerror (errno)); -#endif - return real_name; -} - -/* Set `invocation-name' `invocation-directory'. */ - + +/* Code for dealing with Lisp access to the Unix command line. */ static void -set_invocation_vars (char *argv0, char const *original_pwd) +init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) { - Lisp_Object raw_name, handler; + int i; + Lisp_Object name, dir, handler; + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object raw_name; AUTO_STRING (slash_colon, "/:"); + initial_argv = argv; + initial_argc = argc; + #ifdef WINDOWSNT - /* Must use argv0 converted to UTF-8, as it begets many standard + /* Must use argv[0] converted to UTF-8, as it begets many standard file and directory names. */ { - char argv0_1[MAX_UTF8_PATH]; + char argv0[MAX_UTF8_PATH]; - /* Avoid calling 'openp' below, as we aren't ready for that yet: - emacs_dir is not yet defined in the environment, and therefore - emacs_root_dir, called by expand-file-name, will abort. */ - if (!IS_ABSOLUTE_FILE_NAME (argv0)) - argv0 = w32_my_exename (); - - if (filename_from_ansi (argv0, argv0_1) == 0) - raw_name = build_unibyte_string (argv0_1); - else + if (filename_from_ansi (argv[0], argv0) == 0) raw_name = build_unibyte_string (argv0); + else + raw_name = build_unibyte_string (argv[0]); } #else - raw_name = build_unibyte_string (argv0); + raw_name = build_unibyte_string (argv[0]); #endif /* Add /: to the front of the name @@ -495,26 +475,16 @@ set_invocation_vars (char *argv0, char const *original_pwd) if (! NILP (handler)) raw_name = concat2 (slash_colon, raw_name); - char *filename = real_filename (SSDATA (raw_name)); - raw_name = build_unibyte_string (filename); - xfree (filename); - Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); -#ifdef WINDOWSNT - eassert (!NILP (Vinvocation_directory) - && !NILP (Ffile_name_absolute_p (Vinvocation_directory))); -#endif - - /* If we got no directory in argv0, search PATH to find where + /* If we got no directory in argv[0], search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) { Lisp_Object found; - int yes = - openp (Vexec_path, Vinvocation_name, Vexec_suffixes, &found, - make_fixnum (X_OK), false, 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 @@ -536,38 +506,6 @@ set_invocation_vars (char *argv0, char const *original_pwd) Vinvocation_directory = Fexpand_file_name (Vinvocation_directory, odir); } -} - -/* Initialize a number of variables (ultimately - 'Vinvocation_directory') needed by pdumper to complete native code - load. */ - -void -init_vars_for_load (char *argv0, char const *original_pwd) -{ - /* This function is called from within pdumper while loading (as - soon as we are able to allocate) or later during boot if pdumper - is not used. No need to run it twice. */ - static bool double_run_guard; - if (double_run_guard) - return; - double_run_guard = true; - - init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */ - set_invocation_vars (argv0, original_pwd); -} - - -/* 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) -{ - int i; - Lisp_Object name, dir; - ptrdiff_t count = SPECPDL_INDEX (); - - initial_argv = argv; - initial_argc = argc; Vinstallation_directory = Qnil; @@ -801,6 +739,8 @@ 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; @@ -846,7 +786,19 @@ 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) + return real_name; + } + return candidate; + } *candidate = '\0'; } while (*path++ != '\0'); @@ -856,10 +808,11 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) } static void -load_pdump (int argc, char **argv, char const *original_pwd) +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" @@ -889,9 +842,19 @@ load_pdump (int argc, char **argv, char const *original_pwd) 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, argv[0], original_pwd); + result = pdumper_load (dump_file, emacs_executable); if (result != PDUMPER_LOAD_SUCCESS) fatal ("could not load dump file \"%s\": %s", @@ -905,42 +868,29 @@ load_pdump (int argc, char **argv, char const *original_pwd) 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) { - char *real_exename = real_filename (dump_file); - xfree (dump_file); - dump_file = real_exename; - 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, argv[0], original_pwd); - 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 "%emacs_dir%", so it will never work without some tweaking. */ @@ -951,11 +901,11 @@ load_pdump (int argc, char **argv, char const *original_pwd) "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); @@ -963,7 +913,19 @@ load_pdump (int argc, char **argv, char const *original_pwd) } sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file, argv[0], original_pwd); + /* Assume the Emacs binary lives in a sibling directory as set up by + the default installation configuration. */ + const char *go_up = "../../../../bin/"; + needed += strlen (strip_suffix) - 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); + result = pdumper_load (dump_file, emacs_executable); if (result == PDUMPER_LOAD_FILE_NOT_FOUND) { @@ -998,7 +960,7 @@ load_pdump (int argc, char **argv, char const *original_pwd) #endif sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file, argv[0], original_pwd); + result = pdumper_load (dump_file, emacs_executable); } if (result != PDUMPER_LOAD_SUCCESS) @@ -1010,6 +972,7 @@ load_pdump (int argc, char **argv, char const *original_pwd) out: xfree (dump_file); + xfree (emacs_executable); } #endif /* HAVE_PDUMPER */ @@ -1320,10 +1283,9 @@ main (int argc, char **argv) w32_init_main_thread (); #endif - emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (attempt_load_pdump) - load_pdump (argc, argv, emacs_wd); + load_pdump (argc, argv); #endif argc = maybe_disable_address_randomization (argc, argv); @@ -1395,6 +1357,7 @@ main (int argc, char **argv) exit (0); } + emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) pdumper_record_wd (emacs_wd); @@ -2038,8 +2001,6 @@ 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_vars_for_load (argv[0], original_pwd); - /* Must precede init_lread. */ init_cmdargs (argc, argv, skip_args, original_pwd); diff --git a/src/lisp.h b/src/lisp.h index 474e49c8e1e..f83c55f827d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4450,7 +4450,6 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); -extern void init_vars_for_load (char *, char const *); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif diff --git a/src/pdumper.c b/src/pdumper.c index dc893c59bfa..c9285ddbc78 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -4356,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 { @@ -5269,35 +5279,54 @@ dump_do_dump_relocation (const uintptr_t dump_base, 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 (!CONSP (comp_u->file)) + 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) { - /* Can't use expand-file-name here, because we are too - early in the startup, and we will crash at least on - WINDOWSNT. */ - Lisp_Object fname = - concat2 (Vinvocation_directory, XCAR (comp_u->file)); - if (file_access_p (SSDATA (ENCODE_FILE (fname)), F_OK)) - { - installation_state = INSTALLED; - fixup_eln_load_path (XCAR (comp_u->file)); - } + 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 (XCDR (comp_u->file)); } + 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); } - comp_u->file = - concat2 (Vinvocation_directory, - installation_state == INSTALLED - ? XCAR (comp_u->file) : XCDR (comp_u->file)); - comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (comp_u->file))); + comp_u->file = eln_fname; + comp_u->handle = dynlib_open (SSDATA (eln_fname)); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); @@ -5435,6 +5464,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, @@ -5451,7 +5500,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, char *argv0, char const *original_pwd) +pdumper_load (const char *dump_filename, char *argv0) { intptr_t dump_size; struct stat stat; @@ -5607,9 +5656,11 @@ pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); - /* Once we can allocate and before loading .eln files we must set - Vinvocation_directory (.eln paths are relative to it). */ - init_vars_for_load (argv0, original_pwd); +#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); diff --git a/src/pdumper.h b/src/pdumper.h index 49e6739b0dc..deec9af046d 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -140,8 +140,7 @@ enum pdumper_load_result PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */ }; -int pdumper_load (const char *dump_filename, char *argv0, - char const *original_pwd); +int pdumper_load (const char *dump_filename, char *argv0); struct pdumper_loaded_dump { From cb4c41f0621887172f4ababbbe65ceadb01581ec Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Apr 2021 17:29:17 +0300 Subject: [PATCH 1439/1452] * emacs.c (load_pdump): Fix compilation on picky-complier platforms. --- src/emacs.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/emacs.c b/src/emacs.c index d27b1c1351d..2fc93631c9e 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -820,6 +820,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) @@ -891,6 +892,7 @@ load_pdump (int argc, char **argv) dump_file, dump_error_to_string (result)); hardcoded: + #ifdef WINDOWSNT /* On MS-Windows, PATH_EXEC normally starts with a literal "%emacs_dir%", so it will never work without some tweaking. */ @@ -900,7 +902,6 @@ 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"; needed = (strlen (path_exec) + 1 + strlen (argv0_base) From b8d386083f8f0a0f7ec16f43055cc9f557f6a7f3 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Apr 2021 18:10:52 +0300 Subject: [PATCH 1440/1452] * src/emacs.c (load_pdump): Fix unconditional references to strip_suffix. --- src/emacs.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index 2fc93631c9e..896e129c75f 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -917,7 +917,8 @@ load_pdump (int argc, char **argv) /* Assume the Emacs binary lives in a sibling directory as set up by the default installation configuration. */ const char *go_up = "../../../../bin/"; - needed += strlen (strip_suffix) - strlen (suffix) + strlen (go_up); + needed += (strip_suffix ? strlen (strip_suffix) : 0) + - strlen (suffix) + strlen (go_up); if (exec_bufsize < needed) { xfree (emacs_executable); @@ -925,7 +926,8 @@ load_pdump (int argc, char **argv) -1, 1); } sprintf (emacs_executable, "%s%c%s%s%s", - path_exec, DIRECTORY_SEP, go_up, argv0_base, strip_suffix); + 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) From 75c898edc3d7e06b589ce42917ae56e0c40082ac Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Apr 2021 19:10:16 +0300 Subject: [PATCH 1441/1452] ; * src/pdumper.c (dump_do_dump_relocation): Add a FIXME comment. --- src/pdumper.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/pdumper.c b/src/pdumper.c index c9285ddbc78..ed763a5d7ef 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5325,6 +5325,13 @@ dump_do_dump_relocation (const uintptr_t dump_base, 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) From af0af63742fd2383dae5627d0ce8167517fd4700 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 18 Apr 2021 12:00:25 +0300 Subject: [PATCH 1442/1452] Fix last change * src/emacs.c (load_pdump_find_executable): Fix the value of CANDIDATE_SIZE when the final candidate is a symlink. --- src/emacs.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/emacs.c b/src/emacs.c index 896e129c75f..922da9f1da3 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -795,7 +795,10 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) char *real_name = realpath (candidate, NULL); if (real_name) - return real_name; + { + *candidate_size = strlen (real_name) + 1; + return real_name; + } } return candidate; } From cc2d2e8d6c7d52d2fbbf9ffe410f97952c64cb3e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 18 Apr 2021 14:56:00 +0300 Subject: [PATCH 1443/1452] ; * src/emacs.c (load_pdump_find_executable): Yet another fix. --- src/emacs.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/emacs.c b/src/emacs.c index 922da9f1da3..c09ad97a701 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -749,7 +749,11 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) path already, so just copy it. */ eassert (argv0); if (strchr (argv0, DIRECTORY_SEP)) - return xstrdup (argv0); + { + char *val = xstrdup (argv0); + *candidate_size = strlen (val) + 1; + return val; + } ptrdiff_t argv0_length = strlen (argv0); const char *path = getenv ("PATH"); From 490b8c2c339966886190fdf897e2d95fb4bb5e3b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 18 Apr 2021 16:44:44 +0300 Subject: [PATCH 1444/1452] * src/comp.c (fixup_eln_load_path): Simplify code. --- src/comp.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/comp.c b/src/comp.c index 50947316df8..5309be46dec 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4760,14 +4760,12 @@ fixup_eln_load_path (Lisp_Object eln_filename) if (CONSP (tem)) last_cell = tem; - const char preloaded[] = "preloaded"; - ptrdiff_t preloaded_len = sizeof (preloaded) - 1; + const char preloaded[] = "/preloaded/"; Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename); - bool preloaded_p = - !NILP (Fequal (Fsubstring_no_properties (eln_cache_sys, - make_fixnum (-preloaded_len - 1), - make_fixnum (-1)), - build_string (preloaded))); + const char *p_preloaded = + SSDATA (eln_cache_sys) + SBYTES (eln_cache_sys) - sizeof (preloaded) + 1; + bool preloaded_p = strcmp (p_preloaded, preloaded) == 0; + /* One or two directories up... */ for (int i = 0; i < (preloaded_p ? 2 : 1); i++) eln_cache_sys = From e54066f3d459f67a1ee4e44552bf0356d010e03f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 18 Apr 2021 22:36:01 +0300 Subject: [PATCH 1445/1452] * src/emacs.c (main): Add back the call to init_callproc_1. (bug#47872) --- src/emacs.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/emacs.c b/src/emacs.c index c09ad97a701..792f690797d 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2011,6 +2011,9 @@ 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 (); + /* Must precede init_cmdargs and init_sys_modes. */ + init_callproc_1 (); + /* Must precede init_lread. */ init_cmdargs (argc, argv, skip_args, original_pwd); From 0eee48af9de308ef57a065ecd8b2c2c7b59012a0 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Apr 2021 14:22:11 +0200 Subject: [PATCH 1446/1452] Introduce `sxhash-equal-including-properties'. * src/fns.c (collect_interval): Move it upwards. (Fsxhash_equal_including_properties): New function. (syms_of_fns): Register `sxhash-equal-including-properties'. * etc/NEWS: Add 'sxhash-equal-including-properties'. --- etc/NEWS | 5 +++++ src/fns.c | 43 ++++++++++++++++++++++++++++++++++--------- 2 files changed, 39 insertions(+), 9 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index fb0ec90fea8..6928cbc429f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2579,6 +2579,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 diff --git a/src/fns.c b/src/fns.c index 1758148ff2d..41429c8863d 100644 --- a/src/fns.c +++ b/src/fns.c @@ -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); From f842816125c54a46eb786ff15622d88792e7677a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Apr 2021 15:23:23 +0200 Subject: [PATCH 1447/1452] Fix native compiler string hash consing strategy (bug#47868) * test/src/comp-tests.el (comp-test-47868-1): Add new test. * test/src/comp-test-funcs.el (comp-test-47868-1-f) (comp-test-47868-2-f): New functions. * lisp/emacs-lisp/comp.el (comp-imm-equal-test): Define new hash tanble test. (comp-data-container): Use it. (comp-final, comp-run-async-workers): have comp required before reading dumped hashes so that `comp-imm-equal-test' is defined. --- lisp/emacs-lisp/comp.el | 72 +++++++++++++++++++------------------ test/src/comp-test-funcs.el | 8 +++++ test/src/comp-tests.el | 4 +++ 3 files changed, 50 insertions(+), 34 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0122008fc9e..394b8cb73c0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -730,11 +730,15 @@ Returns ELT." finally return h) "Hash table lap-op -> stack adjustment.")) +(define-hash-table-test 'comp-imm-equal-test #'equal-including-properties + (lambda (x) + (sxhash-equal-including-properties x))) + (cl-defstruct comp-data-container "Data relocation container structure." (l () :type list :documentation "Constant objects used by functions.") - (idx (make-hash-table :test #'equal) :type hash-table + (idx (make-hash-table :test 'comp-imm-equal-test) :type hash-table :documentation "Obj -> position into the previous field.")) (cl-defstruct (comp-ctxt (:include comp-cstr-ctxt)) @@ -3648,25 +3652,26 @@ Prepare every function for final compilation and drive the C back-end." (print-gensym t) (print-circle t) (print-escape-multibyte t) - (expr `(progn - (require 'comp) - (setf comp-verbose ,comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-ctxt ,comp-ctxt - comp-eln-load-path ',comp-eln-load-path - comp-native-driver-options - ',comp-native-driver-options - load-path ',load-path) - ,comp-async-env-modifier-form - (message "Compiling %s..." ',output) - (comp-final1))) + (expr `((require 'comp) + (setf comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer + comp-ctxt ,comp-ctxt + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path) + ,comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) (temp-file (make-temp-file (concat "emacs-int-comp-" (file-name-base output) "-") nil ".el"))) (with-temp-file temp-file (insert ";; -*-coding: nil; -*-\n") - (insert (prin1-to-string expr))) + (mapc (lambda (e) + (insert (prin1-to-string e))) + expr)) (with-temp-buffer (unwind-protect (if (zerop @@ -3900,34 +3905,33 @@ display a message." ; commanded for late load. (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) - do (let* ((expr `(progn - (require 'comp) - ,(when (boundp 'backtrace-line-length) - `(setf backtrace-line-length ,backtrace-line-length)) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-async-compilation t - comp-eln-load-path ',comp-eln-load-path - comp-native-driver-options - ',comp-native-driver-options - load-path ',load-path - warning-fill-column most-positive-fixnum) - ,comp-async-env-modifier-form - (message "Compiling %s..." ,source-file) - (comp--native-compile ,source-file ,(and load t)))) + do (let* ((expr `((require 'comp) + ,(when (boundp 'backtrace-line-length) + `(setf backtrace-line-length ,backtrace-line-length)) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer + comp-async-compilation t + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path + warning-fill-column most-positive-fixnum) + ,comp-async-env-modifier-form + (message "Compiling %s..." ,source-file) + (comp--native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ (temp-file (make-temp-file (concat "emacs-async-comp-" (file-name-base source-file) "-") nil ".el")) - (expr-string (prin1-to-string expr)) + (expr-strings (mapcar #'prin1-to-string expr)) (_ (progn (with-temp-file temp-file - (insert expr-string)) + (mapc #'insert expr-strings)) (comp-log "\n") - (comp-log expr-string))) + (mapc #'comp-log expr-strings))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index cbd0e5747e8..878db70609d 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -501,6 +501,14 @@ (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))) + + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b618110bbe4..cb9032aa410 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -507,6 +507,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "" (should (equal (comp-test-46824-1-f) nil))) +(comp-deftest comp-test-47868-1 () + (should-not (equal-including-properties (comp-test-47868-1-f) + (comp-test-47868-2-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; From de16621b5109f628c3ce41bdb15de6b29f540602 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Apr 2021 15:23:33 +0200 Subject: [PATCH 1448/1452] * lisp/emacs-lisp/comp.el (batch-byte-native-compile-for-bootstrap): Fix typo. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 394b8cb73c0..587618116fe 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4166,7 +4166,7 @@ Native compilation equivalent to `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () - "Like `batch-native-compile', but used for booststrap. + "Like `batch-native-compile', but used for bootstrap. Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `comp-eln-load-path'). From 606188a360111b6985f6615f96fb255330813aeb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Apr 2021 23:15:56 +0200 Subject: [PATCH 1449/1452] * lisp/emacs-lisp/comp.el (comp-imm-equal-test): Style fix. --- lisp/emacs-lisp/comp.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 587618116fe..ab5a06e7e86 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -731,8 +731,7 @@ Returns ELT." "Hash table lap-op -> stack adjustment.")) (define-hash-table-test 'comp-imm-equal-test #'equal-including-properties - (lambda (x) - (sxhash-equal-including-properties x))) + #'sxhash-equal-including-properties) (cl-defstruct comp-data-container "Data relocation container structure." From 062e5994802bbe634bae7f1aef99f65daf1ec44e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 22 Apr 2021 09:57:30 +0200 Subject: [PATCH 1450/1452] Improve a native compiler test * test/src/comp-tests.el (comp-test-47868-1): Improve testcase. * test/src/comp-test-funcs.el (comp-test-47868-3-f) (comp-test-47868-4-f): New functions. --- test/src/comp-test-funcs.el | 6 ++++++ test/src/comp-tests.el | 7 ++++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 878db70609d..f2a246320ac 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -508,6 +508,12 @@ (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))) + ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index cb9032aa410..a1e91ec5141 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -508,8 +508,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-test-46824-1-f) nil))) (comp-deftest comp-test-47868-1 () + "Verify string hash consing strategy. + +" (should-not (equal-including-properties (comp-test-47868-1-f) - (comp-test-47868-2-f)))) + (comp-test-47868-2-f))) + (should (eq (comp-test-47868-1-f) (comp-test-47868-3-f))) + (should (eq (comp-test-47868-2-f) (comp-test-47868-4-f)))) ;;;;;;;;;;;;;;;;;;;;; From 592ffd35b0de48f098fcf070d0a29bb3406e4bf9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 24 Apr 2021 11:20:50 +0300 Subject: [PATCH 1451/1452] Improve diagnostics of loading *.eln files * src/pdumper.c (dump_do_dump_relocation): Improve diagnostics when loading preloaded *.eln files fails. (Bug#46790) --- src/pdumper.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/pdumper.c b/src/pdumper.c index ed763a5d7ef..dfc7388b634 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5335,7 +5335,11 @@ dump_do_dump_relocation (const uintptr_t dump_base, comp_u->file = eln_fname; comp_u->handle = dynlib_open (SSDATA (eln_fname)); if (!comp_u->handle) - error ("%s", dynlib_error ()); + { + fprintf (stderr, "Error using execdir %s:\n", + emacs_execdir); + error ("%s", dynlib_error ()); + } load_comp_unit (comp_u, true, false); break; } From fa65c044f2ebe666467166075c1507a8d0e1347f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 24 Apr 2021 16:01:19 +0300 Subject: [PATCH 1452/1452] Improve detection of pdumper file and *.eln files * src/emacs.c (load_pdump_find_executable): Resolve symlinks even if argv[0] includes leading directories. (Bug#46790) --- src/emacs.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/emacs.c b/src/emacs.c index 792f690797d..9157cd84a99 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -746,10 +746,18 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) 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)) { + 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;