mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

Initial result of applying diff

Browse source
This commit is contained in:
Gerd Möllmann 2024-04-18 09:46:13 +02:00
parent c19b988c29
commit 3c933f40a8
39 changed files with 3967 additions and 275 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.clang-format
View file

@ -4,7 +4,7 @@ AlignOperands: Align
AlwaysBreakAfterReturnType: TopLevelDefinitions
BreakBeforeBinaryOperators: All
BreakBeforeBraces: GNU
ColumnLimit: 70
ColumnLimit: 80
ContinuationIndentWidth: 2
IndentPPDirectives: AfterHash
PPIndentWidth: 1

3
.gitignore vendored
View file

@ -391,3 +391,6 @@ exec/config.h.in
exec/config-mips.m4
exec/configure
exec/*.s.s
# MPS telemetry output
/src/mpsio.txt

187
admin/igc.org Normal file
View file

@ -0,0 +1,187 @@
#+title: MPS garbage collection for Emacs
* What is MPS?
The MPS (Memory Pool System) is a GC library developed by Ravenbrook
Ltd. MPS is available from [[https://github.com/Ravenbrook/mps?tab=readme-ov-file][Github]] under a BSD license. See the
[[https://memory-pool-system.readthedocs.io/en/latest/][documentation]].
In short, MPS implements incremental, generational, concurrent, copying,
thread-safe garbage collection on a large variety of platforms. It has
been around for a long time, is stable, and well documented.
* What is this branch?
This [[https://github.com/gerd-moellmann/emacs-with-cl-packages/tree/igc][branch]] is an experiment if Emacs can be made to use a GC based on
MPS. I'm doing this for my own entertainment, it's not in any form
"official".
* Caveats
This is my local Emacs, which is different from mainstream Emacs: It
uses CL packages, doesn't have obarrays, doesn't support pure space,
does not support shorthands and probably some other stuff.
In addition, I'm exclusively using macOS, so it's unlikely to compile or
run on other systems OOTB. It should not be too hard to port, though.
* Current state
Build succeeds up to and including =compile-first=, i.e. Emacs pdumps, and
compiles some =.elc= files.
* Things worth mentioning
** Configuration
There is a now configure switch =--with-mps= with values =no, yes, debug=.
If =debug= is given, Emacs links with the debug version of the MPS
library.
** Building MPS
I built MPS from its Git repo. I had to make two trivial fixes for macOS
for which I submitted issues upstream.
** Every object has a 1 word header
At the moment, every object has a one-word header, which is not visible
to the rest of Emacs. See ~struct igc_header~.
This means in particular that conses are 50% larger than they would
normally be. I did this because it is less work:
- All objects can be handled by one set of MPS callback functions.
- It simplifies the implementation of eq hash tables considerably by
storing an address-independent hash in the header.
The header can be removed from conses (and other objects, if that's
worth it) by writing additional code using additional MPS pools with
their own object formats.
Note that doing this also means that one has to use MPS's location
dependency feature for implementing eq hash tables.
Also be aware that two calls to ~sxhash-eq~ can then return different
hashes when a concurrent GC happens between calls, unless something is
done to ensure that the hashed objects aren't moved by the GC for long
enough.
** MPS In-band headers
I have tried to use MPS in-band headers at first, but couldn't get it to
work. I don't claim they don't work, though. After all I was and still
am learning MPS.
** Weak hash tables
I didn't think that weak hash tables were important enough for my
experiment, so I didn't implement them to save work.
Weak tables can be implemented using the already present in =igc.c= AWL
pool and its allocation points, and then using MPS's dependent objects
in the hash table implementation. There are examples how to do this in
the MPS documentation, and in an example Scheme interpreter.
To prepare for that, keys and values of a hash table are already split
into two vectors. Two vectors are necessary because objects in an AWL
pool must either contain weak references only, or strong references
only. The currently malloc'd vectors would have to be replaced with
special vectors allocated from the AWL pool.
** Handling of a loaded pdump
The hot part of a loaded pdump (ca. 18 MB) is currently used as an
ambiguous root for MPS. A number of things could be investigated
- Use a root with barrier (~MPS_RM_PROT~)
- Copy objects from the dump to an MPS pool that uses ~MPS_KEY_GEN~ to
allocate objects in an old generation.
It is unclear to me from the docs if the AMC pool supports that, but
one could use an AMS pool.
After loading a dump we would copy the whole object graph to MPS,
starting from static roots. After that, the dump itself would no
longer be used.
Costs some load time, though.
There is also a slight problem currently that's a consequence of Emacs
mixing GC'd objects and malloc'd ones. The loaded dump is scanned
conservativly, but if such objects contain malloc'd data structures
holding references, these are invisble to MPS, so one has to jump
through hoops.
Examples:
- Hash tables hold keys and values in malloc'd vectors. If the hash
table is in the dump, and the vectors are on the heap, keys and values
won't be seen be MPS.
- Symbols in the dump may have a Lisp_Buffer_Local_Value that is on the
heap.
- Buffers have a itree_tree that is malloc'd.
** Intervals and ~itree_node~
Problem with these two is that there are pointers from Lisp objects to
malloc'd memory and back. This is easier to handle if allocated
from MPS. Moving these to MPS makes things easier because MPS triggers
the scanning, and, not the least, makes an ambiguous scan of the loaded
dump keep things alive.
** Finalization
Is now implemented.
** Things old GC does except GC
The function ~garbage_collect~ does some things that are not directly
related to GC, simply because it is called every once in a while.
- compact buffers, undo-list.
This is currently not done, but could be done in another way, from a
timer, for instance.
** Not Considered
Some things are not implemented because they were out of scope. For
example,
- ~memory-report~ Could be done with MPS's pool walk functionality.
- profiler (~profiler-memory-start~...) No idea, haven't looked at it.
- Anything I don't currently use either because it doesn't exist on
macOS (text conversions, for example), or because I didn't think it
being essiential (xwidgets, for example).
** Knobs not tried
- Number of generations
- Size of generations
- Mortality probabilities
- Allocation policies, like ramp allocation
- ...
** Implementation
I think it's not too terrible, but some things should be improved
- Error handling. It currently aborts in many circumstances, but
it is also not clear what else to do.
- Idle time use. It does something in this regard, but not much,
and not always with a time constraint (handling MPS messages).
** Debugger
MPS uses memory barriers. In certain situations it is necessary to
remove these to be able to do certain things. I've added a command
=xpostmortem= to the LLDB support for that. GDB will need something
similar.

27
configure.ac
View file

@ -585,6 +585,7 @@ OPTION_DEFAULT_ON([xinput2],[don't use version 2 of the X Input Extension for in
OPTION_DEFAULT_OFF([small-ja-dic],[generate a smaller-size Japanese dictionary])
OPTION_DEFAULT_OFF([android],[cross-compile Android application package])
OPTION_DEFAULT_ON([android-debug],[don't build Emacs as a debug package on Android])
OPTION_DEFAULT_OFF([mps],[use MPS for garbage collection])
# Find out of Android support is enabled and mailutils has defaulted
# to `yes-unless-android'. Disable it if so.
@ -5498,6 +5499,29 @@ if test "${with_gpm}" != "no"; then
fi
AC_SUBST([LIBGPM])
### Use -lmps if available, unless '--with-mps=no'.
HAVE_MPS=no
LIBMPS=
IGCOBJ=
if test "${with_mps}" != "no"; then
AC_CHECK_HEADER([mps.h],
[AC_CHECK_LIB([mps], [mps_arena_create], [HAVE_MPS=yes])])
if test "${HAVE_MPS}" = "yes"; then
IGCOBJ="igc.o"
AC_DEFINE([HAVE_MPS], [1],
[Define to 1 if you have the mps library (-lmps).])
if test "${with_mps}" = "debug"; then
LIBMPS=-lmps-debug
else
LIBMPS=-lmps
fi
fi
fi
AC_SUBST([LIBMPS])
AC_SUBST([IGCOBJ])
dnl Check for malloc/malloc.h on darwin
AC_CHECK_HEADERS_ONCE([malloc/malloc.h])
@ -7644,7 +7668,7 @@ optsep=
emacs_config_features=
for opt in ACL BE_APP CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \
HARFBUZZ IMAGEMAGICK JPEG LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \
M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PGTK PNG RSVG SECCOMP \
M17N_FLT MODULES MPS NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PGTK PNG RSVG SECCOMP \
SOUND SQLITE3 THREADS TIFF TOOLKIT_SCROLL_BARS TREE_SITTER \
UNEXEC WEBP X11 XAW3D XDBE XFT XIM XINPUT2 XPM XWIDGETS X_TOOLKIT \
ZLIB; do
@ -7705,6 +7729,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
Does Emacs use native APIs for images? ${NATIVE_IMAGE_API}
Does Emacs support sound? ${HAVE_SOUND}
Does Emacs use -lgpm? ${HAVE_GPM}
Does Emacs use -lmps? ${HAVE_MPS}
Does Emacs use -ldbus? ${HAVE_DBUS}
Does Emacs use -lgconf? ${HAVE_GCONF}
Does Emacs use GSettings? ${HAVE_GSETTINGS}

11
etc/emacs_lldb.py
View file

@ -182,6 +182,10 @@ class Lisp_Object:
# LLDB Commands
########################################################################
def xpostmortem(debugger, command, ctx, result, internal_dict):
"""Call igc_postmortem to set MPS arena to postmortem state"""
debugger.HandleCommand(f"expr igc_postmortem()")
def xbacktrace(debugger, command, ctx, result, internal_dict):
"""Print Emacs Lisp backtrace"""
frame = ctx.GetFrame()
@ -237,8 +241,8 @@ class Lisp_Object_Provider:
self.children["cdr"] = cdr
else:
self.children["untagged"] = lisp_obj.untagged
except:
print(f"*** exception in child provider update for {lisp_type}")
except Exception as ex:
print(f"*** exception {ex} in Lisp_Object_Provider::update for {lisp_type}")
pass
def num_children(self):
@ -306,10 +310,11 @@ def enable_type_category(debugger, category):
# This function is called by LLDB to initialize the module.
def __lldb_init_module(debugger, internal_dict):
define_command(debugger, xpostmortem)
define_command(debugger, xbacktrace)
define_command(debugger, xdebug_print)
define_type_summary(debugger, "Lisp_Object", type_summary_Lisp_Object)
define_type_synthetic(debugger, "Lisp_Object", Lisp_Object_Provider)
#define_type_synthetic(debugger, "Lisp_Object", Lisp_Object_Provider)
enable_type_category(debugger, "Emacs")
print('Emacs debugging support has been installed.')

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

@ -1492,7 +1492,8 @@ when printing the error message."
(and (eq 'macro (car-safe f)) (setq f (cdr f)))
;; Advice wrappers have "catch all" args, so fetch the actual underlying
;; function to find the real arguments.
(setq f (advice--cd*r f))
(when (fboundp 'advice--cd*r) ;;nil during early bootstrap.
(setq f (advice--cd*r f)))
(if (eq (car-safe f) 'declared)
(byte-compile-arglist-signature (nth 1 f))
(condition-case nil

42
src/.lldbinit
View file

@ -33,4 +33,46 @@ command script import emacs_lldb
# Print with children provider, depth 2.
command alias xprint frame variable -P 2
# MPS telemetry level (default output file mpsio.log)
#env MPS_TELEMETRY_CONTROL=all
# b xsignal
b pkg_break
#b pkg_error
#b Fpkg_read
b igc_break
b wrong_type_argument
b malloc_error_break
# When an assertion in MPS fails
b mps_lib_assert_fail
# Whlle dying, Emacs may allocate from MPS, although we're dying
# from having an assertion fail in code called from MPS. This leads
# to misleading situations, like pthread_mutex_lock reporting EDEADLK
# because we're owning the lock already, and so on.
b emacs_abort
b die
#watchpoint set expression --size 8 --watch write -- (char*) pkg->symbols
# To find out from where macOS prints stuff to stderr, like
# 023-07-20 13:41:17.073449+0200 emacs[53072:1205906] [default]
# CGSWindowShmemCreateWithPort failed on port 0
# b libsystem_trace.dylib``_os_log_error_impl
# Print with children provider, depth 2.
#command alias xprint frame variable -P 2
#process handle -p true -s false SIGSEGV
#process handle -p true -s false SIGBUS
#target create emacs
#settings set -- target.run-args -batch --no-site-file --no-site-lisp --eval '(setq load-prefer-newer t)' -l ox-texinfo --eval '(setq gc-cons-threshold 50000000)' -f org-texinfo-export-to-texinfo-batch modus-themes.org modus-themes.texi
#command alias go process launch --working-dir ../doc/misc
#target create temacs
#settings set -- target.run-args --batch -l loadup --temacs=pbootstrap --bin-dest /Users/gerd/emacs/github/igc/nextstep/Emacs.app/Contents/MacOS/ --eln-dest /Users/gerd/emacs/github/igc/nextstep/Emacs.app/Contents/Frameworks/
#command alias go process launch --working-dir .
target create emacs
# end.

6
src/Makefile.in
View file

@ -351,6 +351,8 @@ FONT_OBJ=@FONT_OBJ@
CM_OBJ=@CM_OBJ@
LIBGPM = @LIBGPM@
LIBMPS = @LIBMPS@
IGCOBJ = @IGCOBJ@
LIBSELINUX_LIBS = @LIBSELINUX_LIBS@
LIBSELINUX_CFLAGS = @LIBSELINUX_CFLAGS@
@ -470,7 +472,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
region-cache.o sound.o timefns.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \
$(XWIDGETS_OBJ) \
profiler.o decompress.o \
profiler.o decompress.o $(IGCOBJ) \
thread.o systhread.o sqlite.o treesit.o \
itree.o json.o \
$(if $(HYBRID_MALLOC),sheap.o) \
@ -602,7 +604,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
$(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) \
$(TREE_SITTER_LIBS) $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS) \
$(ANDROID_LIBS)
$(ANDROID_LIBS) $(LIBMPS)
## FORCE it so that admin/unidata can decide whether this file is
## up-to-date. Although since charprop depends on bootstrap-emacs,

400
src/alloc.c
View file

File diff suppressed because it is too large Load diff

15
src/bytecode.c
View file

@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "blockinput.h"
#include "igc.h"
#include "sysstdio.h"
#include "character.h"
#include "buffer.h"
@ -386,6 +387,14 @@ struct bc_frame {
Lisp_Object next_stack[]; /* data stack of next frame */
};
#ifdef HAVE_MPS
void *
bc_next_frame (struct bc_frame *bc)
{
return bc->next_stack;
}
#endif
void
init_bc_thread (struct bc_thread_state *bc)
{
@ -402,6 +411,7 @@ free_bc_thread (struct bc_thread_state *bc)
xfree (bc->stack);
}
#ifndef HAVE_MPS
void
mark_bytecode (struct bc_thread_state *bc)
{
@ -432,6 +442,7 @@ mark_bytecode (struct bc_thread_state *bc)
fp = next_fp;
}
}
#endif // not HAVE_MPS
DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats,
0, 0, 0,
@ -483,7 +494,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
setup_frame: ;
eassert (!STRING_MULTIBYTE (bytestr));
#ifndef HAVE_MPS
// With MPS, references from the stack pin string data (also interior
// pointers).
eassert (string_immovable_p (bytestr));
#endif
/* FIXME: in debug mode (!NDEBUG, BYTE_CODE_SAFE or enabled checking),
save the specpdl index on function entry and check that it is the same
when returning, to detect unwind imbalances. This would require adding

17
src/charset.c
View file

@ -40,6 +40,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "sysstdio.h"
#include "pdumper.h"
#include "igc.h"
/*** GENERAL NOTES on CODED CHARACTER SETS (CHARSETS) ***
@ -1130,9 +1131,14 @@ usage: (define-charset-internal ...) */)
int old_size = charset_table_size;
ptrdiff_t new_size = old_size;
struct charset *new_table =
xpalloc (0, &new_size, 1,
min (INT_MAX, MOST_POSITIVE_FIXNUM),
sizeof *charset_table);
#ifdef HAVE_MPS
igc_xpalloc_ambig
#else
xpalloc
#endif
(0, &new_size, 1,
min (INT_MAX, MOST_POSITIVE_FIXNUM),
sizeof *charset_table);
memcpy (new_table, charset_table, old_size * sizeof *new_table);
charset_table = new_table;
charset_table_size = new_size;
@ -2270,6 +2276,7 @@ See also `charset-priority-list' and `set-charset-priority'. */)
return charsets;
}
#ifndef HAVE_MPS
/* Not strictly necessary, because all charset attributes are also
reachable from `Vcharset_hash_table`. */
void
@ -2278,6 +2285,7 @@ mark_charset (void)
for (int i = 0; i < charset_table_used; i++)
mark_object (charset_table[i].attributes);
}
#endif
void
@ -2376,6 +2384,9 @@ syms_of_charset (void)
charset_table = charset_table_init;
charset_table_size = ARRAYELTS (charset_table_init);
#ifdef HAVE_MPS
igc_create_charset_root (charset_table_init, sizeof charset_table_init);
#endif
PDUMPER_REMEMBER_SCALAR (charset_table_size);
charset_table_used = 0;
PDUMPER_REMEMBER_SCALAR (charset_table_used);

6
src/composite.c
View file

@ -2163,7 +2163,9 @@ of the way buffer text is examined for matching one of the rules. */)
return rules;
}
#ifndef HAVE_MPS
/* Not strictly necessary, because all those "keys" are also
reachable from `composition_hash_table`. */
void
@ -2173,6 +2175,8 @@ mark_composite (void)
mark_object (composition_table[i]->key);
}
#endif // not HAVE_MPS
void
syms_of_composite (void)

8
src/data.c
View file

@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "process.h"
#include "frame.h"
#include "keymap.h"
#include "igc.h"
static void swap_in_symval_forwarding (struct Lisp_Symbol *,
struct Lisp_Buffer_Local_Value *);
@ -2090,7 +2091,12 @@ static struct Lisp_Buffer_Local_Value *
make_blv (struct Lisp_Symbol *sym, bool forwarded,
union Lisp_Val_Fwd valcontents)
{
struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
struct Lisp_Buffer_Local_Value *blv;
#ifdef HAVE_MPS
blv = igc_alloc_blv ();
#else
blv = xmalloc (sizeof *blv);
#endif
Lisp_Object symbol;
Lisp_Object tem;

9
src/dispextern.h
View file

@ -829,6 +829,10 @@ struct glyph_matrix
/* Values of BEGV and ZV as of last redisplay. Set in
mark_window_display_accurate_1. */
ptrdiff_t begv, zv;
# ifdef HAVE_MPS
void *igc_info;
# endif
};
@ -1923,6 +1927,11 @@ struct face_cache
bool_bf menu_face_changed_p : 1;
};
/* Size of hash table of realized faces in face caches (should be a
prime number). */
#define FACE_CACHE_BUCKETS_SIZE 1009
#define FACE_EXTENSIBLE_P(F) \
(!NILP (F->lface[LFACE_EXTEND_INDEX]))

61
src/dispnew.c
View file

@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <unistd.h>
#include "lisp.h"
#include "igc.h"
#include "termchar.h"
/* cm.h must come after dispextern.h on Windows. */
#include "dispextern.h"
@ -303,8 +304,11 @@ free_glyph_matrix (struct glyph_matrix *matrix)
/* Free glyph memory if MATRIX owns it. */
if (matrix->pool == NULL)
for (i = 0; i < matrix->rows_allocated; ++i)
#ifdef HAVE_MPS
igc_xfree (matrix->rows[i].glyphs[LEFT_MARGIN_AREA]);
#else
xfree (matrix->rows[i].glyphs[LEFT_MARGIN_AREA]);
#endif
/* Free row structures and the matrix itself. */
xfree (matrix->rows);
xfree (matrix);
@ -424,7 +428,8 @@ adjust_glyph_matrix (struct window *w, struct glyph_matrix *matrix, int x, int y
matrix->rows = xpalloc (matrix->rows, &matrix->rows_allocated,
new_rows, INT_MAX, sizeof *matrix->rows);
memset (matrix->rows + old_alloc, 0,
(matrix->rows_allocated - old_alloc) * sizeof *matrix->rows);
(matrix->rows_allocated - old_alloc)
* sizeof *matrix->rows);
}
else
new_rows = 0;
@ -506,10 +511,14 @@ adjust_glyph_matrix (struct window *w, struct glyph_matrix *matrix, int x, int y
while (row < end)
{
row->glyphs[LEFT_MARGIN_AREA]
= xnrealloc (row->glyphs[LEFT_MARGIN_AREA],
dim.width, sizeof (struct glyph));
row->glyphs[LEFT_MARGIN_AREA] =
#ifdef HAVE_MPS
igc_xnrealloc_ambig (row->glyphs[LEFT_MARGIN_AREA],
dim.width, sizeof (struct glyph));
#else
xnrealloc (row->glyphs[LEFT_MARGIN_AREA],
dim.width, sizeof (struct glyph));
#endif
/* The mode line, if displayed, never has marginal areas. */
if ((row == matrix->rows + dim.height - 1
&& !(w && window_wants_mode_line (w)))
@ -1365,7 +1374,11 @@ free_glyph_pool (struct glyph_pool *pool)
--glyph_pool_count;
eassert (glyph_pool_count >= 0);
#endif
#ifdef HAVE_MPS
igc_xfree (pool->glyphs);
#else
xfree (pool->glyphs);
#endif
xfree (pool);
}
}
@ -1396,8 +1409,16 @@ realloc_glyph_pool (struct glyph_pool *pool, struct dim matrix_dim)
if (needed > pool->nglyphs)
{
ptrdiff_t old_nglyphs = pool->nglyphs;
pool->glyphs = xpalloc (pool->glyphs, &pool->nglyphs,
needed - old_nglyphs, -1, sizeof *pool->glyphs);
#ifdef HAVE_MPS
pool->glyphs
= igc_xpalloc_ambig (pool->glyphs, &pool->nglyphs, needed - old_nglyphs,
-1, sizeof *pool->glyphs);
#else
pool->glyphs
= xpalloc (pool->glyphs, &pool->nglyphs, needed - old_nglyphs,
-1, sizeof *pool->glyphs);
#endif
memclear (pool->glyphs + old_nglyphs,
(pool->nglyphs - old_nglyphs) * sizeof *pool->glyphs);
}
@ -1954,7 +1975,11 @@ save_current_matrix (struct frame *f)
struct glyph_row *to = saved->rows + i;
ptrdiff_t nbytes = from->used[TEXT_AREA] * sizeof (struct glyph);
#ifdef HAVE_MPS
to->glyphs[TEXT_AREA] = igc_xzalloc_ambig (nbytes);
#else
to->glyphs[TEXT_AREA] = xmalloc (nbytes);
#endif
memcpy (to->glyphs[TEXT_AREA], from->glyphs[TEXT_AREA], nbytes);
to->used[TEXT_AREA] = from->used[TEXT_AREA];
to->enabled_p = from->enabled_p;
@ -1962,7 +1987,11 @@ save_current_matrix (struct frame *f)
if (from->used[LEFT_MARGIN_AREA])
{
nbytes = from->used[LEFT_MARGIN_AREA] * sizeof (struct glyph);
#ifdef HAVE_MPS
to->glyphs[LEFT_MARGIN_AREA] = igc_xzalloc_ambig (nbytes);
#else
to->glyphs[LEFT_MARGIN_AREA] = xmalloc (nbytes);
#endif
memcpy (to->glyphs[LEFT_MARGIN_AREA],
from->glyphs[LEFT_MARGIN_AREA], nbytes);
to->used[LEFT_MARGIN_AREA] = from->used[LEFT_MARGIN_AREA];
@ -1970,7 +1999,11 @@ save_current_matrix (struct frame *f)
if (from->used[RIGHT_MARGIN_AREA])
{
nbytes = from->used[RIGHT_MARGIN_AREA] * sizeof (struct glyph);
#ifdef HAVE_MPS
to->glyphs[RIGHT_MARGIN_AREA] = igc_xzalloc_ambig (nbytes);
#else
to->glyphs[RIGHT_MARGIN_AREA] = xmalloc (nbytes);
#endif
memcpy (to->glyphs[RIGHT_MARGIN_AREA],
from->glyphs[RIGHT_MARGIN_AREA], nbytes);
to->used[RIGHT_MARGIN_AREA] = from->used[RIGHT_MARGIN_AREA];
@ -1997,14 +2030,22 @@ restore_current_matrix (struct frame *f, struct glyph_matrix *saved)
memcpy (to->glyphs[TEXT_AREA], from->glyphs[TEXT_AREA], nbytes);
to->used[TEXT_AREA] = from->used[TEXT_AREA];
#ifdef HAVE_MPS
igc_xfree (from->glyphs[TEXT_AREA]);
#else
xfree (from->glyphs[TEXT_AREA]);
#endif
nbytes = from->used[LEFT_MARGIN_AREA] * sizeof (struct glyph);
if (nbytes)
{
memcpy (to->glyphs[LEFT_MARGIN_AREA],
from->glyphs[LEFT_MARGIN_AREA], nbytes);
to->used[LEFT_MARGIN_AREA] = from->used[LEFT_MARGIN_AREA];
#ifdef HAVE_MPS
igc_xfree (from->glyphs[LEFT_MARGIN_AREA]);
#else
xfree (from->glyphs[LEFT_MARGIN_AREA]);
#endif
}
else
to->used[LEFT_MARGIN_AREA] = 0;
@ -2014,7 +2055,11 @@ restore_current_matrix (struct frame *f, struct glyph_matrix *saved)
memcpy (to->glyphs[RIGHT_MARGIN_AREA],
from->glyphs[RIGHT_MARGIN_AREA], nbytes);
to->used[RIGHT_MARGIN_AREA] = from->used[RIGHT_MARGIN_AREA];
#ifdef HAVE_MPS
xfree (from->glyphs[RIGHT_MARGIN_AREA]);
#else
xfree (from->glyphs[RIGHT_MARGIN_AREA]);
#endif
}
else
to->used[RIGHT_MARGIN_AREA] = 0;

2
src/editfns.c
View file

@ -3066,7 +3066,9 @@ save_restriction_restore_1 (Lisp_Object data)
/* Detach the markers, and free the cons instead of waiting for GC. */
detach_marker (XCAR (data));
detach_marker (XCDR (data));
#ifndef HAVE_MPS
free_cons (XCONS (data));
#endif
}
else
/* A buffer, which means that there was no old restriction. */

2
src/emacs-module.c
View file

@ -1515,6 +1515,7 @@ allocate_emacs_value (emacs_env *env, Lisp_Object obj)
return value;
}
#ifndef HAVE_MPS
/* Mark all objects allocated from local environments so that they
don't get garbage-collected. */
void
@ -1527,6 +1528,7 @@ mark_module_environment (void *ptr)
for (int i = 0; i < frame->offset; ++i)
mark_object (frame->objects[i].v);
}
#endif // not HAVE_MPS
/* Environment lifetime management. */

10
src/emacs.c
View file

@ -31,6 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define MAIN_PROGRAM
#include "lisp.h"
#include "igc.h"
#include "sysstdio.h"
#ifdef HAVE_ANDROID
@ -1424,6 +1425,10 @@ main (int argc, char **argv)
ns_init_pool ();
#endif
#ifdef HAVE_MPS
init_igc ();
#endif
#ifdef HAVE_PDUMPER
if (attempt_load_pdump)
initial_emacs_executable = load_pdump (argc, argv, dump_file);
@ -1980,6 +1985,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_data ();
syms_of_fns (); /* Before syms_of_charset which uses hash tables. */
syms_of_fileio ();
#ifdef HAVE_MPS
syms_of_igc ();
#endif
/* Before syms_of_coding to initialize Vgc_cons_threshold. */
syms_of_alloc ();
/* May call Ffuncall and so GC, thus the latter should be initialized. */
@ -3145,7 +3153,9 @@ You must run Emacs in batch mode in order to dump it. */)
Lisp_Object symbol;
specpdl_ref count = SPECPDL_INDEX ();
#ifndef HAVE_MPS
check_pure_size ();
# endif
if (! noninteractive)
error ("Dumping Emacs works only in batch mode");

17
src/eval.c
View file

@ -23,6 +23,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <limits.h>
#include <stdlib.h>
#include "lisp.h"
#include "igc.h"
#include "blockinput.h"
#include "commands.h"
#include "keyboard.h"
@ -30,6 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "pdumper.h"
#include "atimer.h"
#include "igc.h"
/* CACHEABLE is ordinarily nothing, except it is 'volatile' if
necessary to cajole GCC into not warning incorrectly that a
@ -103,12 +105,14 @@ specpdl_where (union specbinding *pdl)
return pdl->let.where;
}
#ifndef HAVE_MPS
static Lisp_Object
specpdl_arg (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_UNWIND);
return pdl->unwind.arg;
}
#endif
Lisp_Object
backtrace_function (union specbinding *pdl)
@ -217,6 +221,9 @@ init_eval_once_for_pdumper (void)
union specbinding *pdlvec = malloc ((size + 1) * sizeof *specpdl);
specpdl = specpdl_ptr = pdlvec + 1;
specpdl_end = specpdl + size;
#ifdef HAVE_MPS
igc_on_alloc_main_thread_specpdl ();
#endif
}
void
@ -2404,6 +2411,9 @@ grow_specpdl_allocation (void)
specpdl = pdlvec + 1;
specpdl_end = specpdl + pdlvecsize - 1;
specpdl_ptr = specpdl_ref_to_ptr (count);
#ifdef HAVE_MPS
igc_on_grow_specpdl ();
#endif
}
/* Eval a sub-expression of the current expression (i.e. in the same
@ -3757,7 +3767,6 @@ unbind_to (specpdl_ref count, Lisp_Object value)
union specbinding this_binding;
this_binding = *--specpdl_ptr;
do_one_unbind (&this_binding, true, SET_INTERNAL_UNBIND);
}
@ -4127,10 +4136,12 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.
return result;
}
#ifndef HAVE_MPS
void
mark_specpdl (union specbinding *first, union specbinding *ptr)
{
eassert_not_mps ();
union specbinding *pdl;
for (pdl = first; pdl != ptr; pdl++)
{
@ -4195,6 +4206,8 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
}
}
}
#endif // not HAVE_MPS
/* Fill ARRAY of size SIZE with backtrace entries, most recent call first.
Truncate the backtrace if longer than SIZE; pad with nil if shorter. */

95
src/fns.c
View file

@ -19,7 +19,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include <stddef.h>
#include <stdlib.h>
#include <sys/_types/_size_t.h>
#include <sys/random.h>
#include <unistd.h>
#include <filevercmp.h>
@ -35,7 +37,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "composite.h"
#include "buffer.h"
#include "igc.h"
#include "intervals.h"
#include "pdumper.h"
#include "window.h"
#include "puresize.h"
#include "gnutls.h"
@ -4751,7 +4755,11 @@ static EMACS_INT
sxhash_eq (Lisp_Object key)
{
Lisp_Object k = maybe_remove_pos_from_symbol (key);
#ifdef HAVE_MPS
return igc_hash (k);
#else
return XHASH (k) ^ XTYPE (k);
#endif
}
static EMACS_INT
@ -4861,7 +4869,8 @@ make_hash_table (const struct hash_table_test *test, EMACS_INT size,
if (size == 0)
{
h->key_and_value = NULL;
h->key = NULL;
h->value = NULL;
h->hash = NULL;
h->next = NULL;
h->index_bits = 0;
@ -4870,10 +4879,17 @@ make_hash_table (const struct hash_table_test *test, EMACS_INT size,
}
else
{
h->key_and_value = hash_table_alloc_bytes (2 * size
* sizeof *h->key_and_value);
for (ptrdiff_t i = 0; i < 2 * size; i++)
h->key_and_value[i] = HASH_UNUSED_ENTRY_KEY;
Lisp_Object *key = hash_table_alloc_kv (h, size);
Lisp_Object *value = hash_table_alloc_kv (h, size);
for (ptrdiff_t i = 0; i < size; i++)
{
key[i] = HASH_UNUSED_ENTRY_KEY;
value[i] = Qnil;
}
/* Initialize, then set. */
h->key = key;
h->value = value;
h->hash = hash_table_alloc_bytes (size * sizeof *h->hash);
@ -4913,9 +4929,13 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
if (h1->table_size > 0)
{
ptrdiff_t kv_bytes = 2 * h1->table_size * sizeof *h1->key_and_value;
h2->key_and_value = hash_table_alloc_bytes (kv_bytes);
memcpy (h2->key_and_value, h1->key_and_value, kv_bytes);
ptrdiff_t kv_bytes = h1->table_size * sizeof *h1->key;
Lisp_Object *key = hash_table_alloc_kv (h2, h1->table_size);
Lisp_Object *value = hash_table_alloc_kv (h2, h1->table_size);
memcpy (key, h1->key, kv_bytes);
memcpy (value, h1->value, kv_bytes);
h2->key = key;
h2->value = value;
ptrdiff_t hash_bytes = h1->table_size * sizeof *h1->hash;
h2->hash = hash_table_alloc_bytes (hash_bytes);
@ -4963,12 +4983,15 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
next[i] = i + 1;
next[new_size - 1] = -1;
Lisp_Object *key_and_value
= hash_table_alloc_bytes (2 * new_size * sizeof *key_and_value);
memcpy (key_and_value, h->key_and_value,
2 * old_size * sizeof *key_and_value);
for (ptrdiff_t i = 2 * old_size; i < 2 * new_size; i++)
key_and_value[i] = HASH_UNUSED_ENTRY_KEY;
Lisp_Object *key = hash_table_alloc_kv (h, new_size);
Lisp_Object *value = hash_table_alloc_kv (h, new_size);
memcpy (key, h->key, old_size * sizeof *key);
memcpy (value, h->value, old_size * sizeof *value);
for (ptrdiff_t i = old_size; i < new_size; i++)
{
key[i] = HASH_UNUSED_ENTRY_KEY;
value[i] = Qnil;
}
hash_hash_t *hash = hash_table_alloc_bytes (new_size * sizeof *hash);
memcpy (hash, h->hash, old_size * sizeof *hash);
@ -4988,9 +5011,12 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
hash_table_free_bytes (h->index, old_index_size * sizeof *h->index);
h->index = index;
hash_table_free_bytes (h->key_and_value,
2 * old_size * sizeof *h->key_and_value);
h->key_and_value = key_and_value;
Lisp_Object *old = h->key;
h->key = key;
hash_table_free_kv (h, old);
old = h->value;
h->value = value;
hash_table_free_kv (h, old);
hash_table_free_bytes (h->hash, old_size * sizeof *h->hash);
h->hash = hash;
@ -4998,8 +5024,6 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
hash_table_free_bytes (h->next, old_size * sizeof *h->next);
h->next = next;
h->key_and_value = key_and_value;
/* Rehash: all data occupy entries 0..old_size-1. */
for (ptrdiff_t i = 0; i < old_size; i++)
{
@ -5043,7 +5067,8 @@ hash_table_thaw (Lisp_Object hash_table)
if (size == 0)
{
h->key_and_value = NULL;
h->key = NULL;
h->value = NULL;
h->hash = NULL;
h->next = NULL;
h->index_bits = 0;
@ -5054,6 +5079,11 @@ hash_table_thaw (Lisp_Object hash_table)
ptrdiff_t index_bits = compute_hash_index_bits (size);
h->index_bits = index_bits;
#ifdef HAVE_MPS
eassert (pdumper_object_p (h->key));
eassert (pdumper_object_p (h->value));
#endif
h->hash = hash_table_alloc_bytes (size * sizeof *h->hash);
h->next = hash_table_alloc_bytes (size * sizeof *h->next);
@ -5215,11 +5245,11 @@ hash_clear (struct Lisp_Hash_Table *h)
}
}
/************************************************************************
Weak Hash Tables
************************************************************************/
#ifndef HAVE_MPS
/* Whether to keep an entry whose key and value are known to be retained
if STRONG_KEY and STRONG_VALUE, respectively, are true. */
@ -5317,6 +5347,8 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
return marked;
}
#endif // not HAVE_MPS
/***********************************************************************
Hash Code Computation
@ -5504,7 +5536,11 @@ sxhash_obj (Lisp_Object obj, int depth)
return XUFIXNUM (obj);
case Lisp_Symbol:
#ifdef HAVE_MPS
return igc_hash (obj);
#else
return XHASH (obj);
#endif
case Lisp_String:
return hash_string (SSDATA (obj), SBYTES (obj));
@ -5532,8 +5568,15 @@ sxhash_obj (Lisp_Object obj, int depth)
{
ptrdiff_t bytepos
= XMARKER (obj)->buffer ? XMARKER (obj)->bytepos : 0;
EMACS_UINT hash
= sxhash_combine ((intptr_t) XMARKER (obj)->buffer, bytepos);
EMACS_UINT hash;
#ifdef HAVE_MPS
Lisp_Object buf;
XSETBUFFER (buf, XMARKER (obj)->buffer);
hash = igc_hash (buf);
#else
hash = (intptr_t) XMARKER (obj)->buffer;
#endif
hash = sxhash_combine (hash, bytepos);
return hash;
}
else if (pvec_type == PVEC_BOOL_VECTOR)
@ -5552,7 +5595,11 @@ sxhash_obj (Lisp_Object obj, int depth)
/* Others are 'equal' if they are 'eq', so take their
address as hash. */
#ifdef HAVE_MPS
return igc_hash (obj);
#else
return XHASH (obj);
#endif
}
}
@ -5663,6 +5710,7 @@ struct hash_table_user_test
static struct hash_table_user_test *hash_table_user_tests = NULL;
#ifndef HAVE_MPS
void
mark_fns (void)
{
@ -5674,6 +5722,7 @@ mark_fns (void)
mark_object (ut->test.user_hash_function);
}
}
#endif // not HAVE_MPS
/* Find the hash_table_test object corresponding to the (bare) symbol TEST,
creating one if none existed. */

3
src/fringe.c
View file

@ -1781,6 +1781,7 @@ If nil, also continue lines which are exactly as wide as the window. */);
Vfringe_bitmaps = Qnil;
}
#ifndef HAVE_MPS
/* Garbage collection hook */
void
@ -1788,6 +1789,8 @@ mark_fringe_data (void)
{
mark_objects (fringe_faces, max_fringe_bitmaps);
}
#endif // not HAVE_MPS
/* Initialize this module when Emacs starts. */

2681
src/igc.c Normal file
View file

File diff suppressed because it is too large Load diff

101
src/igc.h Normal file
View file

@ -0,0 +1,101 @@
/* Fundamental definitions for GNU Emacs Lisp interpreter. -*- coding: utf-8 -*-
Copyright (C) 2024 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef EMACS_IGC_H
#define EMACS_IGC_H
#include "config.h"
#include "lisp.h"
#ifdef HAVE_MPS
/* Assertions. */
# define IGC_DEBUG 1
/* If defined, allocate conses from MPS. */
# define IGC_MANAGE_CONS 1
# define IGC_MANAGE_SYMBOLS 1
/* If defined, use a debug AMS pool, and check fenceposts etc.
See MPS docs. Can be slow. */
# define IGC_DEBUG_POOL 1
void igc_break (void);
void init_igc (void);
void syms_of_igc (void);
void *igc_thread_add (struct thread_state *ts);
void igc_thread_remove (void *info);
void igc_on_idle (void);
void igc_on_pdump_loaded (void *start, void *end);
void igc_on_face_cache_change (void *face_cache);
void igc_process_messages (void);
Lisp_Object igc_make_cons (Lisp_Object car, Lisp_Object cdr);
Lisp_Object igc_alloc_symbol (void);
struct Lisp_Buffer_Local_Value *igc_alloc_blv (void);
void *igc_xzalloc_ambig (size_t size);
void igc_xfree (void *p);
Lisp_Object *igc_xalloc_lisp_objs_exact (size_t n);
void *igc_xpalloc_ambig (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
ptrdiff_t nitems_max, ptrdiff_t item_size);
void *igc_xnrealloc_ambig (void *pa, ptrdiff_t nitems, ptrdiff_t item_size);
struct Lisp_Vector *igc_alloc_pseudovector (size_t nwords_mem,
size_t nwords_lisp,
size_t nwords_zero,
enum pvec_type tag);
struct Lisp_Vector *igc_alloc_vector (ptrdiff_t len);
struct Lisp_Vector *igc_alloc_record (ptrdiff_t len);
struct itree_node *igc_make_itree_node (void);
struct itree_tree *igc_make_itree_tree (void);
struct image *igc_make_image (void);
struct face *igc_make_face (void);
struct face_cache *igc_make_face_cache (void);
struct interval *igc_make_interval (void);
Lisp_Object igc_make_string (size_t nchars, size_t nbytes, bool unibyte,
bool clear);
Lisp_Object igc_make_multibyte_string (size_t nchars, size_t nbytes,
bool clear);
Lisp_Object igc_make_unibyte_string (size_t nchars, size_t nbytes, bool clear);
Lisp_Object igc_make_float (double val);
int igc_valid_lisp_object_p (Lisp_Object obj);
unsigned char *igc_replace_char (Lisp_Object string, ptrdiff_t at_byte_pos,
ptrdiff_t old_char_len,
ptrdiff_t new_char_len);
size_t igc_hash (Lisp_Object key);
void igc_create_charset_root (void *table, size_t size);
specpdl_ref igc_park_arena (void);
void igc_check_vector (const struct Lisp_Vector *v);
void igc_postmortem (void);
void igc_on_grow_specpdl (void);
void igc_on_alloc_main_thread_specpdl (void);
void igc_on_alloc_main_thread_bc (void);
void igc_check_symbol (void *p);
void igc_collect (void);
void igc_root_create_ambig (void *start, void *end);
# define eassert_not_mps() eassert (false)
#else
# define igc_break() (void) 0
# define eassert_not_mps() (void) 0
#endif // HAVE_MPS
#endif // EMACS_IGC_H

18
src/image.c
View file

@ -50,6 +50,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "termhooks.h"
#include "font.h"
#include "pdumper.h"
#include "igc.h"
#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
@ -1662,7 +1663,11 @@ or omitted means use the selected frame. */)
static struct image *
make_image (Lisp_Object spec, EMACS_UINT hash)
{
#ifdef HAVE_MPS
struct image *img = igc_make_image ();
#else
struct image *img = xzalloc (sizeof *img);
#endif
Lisp_Object file = image_spec_value (spec, QCfile, NULL);
eassert (valid_image_p (spec));
@ -1720,7 +1725,9 @@ free_image (struct frame *f, struct image *img)
img->type->free_img (f, img);
xfree (img->face_font_family);
#ifndef HAVE_MPS
xfree (img);
#endif
}
}
@ -2110,7 +2117,11 @@ make_image_cache (void)
c->size = 50;
c->used = c->refcount = 0;
#ifdef HAVE_MPS
c->images = igc_xzalloc_ambig (c->size * sizeof *c->images);
#else
c->images = xmalloc (c->size * sizeof *c->images);
#endif
c->buckets = xzalloc (IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets);
return c;
}
@ -2228,7 +2239,11 @@ free_image_cache (struct frame *f)
for (i = 0; i < c->used; ++i)
free_image (f, c->images[i]);
#ifdef HAVE_MPS
igc_xfree (c->images);
#else
xfree (c->images);
#endif
xfree (c->buckets);
xfree (c);
FRAME_IMAGE_CACHE (f) = NULL;
@ -3632,6 +3647,7 @@ anim_get_animation_cache (Lisp_Object spec)
Lisp Objects in the image cache. */
/* Mark Lisp objects in image IMG. */
#ifndef HAVE_MPS
static void
mark_image (struct image *img)
@ -3643,7 +3659,6 @@ mark_image (struct image *img)
mark_object (img->lisp_data);
}
void
mark_image_cache (struct image_cache *c)
{
@ -3661,6 +3676,7 @@ mark_image_cache (struct image_cache *c)
#endif
}
#endif // not HAVE_MPS
/***********************************************************************

7
src/itree.c
View file

@ -19,6 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include <math.h>
#include "igc.h"
#include "itree.h"
@ -468,7 +469,11 @@ itree_node_end (struct itree_tree *tree,
struct itree_tree *
itree_create (void)
{
#ifdef HAVE_MPS
struct itree_tree *tree = igc_make_itree_tree ();
#else
struct itree_tree *tree = xmalloc (sizeof (*tree));
#endif
itree_clear (tree);
return tree;
}
@ -498,7 +503,9 @@ void
itree_destroy (struct itree_tree *tree)
{
eassert (tree->root == NULL);
#ifndef HAVE_MPS
xfree (tree);
#endif
}
/* Return the number of nodes in TREE. */

22
src/keyboard.c
View file

@ -23,6 +23,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <sys/stat.h>
#include "lisp.h"
#include "igc.h"
#include "coding.h"
#include "termchar.h"
#include "termopts.h"
@ -4686,6 +4687,10 @@ timer_check_2 (Lisp_Object timers, Lisp_Object idle_timers)
: make_timespec (0, 0));
}
#ifdef HAVE_MPS
igc_on_idle ();
#endif
while (CONSP (timers) || CONSP (idle_timers))
{
Lisp_Object timer = Qnil, idle_timer = Qnil;
@ -12581,7 +12586,11 @@ init_kboard (KBOARD *kb, Lisp_Object type)
KBOARD *
allocate_kboard (Lisp_Object type)
{
#ifdef HAVE_MPS
KBOARD *kb = igc_xzalloc_ambig (sizeof *kb);
#else
KBOARD *kb = xmalloc (sizeof *kb);
#endif
init_kboard (kb, type);
kb->next_kboard = all_kboards;
@ -12597,7 +12606,11 @@ allocate_kboard (Lisp_Object type)
static void
wipe_kboard (KBOARD *kb)
{
#ifdef HAVE_MPS
igc_xfree (kb->kbd_macro_buffer);
#else
xfree (kb->kbd_macro_buffer);
#endif
}
/* Free KB and memory referenced from it. */
@ -12624,12 +12637,19 @@ delete_kboard (KBOARD *kb)
}
wipe_kboard (kb);
#ifdef HAVE_MPS
igc_xfree (kb);
#else
xfree (kb);
#endif
}
void
init_keyboard (void)
{
#ifdef HAVE_MPS
igc_root_create_ambig (kbd_buffer, (char *) kbd_buffer + ARRAYELTS (kbd_buffer));
#endif
/* This is correct before outermost invocation of the editor loop. */
command_loop_level = -1;
quit_char = Ctl ('g');
@ -13965,6 +13985,7 @@ keys_of_keyboard (void)
"handle-move-frame");
}
#ifndef HAVE_MPS
/* Mark the pointers in the kboard objects.
Called by Fgarbage_collect. */
void
@ -14018,3 +14039,4 @@ mark_kboards (void)
}
}
}
#endif // not HAVE_MPS

145
src/lisp.h
View file

@ -1016,7 +1016,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
with PVEC_TYPE_MASK to indicate the actual type. */
enum pvec_type
{
PVEC_NORMAL_VECTOR, /* Should be first, for sxhash_obj. */
PVEC_NORMAL_VECTOR, /* Should be first, for sxhash_obj. */
PVEC_FREE,
PVEC_BIGNUM,
PVEC_MARKER,
@ -2530,6 +2530,7 @@ obarray_iter_symbol (obarray_iter_t *it)
/* The structure of a Lisp hash table. */
struct Lisp_Hash_Table;
struct hash_impl;
/* The type of a hash value stored in the table.
It's unsigned and a subtype of EMACS_UINT. */
@ -2617,12 +2618,11 @@ struct Lisp_Hash_Table
This vector is table_size entries long. */
hash_hash_t *hash;
/* Vector of keys and values. The key of item I is found at index
2 * I, the value is found at index 2 * I + 1.
If the key is HASH_UNUSED_ENTRY_KEY, then this slot is unused.
This is gc_marked specially if the table is weak.
This vector is 2 * table_size entries long. */
Lisp_Object *key_and_value;
/* Vectors of keys and values. If the key is HASH_UNUSED_ENTRY_KEY,
then this slot is unused. This is gc_marked specially if the table
is weak. */
Lisp_Object *key;
Lisp_Object *value;
/* The comparison and hash functions. */
const struct hash_table_test *test;
@ -2705,7 +2705,7 @@ INLINE Lisp_Object
HASH_KEY (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
eassert (idx >= 0 && idx < h->table_size);
return h->key_and_value[2 * idx];
return h->key[idx];
}
/* Value is the value part of entry IDX in hash table H. */
@ -2713,7 +2713,7 @@ INLINE Lisp_Object
HASH_VALUE (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
eassert (idx >= 0 && idx < h->table_size);
return h->key_and_value[2 * idx + 1];
return h->value[idx];
}
/* Value is the hash code computed for entry IDX in hash table H. */
@ -2748,21 +2748,22 @@ hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key)
/* Iterate K and V as key and value of valid entries in hash table H.
The body may remove the current entry or alter its value slot, but not
mutate TABLE in any other way. */
#define DOHASH(h, k, v) \
for (Lisp_Object *dohash_##k##_##v##_kv = (h)->key_and_value, \
*dohash_##k##_##v##_end = dohash_##k##_##v##_kv \
+ 2 * HASH_TABLE_SIZE (h), \
*dohash_##k##_##v##_base = dohash_##k##_##v##_kv, \
# define DOHASH(h, k, v) \
for (Lisp_Object *dohash_##k##_##v##_k = (h)->key, \
*dohash_##k##_##v##_v = (h)->value, \
*dohash_##k##_##v##_end = dohash_##k##_##v##_k \
+ HASH_TABLE_SIZE (h), \
*dohash_##k##_##v##_base = dohash_##k##_##v##_k, \
k, v; \
dohash_##k##_##v##_kv < dohash_##k##_##v##_end \
&& (k = dohash_##k##_##v##_kv[0], \
v = dohash_##k##_##v##_kv[1], /*maybe unused*/ (void)v, \
dohash_##k##_##v##_k < dohash_##k##_##v##_end \
&& (k = dohash_##k##_##v##_k[0], \
v = dohash_##k##_##v##_v[0], /*maybe unused*/ (void)v, \
true); \
eassert (dohash_##k##_##v##_base == (h)->key_and_value \
eassert (dohash_##k##_##v##_base == (h)->key \
&& dohash_##k##_##v##_end \
== dohash_##k##_##v##_base \
+ 2 * HASH_TABLE_SIZE (h)), \
dohash_##k##_##v##_kv += 2) \
+ HASH_TABLE_SIZE (h)), \
++dohash_##k##_##v##_k, ++dohash_##k##_##v##_v) \
if (hash_unused_entry_key_p (k)) \
; \
else
@ -2962,6 +2963,7 @@ struct Lisp_Finalizer
extern struct Lisp_Finalizer finalizers;
extern struct Lisp_Finalizer doomed_finalizers;
void unchain_finalizer (struct Lisp_Finalizer *finalizer);
INLINE bool
FINALIZERP (Lisp_Object x)
@ -3182,14 +3184,15 @@ XBUFFER_OBJFWD (lispfwd a)
/* Lisp floating point type. */
struct Lisp_Float
{
int type;
union
{
union
{
double data;
struct Lisp_Float *chain;
GCALIGNED_UNION_MEMBER
} u;
};
double data;
struct Lisp_Float *chain;
GCALIGNED_UNION_MEMBER
} u;
};
verify (GCALIGNED (struct Lisp_Float));
INLINE bool
@ -3578,7 +3581,8 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd const *, char const *);
used all over the place, needs to be fast, and needs to know the size of
union specbinding. But only eval.c should access it. */
enum specbind_tag {
enum specbind_tag
{
SPECPDL_UNWIND, /* An unwind_protect function on Lisp_Object. */
SPECPDL_UNWIND_ARRAY, /* Likewise, on an array that needs freeing.
Its elements are potential Lisp_Objects. */
@ -3997,14 +4001,14 @@ INLINE void
set_hash_key_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
{
eassert (idx >= 0 && idx < h->table_size);
h->key_and_value[2 * idx] = val;
h->key[idx] = val;
}
INLINE void
set_hash_value_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
{
eassert (idx >= 0 && idx < h->table_size);
h->key_and_value[2 * idx + 1] = val;;
h->value[idx] = val;;
}
/* Use these functions to set Lisp_Object
@ -4434,6 +4438,8 @@ extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t,
ptrdiff_t *, ptrdiff_t *);
/* Defined in alloc.c. */
struct Lisp_Vector *allocate_vectorlike (ptrdiff_t len, bool clearit);
extern void run_finalizer_function (Lisp_Object function);
extern void *my_heap_start (void);
extern void check_pure_size (void);
unsigned char *resize_string_data (Lisp_Object, ptrdiff_t, int, int);
@ -4670,7 +4676,9 @@ extern Lisp_Object make_float (double);
extern void display_malloc_warning (void);
extern specpdl_ref inhibit_garbage_collection (void);
extern Lisp_Object build_symbol_with_pos (Lisp_Object, Lisp_Object);
#ifndef HAVE_MPS
extern void free_cons (struct Lisp_Cons *);
#endif
extern void init_alloc_once (void);
extern void init_alloc (void);
extern void syms_of_alloc (void);
@ -4679,6 +4687,8 @@ extern int valid_lisp_object_p (Lisp_Object);
void *hash_table_alloc_bytes (ptrdiff_t nbytes) ATTRIBUTE_MALLOC_SIZE ((1));
void hash_table_free_bytes (void *p, ptrdiff_t nbytes);
Lisp_Object *hash_table_alloc_kv (struct Lisp_Hash_Table *h, ptrdiff_t nobjs);
void hash_table_free_kv (struct Lisp_Hash_Table *h, Lisp_Object *p);
/* Defined in gmalloc.c. */
#if !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC && !defined SYSTEM_MALLOC
@ -4741,6 +4751,67 @@ extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char *, ptrdiff_t,
ATTRIBUTE_FORMAT_PRINTF (5, 0);
/* Defined in lread.c. */
/* When an object is read, the type of the top read stack entry indicates
the syntactic context. */
enum read_entry_type
{
/* preceding syntactic context */
RE_list_start, /* "(" */
RE_list, /* "(" (+ OBJECT) */
RE_list_dot, /* "(" (+ OBJECT) "." */
RE_vector, /* "[" (* OBJECT) */
RE_record, /* "#s(" (* OBJECT) */
RE_char_table, /* "#^[" (* OBJECT) */
RE_sub_char_table, /* "#^^[" (* OBJECT) */
RE_byte_code, /* "#[" (* OBJECT) */
RE_string_props, /* "#(" (* OBJECT) */
RE_special, /* "'" | "#'" | "`" | "," | ",@" */
RE_numbered, /* "#" (+ DIGIT) "=" */
};
struct read_stack_entry
{
enum read_entry_type type;
union {
/* RE_list, RE_list_dot */
struct {
Lisp_Object head; /* first cons of list */
Lisp_Object tail; /* last cons of list */
} list;
/* RE_vector, RE_record, RE_char_table, RE_sub_char_table,
RE_byte_code, RE_string_props */
struct {
Lisp_Object elems; /* list of elements in reverse order */
bool old_locate_syms; /* old value of locate_syms */
} vector;
/* RE_special */
struct {
Lisp_Object symbol; /* symbol from special syntax */
} special;
/* RE_numbered */
struct {
Lisp_Object number; /* number as a fixnum */
Lisp_Object placeholder; /* placeholder object */
} numbered;
} u;
};
struct read_stack
{
struct read_stack_entry *stack; /* base of stack */
ptrdiff_t size; /* allocated size in entries */
ptrdiff_t sp; /* current number of entries */
};
extern struct read_stack rdstack;
extern Lisp_Object intern_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object);
@ -4905,6 +4976,9 @@ XMODULE_FUNCTION (Lisp_Object o)
typedef void (*module_funcptr) (void);
/* Defined in alloc.c. */
void set_string_marked (struct Lisp_String *s);
void mark_interval_tree (INTERVAL i);
extern Lisp_Object make_user_ptr (void (*finalizer) (void *), void *p);
/* Defined in emacs-module.c. */
@ -5249,6 +5323,9 @@ extern Lisp_Object get_byte_code_arity (Lisp_Object);
extern void init_bc_thread (struct bc_thread_state *bc);
extern void free_bc_thread (struct bc_thread_state *bc);
extern void mark_bytecode (struct bc_thread_state *bc);
#ifdef HAVE_MPS
extern void *bc_next_frame (struct bc_frame *bc);
# endif
INLINE struct bc_frame *
get_act_rec (struct thread_state *th)
@ -5745,7 +5822,13 @@ safe_free_unbind_to (specpdl_ref count, specpdl_ref sa_count, Lisp_Object val)
#endif
#ifndef USE_STACK_LISP_OBJECTS
# define USE_STACK_LISP_OBJECTS true
#endif
# endif
# ifdef HAVE_MPS
# undef USE_STACK_LISP_OBJECTS
# define USE_STACK_LISP_OBJECTS false
# endif
#ifdef GC_CHECK_STRING_BYTES
enum { defined_GC_CHECK_STRING_BYTES = true };

71
src/lread.c
View file

@ -31,6 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <math.h>
#include <stat-time.h>
#include "lisp.h"
#include "igc.h"
#include "dispextern.h"
#include "intervals.h"
#include "character.h"
@ -305,7 +306,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
ptrdiff_t pt_byte = BUF_PT_BYTE (inbuffer);
if (! BUFFER_LIVE_P (inbuffer))
if (!BUFFER_LIVE_P (inbuffer))
return -1;
if (pt_byte >= BUF_ZV_BYTE (inbuffer))
@ -2391,6 +2392,7 @@ readevalloop_1 (int old)
static AVOID
end_of_file_error (void)
{
igc_break ();
if (STRINGP (Vload_true_file_name))
xsignal1 (Qend_of_file, Vload_true_file_name);
@ -3483,7 +3485,9 @@ vector_from_rev_list (Lisp_Object elems)
{
vec[i] = XCAR (elems);
Lisp_Object next = XCDR (elems);
#ifndef HAVE_MPS
free_cons (XCONS (elems));
#endif
elems = next;
}
return obj;
@ -3540,8 +3544,10 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun)
Convert them back to the original unibyte form. */
vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
#ifndef HAVE_MPS
/* Bytecode must be immovable. */
pin_string (vec[COMPILED_BYTECODE]);
#endif
XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED);
return obj;
@ -3814,67 +3820,9 @@ skip_space_and_comments (Lisp_Object readcharfun)
UNREAD (c);
}
/* When an object is read, the type of the top read stack entry indicates
the syntactic context. */
enum read_entry_type
{
/* preceding syntactic context */
RE_list_start, /* "(" */
RE_list, /* "(" (+ OBJECT) */
RE_list_dot, /* "(" (+ OBJECT) "." */
RE_vector, /* "[" (* OBJECT) */
RE_record, /* "#s(" (* OBJECT) */
RE_char_table, /* "#^[" (* OBJECT) */
RE_sub_char_table, /* "#^^[" (* OBJECT) */
RE_byte_code, /* "#[" (* OBJECT) */
RE_string_props, /* "#(" (* OBJECT) */
RE_special, /* "'" | "#'" | "`" | "," | ",@" */
RE_numbered, /* "#" (+ DIGIT) "=" */
};
struct read_stack_entry
{
enum read_entry_type type;
union {
/* RE_list, RE_list_dot */
struct {
Lisp_Object head; /* first cons of list */
Lisp_Object tail; /* last cons of list */
} list;
/* RE_vector, RE_record, RE_char_table, RE_sub_char_table,
RE_byte_code, RE_string_props */
struct {
Lisp_Object elems; /* list of elements in reverse order */
bool old_locate_syms; /* old value of locate_syms */
} vector;
/* RE_special */
struct {
Lisp_Object symbol; /* symbol from special syntax */
} special;
/* RE_numbered */
struct {
Lisp_Object number; /* number as a fixnum */
Lisp_Object placeholder; /* placeholder object */
} numbered;
} u;
};
struct read_stack
{
struct read_stack_entry *stack; /* base of stack */
ptrdiff_t size; /* allocated size in entries */
ptrdiff_t sp; /* current number of entries */
};
static struct read_stack rdstack = {NULL, 0, 0};
struct read_stack rdstack = {NULL, 0, 0};
#ifndef HAVE_MPS
void
mark_lread (void)
{
@ -3909,6 +3857,7 @@ mark_lread (void)
}
}
}
#endif // not HAVE_MPS
static inline struct read_stack_entry *
read_stack_top (void)

33
src/macros.c
View file

@ -22,6 +22,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "macros.h"
#include "igc.h"
#include "window.h"
#include "keyboard.h"
@ -55,7 +56,11 @@ macro before appending to it. */)
if (!current_kboard->kbd_macro_buffer)
{
#ifdef HAVE_MPS
current_kboard->kbd_macro_buffer = igc_xzalloc_ambig (30 * word_size);
#else
current_kboard->kbd_macro_buffer = xmalloc (30 * word_size);
#endif
current_kboard->kbd_macro_bufsize = 30;
current_kboard->kbd_macro_ptr = current_kboard->kbd_macro_buffer;
current_kboard->kbd_macro_end = current_kboard->kbd_macro_buffer;
@ -65,9 +70,13 @@ macro before appending to it. */)
{
if (current_kboard->kbd_macro_bufsize > 200)
{
#ifdef HAVE_MPS
current_kboard->kbd_macro_buffer = igc_xnrealloc_ambig
(current_kboard->kbd_macro_buffer, 30, word_size);
#else
current_kboard->kbd_macro_buffer
= xrealloc (current_kboard->kbd_macro_buffer,
30 * word_size);
= xrealloc (current_kboard->kbd_macro_buffer, 30 * word_size);
#endif
current_kboard->kbd_macro_bufsize = 30;
}
current_kboard->kbd_macro_ptr = current_kboard->kbd_macro_buffer;
@ -86,11 +95,21 @@ macro before appending to it. */)
/* Copy last-kbd-macro into the buffer, in case the Lisp code
has put another macro there. */
if (current_kboard->kbd_macro_bufsize - incr < len)
current_kboard->kbd_macro_buffer =
xpalloc (current_kboard->kbd_macro_buffer,
&current_kboard->kbd_macro_bufsize,
len - current_kboard->kbd_macro_bufsize + incr, -1,
sizeof *current_kboard->kbd_macro_buffer);
{
#ifdef HAVE_MPS
current_kboard->kbd_macro_buffer
= igc_xpalloc_ambig (current_kboard->kbd_macro_buffer,
&current_kboard->kbd_macro_bufsize,
len - current_kboard->kbd_macro_bufsize + incr, -1,
sizeof *current_kboard->kbd_macro_buffer);
#else
current_kboard->kbd_macro_buffer
= xpalloc (current_kboard->kbd_macro_buffer,
&current_kboard->kbd_macro_bufsize,
len - current_kboard->kbd_macro_bufsize + incr, -1,
sizeof *current_kboard->kbd_macro_buffer);
#endif
}
/* Must convert meta modifier when copying string to vector. */
cvt = STRINGP (KVAR (current_kboard, Vlast_kbd_macro));

2
src/nsterm.m
View file

@ -10073,12 +10073,14 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
- (void) mark
{
#ifndef HAVE_MPS
if (window)
{
Lisp_Object win;
XSETWINDOW (win, window);
mark_object (win);
}
#endif
}

124
src/pdumper.c
View file

@ -38,6 +38,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "frame.h"
#include "intervals.h"
#include "lisp.h"
#include "igc.h"
#include "pdumper.h"
#include "window.h"
#include "sysstdio.h"
@ -1355,11 +1356,21 @@ dump_enqueue_object (struct dump_context *ctx,
/* Note that we call dump_queue_enqueue even if the object
is already on the normal queue: multiple enqueue calls
can increase the object's weight. */
if (state == DUMP_OBJECT_ON_NORMAL_QUEUE)
dump_queue_enqueue (&ctx->dump_queue,
object,
ctx->offset,
weight);
if (state == DUMP_OBJECT_ON_NORMAL_QUEUE)
{
#if 0
if (XTYPE (object) == Lisp_Vectorlike)
{
struct Lisp_Vector *v = XVECTOR (object);
void *p = v;
if (p == (void *) 0x000000017362d8a8)
igc_break ();
}
#endif
dump_queue_enqueue (&ctx->dump_queue, object, ctx->offset,
weight);
}
}
}
/* Always remember the path to this object. */
@ -2640,21 +2651,21 @@ dump_vectorlike_generic (struct dump_context *ctx,
/* Return a vector of KEY, VALUE pairs in the given hash table H.
No room for growth is included. */
static Lisp_Object *
hash_table_contents (struct Lisp_Hash_Table *h)
static void
hash_table_contents (struct Lisp_Hash_Table *h, Lisp_Object **key,
Lisp_Object **value)
{
ptrdiff_t size = h->count;
Lisp_Object *key_and_value = hash_table_alloc_bytes (2 * size
* sizeof *key_and_value);
*key = hash_table_alloc_kv (h, size);
*value = hash_table_alloc_kv (h, size);
ptrdiff_t n = 0;
DOHASH (h, k, v)
{
key_and_value[n++] = k;
key_and_value[n++] = v;
(*key)[n] = k;
(*value)[n] = v;
++n;
}
return key_and_value;
}
static void
@ -2683,7 +2694,10 @@ hash_table_std_test (const struct hash_table_test *t)
static void
hash_table_freeze (struct Lisp_Hash_Table *h)
{
h->key_and_value = hash_table_contents (h);
Lisp_Object *key, *value;
hash_table_contents (h, &key, &value);
h->key = key;
h->value = value;
h->next = NULL;
h->hash = NULL;
h->index = NULL;
@ -2694,11 +2708,11 @@ hash_table_freeze (struct Lisp_Hash_Table *h)
}
static dump_off
dump_hash_table_contents (struct dump_context *ctx, struct Lisp_Hash_Table *h)
dump_hash_table_key (struct dump_context *ctx, struct Lisp_Hash_Table *h)
{
dump_align_output (ctx, DUMP_ALIGNMENT);
dump_off start_offset = ctx->offset;
ptrdiff_t n = 2 * h->count;
ptrdiff_t n = h->count;
struct dump_flags old_flags = ctx->flags;
ctx->flags.pack_objects = true;
@ -2706,7 +2720,30 @@ dump_hash_table_contents (struct dump_context *ctx, struct Lisp_Hash_Table *h)
for (ptrdiff_t i = 0; i < n; i++)
{
Lisp_Object out;
const Lisp_Object *slot = &h->key_and_value[i];
const Lisp_Object *slot = &h->key[i];
dump_object_start (ctx, &out, sizeof out);
dump_field_lv (ctx, &out, slot, slot, WEIGHT_STRONG);
dump_object_finish (ctx, &out, sizeof out);
}
ctx->flags = old_flags;
return start_offset;
}
static dump_off
dump_hash_table_value (struct dump_context *ctx, struct Lisp_Hash_Table *h)
{
dump_align_output (ctx, DUMP_ALIGNMENT);
dump_off start_offset = ctx->offset;
ptrdiff_t n = h->count;
struct dump_flags old_flags = ctx->flags;
ctx->flags.pack_objects = true;
for (ptrdiff_t i = 0; i < n; i++)
{
Lisp_Object out;
const Lisp_Object *slot = &h->value[i];
dump_object_start (ctx, &out, sizeof out);
dump_field_lv (ctx, &out, slot, slot, WEIGHT_STRONG);
dump_object_finish (ctx, &out, sizeof out);
@ -2736,15 +2773,22 @@ dump_hash_table (struct dump_context *ctx, Lisp_Object object)
DUMP_FIELD_COPY (out, hash, purecopy);
DUMP_FIELD_COPY (out, hash, mutable);
DUMP_FIELD_COPY (out, hash, frozen_test);
if (hash->key_and_value)
dump_field_fixup_later (ctx, out, hash, &hash->key_and_value);
if (hash->key)
dump_field_fixup_later (ctx, out, hash, &hash->key);
if (hash->value)
dump_field_fixup_later (ctx, out, hash, &hash->value);
eassert (hash->next_weak == NULL);
dump_off offset = finish_dump_pvec (ctx, &out->header);
if (hash->key_and_value)
if (hash->key)
dump_remember_fixup_ptr_raw
(ctx,
offset + dump_offsetof (struct Lisp_Hash_Table, key_and_value),
dump_hash_table_contents (ctx, hash));
offset + dump_offsetof (struct Lisp_Hash_Table, key),
dump_hash_table_key (ctx, hash));
if (hash->value)
dump_remember_fixup_ptr_raw
(ctx,
offset + dump_offsetof (struct Lisp_Hash_Table, value),
dump_hash_table_value (ctx, hash));
return offset;
}
@ -4141,8 +4185,13 @@ types. */)
CALLN (Ffuncall, intern_c_string ("load--fixup-all-elns"));
#endif
#ifndef HAVE_MPS
check_pure_size ();
# endif
# ifndef HAVE_MPS
/* I don't think this can be guaranteed to work with MPS.
Finalizers may be kept alive unpredictably. */
/* Clear out any detritus in memory. */
do
{
@ -4150,8 +4199,14 @@ types. */)
garbage_collect ();
}
while (number_finalizers_run);
#endif
specpdl_ref count = SPECPDL_INDEX ();
Lisp_Object start_time = Ffloat_time (Qnil);
# ifdef HAVE_MPS
/* Turn off GC while dumping. This turns out to be the fastest option. */
igc_park_arena ();
#endif
/* Bind `command-line-processed' to nil before dumping,
so that the dumped Emacs will process its command line
@ -4379,19 +4434,21 @@ types. */)
ctx->buf_size = 0;
ctx->max_offset = 0;
Lisp_Object end_time = Ffloat_time (Qnil);
dump_off
header_bytes = header_end - header_start,
hot_bytes = hot_end - hot_start,
discardable_bytes = discardable_end - ctx->header.discardable_start,
cold_bytes = cold_end - ctx->header.cold_start;
fprintf (stderr,
("Dump complete\n"
"Byte counts: header=%"PRIdDUMP_OFF" hot=%"PRIdDUMP_OFF
" discardable=%"PRIdDUMP_OFF" cold=%"PRIdDUMP_OFF"\n"
"Reloc counts: hot=%"PRIdDUMP_OFF" discardable=%"PRIdDUMP_OFF"\n"),
("Dump complete (%.2f seconds)\n"
"Byte counts: header=%" PRIdDUMP_OFF " hot=%" PRIdDUMP_OFF
" discardable=%" PRIdDUMP_OFF " cold=%" PRIdDUMP_OFF "\n"
"Reloc counts: hot=%" PRIdDUMP_OFF
" discardable=%" PRIdDUMP_OFF "\n"),
XFLOAT_DATA (end_time) - XFLOAT_DATA (start_time),
header_bytes, hot_bytes, discardable_bytes, cold_bytes,
number_hot_relocations,
number_discardable_relocations);
number_hot_relocations, number_discardable_relocations);
unblock_input ();
return unbind_to (count, Qnil);
@ -5225,7 +5282,7 @@ dump_find_relocation (const struct dump_table_locator *const table,
return found;
}
static bool
bool
dump_loaded_p (void)
{
return dump_public.start != 0;
@ -5763,6 +5820,11 @@ pdumper_load (const char *dump_filename, char *argv0)
dump_public.start = dump_base;
dump_public.end = dump_public.start + dump_size;
#ifdef HAVE_MPS
void *hot_start = (void *) dump_base;
void *hot_end = (void *) (dump_base + adj_discardable_start);
#endif
dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS);
dump_do_all_emacs_relocations (header, dump_base);
@ -5805,6 +5867,10 @@ pdumper_load (const char *dump_filename, char *argv0)
dump_private.load_time = timespectod (load_timespec);
dump_private.dump_filename = dump_filename_copy;
# ifdef HAVE_MPS
igc_on_pdump_loaded (hot_start, hot_end);
# endif
out:
for (int i = 0; i < ARRAYELTS (sections); ++i)
dump_mmap_release (&sections[i]);

1
src/pdumper.h
View file

@ -276,6 +276,7 @@ extern void pdumper_record_wd (const char *);
void init_pdumper_once (void);
void syms_of_pdumper (void);
bool dump_loaded_p (void);
INLINE_HEADER_END
#endif

9
src/print.c
View file

@ -1452,10 +1452,11 @@ print_preprocess (Lisp_Object obj)
if (HASH_TABLE_P (obj))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
/* The values pushed here may include
HASH_UNUSED_ENTRY_KEY; see top of this function. */
pp_stack_push_values (h->key_and_value,
2 * h->table_size);
DOHASH (h, k, v)
{
pp_stack_push_value (k);
pp_stack_push_value (v);
}
}
break;
}

4
src/profiler.c
View file

@ -51,6 +51,7 @@ typedef struct {
int next_free; /* next free entry, -1 if all taken */
} log_t;
#ifndef HAVE_MPS
static void
mark_log (log_t *log)
{
@ -62,6 +63,7 @@ mark_log (log_t *log)
if (log->counts[i] > 0) /* Only mark valid keys. */
mark_objects (log->keys + i * depth, depth);
}
#endif // not HAVE_MPS
static log_t *
make_log (int size, int depth)
@ -686,6 +688,7 @@ the same lambda expression, or are really unrelated function. */)
return res ? Qt : Qnil;
}
#ifndef HAVE_MPS
void
mark_profiler (void)
{
@ -694,6 +697,7 @@ mark_profiler (void)
#endif
mark_log (memory.log);
}
#endif // not HAVE_MPS
void
syms_of_profiler (void)

5
src/puresize.h
View file

@ -17,7 +17,7 @@ You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef EMACS_PURESIZE_H
#define EMACS_PURESIZE_H
# define EMACS_PURESIZE_H
#include "lisp.h"
@ -73,8 +73,8 @@ INLINE_HEADER_BEGIN
#endif
/* This is the actual size in bytes to allocate. */
#ifndef PURESIZE
#define PURESIZE (BASE_PURESIZE * PURESIZE_RATIO * PURESIZE_CHECKING_RATIO)
#ifndef PURESIZE
#endif
extern AVOID pure_write_error (Lisp_Object);
@ -111,5 +111,4 @@ CHECK_IMPURE (Lisp_Object obj, void *ptr)
#endif
INLINE_HEADER_END
#endif /* EMACS_PURESIZE_H */

16
src/sort.c
View file

@ -32,6 +32,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include "lisp.h"
#include "igc.h"
/* Reverse a slice of a vector in place, from lo up to (exclusive) hi. */
@ -529,6 +530,8 @@ merge_init (merge_state *ms, const ptrdiff_t list_size,
static void
merge_markmem (void *arg)
{
#ifndef HAVE_MPS
merge_state *ms = arg;
eassume (ms != NULL);
@ -542,6 +545,7 @@ merge_markmem (void *arg)
eassume (src != NULL);
mark_objects (src, *ms->reloc.size);
}
#endif
}
@ -576,13 +580,21 @@ cleanup_mem (void *arg)
/* Free any remaining temp storage. */
if (ms->a.keys != ms->temparray)
{
#ifdef HAVE_MPS
igc_xfree (ms->a.keys);
# else
xfree (ms->a.keys);
#endif
ms->a.keys = NULL;
}
if (ms->allocated_keys != NULL)
{
#ifdef HAVE_MPS
igc_xfree (ms->allocated_keys);
#else
xfree (ms->allocated_keys);
#endif
ms->allocated_keys = NULL;
}
}
@ -621,7 +633,11 @@ merge_getmem (merge_state *ms, const ptrdiff_t need)
xfree (ms->a.keys);
}
ptrdiff_t bytes = (need * word_size) << (ms->a.values != NULL ? 1 : 0);
# ifdef HAVE_MPS
ms->a.keys = igc_xzalloc_ambig (bytes);
#else
ms->a.keys = xmalloc (bytes);
#endif
ms->alloced = need;
if (ms->a.values != NULL)
ms->a.values = &ms->a.keys[need];

25
src/thread.c
View file

@ -20,6 +20,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
#include <setjmp.h>
#include "lisp.h"
#include "igc.h"
#include "character.h"
#include "buffer.h"
#include "process.h"
@ -38,14 +39,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define release_select_lock() do { } while (0)
#endif
union aligned_thread_state
{
struct thread_state s;
GCALIGNED_UNION_MEMBER
};
verify (GCALIGNED (union aligned_thread_state));
static union aligned_thread_state main_thread
union aligned_thread_state main_thread
= {{
.header.size = PVECHEADERSIZE (PVEC_THREAD,
PSEUDOVECSIZE (struct thread_state,
@ -658,7 +652,7 @@ thread_select (select_func *func, int max_fds, fd_set *rfds,
}
#ifndef HAVE_MPS
static void
mark_one_thread (struct thread_state *thread)
{
@ -716,6 +710,7 @@ unmark_main_thread (void)
main_thread.s.header.size &= ~ARRAY_MARK_FLAG;
}
#endif // not HAVE_MPS
static void
@ -811,6 +806,10 @@ run_thread (void *state)
handlerlist_sentinel->nextfree = NULL;
handlerlist_sentinel->next = NULL;
#ifdef HAVE_MPS
self->gc_info = igc_thread_add (self);
#endif
/* It might be nice to do something with errors here. */
internal_condition_case (invoke_thread_function, Qt, record_thread_error);
@ -855,6 +854,10 @@ run_thread (void *state)
;
*iter = (*iter)->next_thread;
#ifdef HAVE_MPS
igc_thread_remove (self->gc_info);
#endif
release_global_lock ();
return NULL;
@ -907,7 +910,6 @@ If NAME is given, it must be a string; it names the new thread. */)
new_thread->m_specpdl_ptr = new_thread->m_specpdl;
init_bc_thread (&new_thread->bc);
sys_cond_init (&new_thread->thread_condvar);
/* We'll need locking here eventually. */
@ -1172,6 +1174,9 @@ init_threads (void)
main_thread.s.thread_id = sys_thread_self ();
init_bc_thread (&main_thread.s.bc);
#ifdef HAVE_MPS
igc_on_alloc_main_thread_bc ();
#endif
}
void

15
src/thread.h
View file

@ -19,6 +19,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef THREAD_H
#define THREAD_H
#include "config.h"
#include "regex-emacs.h"
#ifdef WINDOWSNT
@ -214,6 +215,11 @@ struct thread_state
struct thread_state *next_thread;
struct bc_thread_state bc;
# ifdef HAVE_MPS
void *gc_info;
# endif
} GCALIGNED_STRUCT;
INLINE bool
@ -337,6 +343,15 @@ int thread_select (select_func *func, int max_fds, fd_set *rfds,
bool thread_check_current_buffer (struct buffer *);
union aligned_thread_state
{
struct thread_state s;
GCALIGNED_UNION_MEMBER
};
verify (GCALIGNED (union aligned_thread_state));
extern union aligned_thread_state main_thread;
INLINE_HEADER_END
#endif /* THREAD_H */

37
src/xfaces.c
View file

@ -224,6 +224,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <math.h>
#include "lisp.h"
#include "igc.h"
#include "character.h"
#include "frame.h"
@ -303,11 +304,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define RESET_P(ATTR) EQ (ATTR, Qreset)
/* Size of hash table of realized faces in face caches (should be a
prime number). */
#define FACE_CACHE_BUCKETS_SIZE 1009
char unspecified_fg[] = "unspecified-fg", unspecified_bg[] = "unspecified-bg";
/* Alist of alternative font families. Each element is of the form
@ -4545,8 +4541,11 @@ static struct face *
make_realized_face (Lisp_Object *attr)
{
enum { off = offsetof (struct face, id) };
#ifdef HAVE_MPS
struct face *face = igc_make_face ();
#else
struct face *face = xmalloc (sizeof *face);
#endif
memcpy (face->lface, attr, sizeof face->lface);
memset (&face->id, 0, sizeof *face - off);
face->ascii_face = face;
@ -4594,7 +4593,9 @@ free_realized_face (struct frame *f, struct face *face)
}
#endif /* HAVE_WINDOW_SYSTEM */
#ifndef HAVE_MPS
xfree (face);
#endif
}
}
@ -4724,12 +4725,17 @@ the triangle inequality. */)
static struct face_cache *
make_face_cache (struct frame *f)
{
struct face_cache *c = xmalloc (sizeof *c);
struct face_cache *c;
#ifdef HAVE_MPS
c = igc_make_face_cache ();
#else
c = xmalloc (sizeof *c);
#endif
c->buckets = xzalloc (FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets);
c->size = 50;
c->used = 0;
c->faces_by_id = xmalloc (c->size * sizeof *c->faces_by_id);
c->faces_by_id = xzalloc (c->size * sizeof *c->faces_by_id);
c->f = f;
c->menu_face_changed_p = menu_face_changed_default;
return c;
@ -4837,9 +4843,15 @@ free_face_cache (struct face_cache *c)
if (c)
{
free_realized_faces (c);
xfree (c->buckets);
xfree (c->faces_by_id);
struct face **p = c->buckets;
c->buckets = NULL;
xfree (p);
p = c->faces_by_id;
c->faces_by_id = NULL;
xfree (p);
#ifndef HAVE_MPS
xfree (c);
#endif
}
}
@ -4910,8 +4922,9 @@ cache_face (struct face_cache *c, struct face *face, uintptr_t hash)
if (i == c->used)
{
if (c->used == c->size)
c->faces_by_id = xpalloc (c->faces_by_id, &c->size, 1, MAX_FACE_ID,
sizeof *c->faces_by_id);
c->faces_by_id
= xpalloc (c->faces_by_id, &c->size, 1, MAX_FACE_ID,
sizeof *c->faces_by_id);
c->used++;
}