Provide a new tree data-structure for overlays.

* src/itree.c
(interval_generator_narrow, interval_generator_next)
(interval_node_init, interval_node_begin)
(interval_node_end, interval_node_set_region)
(interval_tree_create, interval_tree_clear)
(interval_tree_init, interval_tree_destroy)
(interval_tree_size, interval_tree_insert)
(interval_tree_contains, interval_tree_remove)
(interval_tree_validate, interval_tree_iter_start)
(interval_tree_iter_finish, interval_tree_iter_next)
(interval_tree_iter_ensure_space, interval_tree_max_height)
(interval_tree_insert_gap, interval_tree_delete_gap)
(interval_generator_create, interval_generator_reset)
(interval_generator_ensure_space, interval_node_intersects)
(interval_generator_next, interval_generator_narrow)
(interval_generator_destroy, interval_stack_create)
(interval_stack_destroy, interval_stack_clear)
(interval_stack_ensure_space, interval_stack_push)
(interval_stack_push_flagged, interval_stack_pop)
(interval_tree_update_limit, interval_tree_inherit_offset)
(interval_tree_propagate_limit, interval_tree_rotate_left)
(interval_tree_rotate_right, interval_tree_insert_fix)
(interval_tree_remove_fix, interval_tree_transplant)
(interval_tree_subtree_min): New file and new functions.

* src/itree.h: New file.

* configure.ac: Create Makefile for manual overlay tests.

* src/Makefile.in: Add itree.o target.

* src/alloc.c (build_overlay, mark_overlay, mark_buffer)
(sweep_misc, sweep_buffers): Adapt to new tree data-structure.

* src/buffer.c (overlays_in, overlays_at): Remove unused arguments
prev_ptr and change_req, adapt to new data-structure and reuse
code.
(copy_overlays, drop_overlays, delete_all_overlays)
(reset_buffer, kill-buffer, buffer-swap-text, next_overlay_change)
(previous_overlay_change, mouse_face_overlay_overlaps)
(disable_line_numbers_overlay_at_eob, overlay_touches_p)
(overlay_strings, adjust_overlays_for_insert)
(adjust_overlays_for_delete, overlayp, make-overlay, move-overlay)
(delete-overlay, overlay-start, overlay-end, overlay-buffer)
(overlay-properties, overlays-at, overlays-in)
(next-overlay-change, previous-overlay-change, overlay-put)
(overlay-get, report_overlay_modification, evaporate_overlays)
(init_buffer_once): Adapt to changes and tree data-structure.
(overlay-lists, overlay-recenter): Funtions are now obsolete, but
kept anyway.
(set_buffer_overlays_before, set_buffer_overlays_after)
(recenter_overlay_lists,fix_start_end_in_overlays,fix_overlays_before)
(unchain_overlay,): Removed functions of the old list
data-structure.
(swap_buffer_overlays, make_sortvec_item): New functions.
(sort_overlays): Adapt to changes and tree data-structure.
(sortvec): Moved to buffer.h .
(make_lispy_interval_node, overlay_tree, overlay-tree)
[ITREE_DEBUG]: New debugging functions.

* src/buffer.h (overlays_before, overlays_after): Removed struct
member of the list data-structure.
(overlays): Added tree struct member.
(sortvec): Moved here from buffer.c .
(GET_OVERLAYS_AT): Adapt to changes.
(set_buffer_intervals, OVERLAY_START, OVERLAY_END, OVERLAY_PLIST):
Adapt to tree data-structure.
(OVERLAY_POSITION): Removed macro of the list data-structure.
(OVERLAY_REAR_ADVANCE_P, OVERLAY_FRONT_ADVANCE_P): New macros.
(overlay_start, overlay_end)
(set_overlay_region, maybe_alloc_buffer_overlays)
(free_buffer_overlays, add_buffer_overlay)
(remove_buffer_overlay, buffer_overlay_iter_start)
(buffer_overlay_iter_next, buffer_overlay_iter_finish)
(buffer_overlay_iter_narrow): New functions.
(compare_overlays, make_sortvec_item): Export functions.

* src/editfns.c (overlays_around): Reuse overlays_in.
(get-pos-property): Adapt to tree data-structure.
(transpose-regions): Remove call to deleted function.

* src/fileio.c: (insert-file-contents): Remove
references to deleted struct member.

* src/fns.c (internal_equal): Adapt to tree data-structure.

* src/indent.c (check_display_width): Adapt to tree
data-structure.
(skip_invisible): Remove call to deleted function.

* src/insdel.c (adjust_markers_for_insert): Remove calls to
deleted functions.

* src/intervals.c (adjust_for_invis_intang): Adapt to tree
data-structure.

* src/keyboard.c (adjust_point_for_property): Adapt to tree
data-structure.

* src/lisp.h (Lisp_Overlay): Modified struct layout.

* src/print.c (temp_output_buffer_setup, print_object): Adapt to
tree data-structure.

* src/textprop.c (get_char_property_and_overlay): Adapt to tree
data-structure.  Take advantage of the new data-structure.

* src/window.h (overlay_matches_window): New function.

* src/xdisp.h (next_overlay_change): Removed function.  Use
next-overlay-change, which does not use xmalloc anymore.
(handle_single_display_spec, load_overlay_strings)
(back_to_previous_visible_line_start, note_mouse_highlight): Adapt
to tree data-structure.
(move_it_to, display_line): Remove calls to deleted functions.

* src/xfaces.c (face_at_buffer_position): Adapt to changes and
tree data-structure.

* test/src/buffer-tests.el: Many tests regarding overlays added.

* test/manual/noverlay/itree-tests.c: New file with tests of the
tree data-structure on the C level.
* test/manual/noverlay/Makefile.in: New file.
* test/manual/noverlay/check-sanitize.sh: New file.
* test/manual/noverlay/emacs-compat.h: New file.
* test/manual/noverlay/.gitignore: New file.

* test/manual/noverlay/overlay-perf.el: New file providing
performance tests.
* test/manual/noverlay/many-errors.h: New file.
This commit is contained in:
Andreas Politz 2017-02-07 17:56:50 +01:00
parent f204e6e1a4
commit 8d7bdfa3fc
28 changed files with 14170 additions and 1360 deletions

View file

@ -5495,6 +5495,7 @@ if test -f "$srcdir/$opt_makefile.in"; then
dnl Again, it's best not to use a variable. Though you can add
dnl ", [], [opt_makefile='$opt_makefile']" and it should work.
AC_CONFIG_FILES([test/Makefile])
AC_CONFIG_FILES([test/manual/noverlay/Makefile])
fi

View file

@ -395,6 +395,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
$(XWIDGETS_OBJ) \
profiler.o decompress.o \
thread.o systhread.o \
itree.o \
$(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)

View file

@ -43,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "frame.h"
#include "blockinput.h"
#include "termhooks.h" /* For struct terminal. */
#include "itree.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@ -3835,16 +3836,19 @@ free_save_value (Lisp_Object save)
/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
Lisp_Object
build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
build_overlay (ptrdiff_t begin, ptrdiff_t end,
bool front_advance, bool rear_advance,
Lisp_Object plist)
{
register Lisp_Object overlay;
Lisp_Object ov = allocate_misc (Lisp_Misc_Overlay);
struct interval_node *node = xmalloc (sizeof (*node));
overlay = allocate_misc (Lisp_Misc_Overlay);
OVERLAY_START (overlay) = start;
OVERLAY_END (overlay) = end;
set_overlay_plist (overlay, plist);
XOVERLAY (overlay)->next = NULL;
return overlay;
interval_node_init (node, begin, end, front_advance,
rear_advance, ov);
XOVERLAY (ov)->interval = node;
XOVERLAY (ov)->buffer = NULL;
set_overlay_plist (ov, plist);
return ov;
}
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
@ -6280,16 +6284,10 @@ mark_compiled (struct Lisp_Vector *ptr)
/* Mark the chain of overlays starting at PTR. */
static void
mark_overlay (struct Lisp_Overlay *ptr)
mark_overlay (struct Lisp_Overlay *ov)
{
for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
{
ptr->gcmarkbit = 1;
/* These two are always markers and can be marked fast. */
XMARKER (ptr->start)->gcmarkbit = 1;
XMARKER (ptr->end)->gcmarkbit = 1;
mark_object (ptr->plist);
}
ov->gcmarkbit = 1;
mark_object (ov->plist);
}
/* Mark Lisp_Objects and special pointers in BUFFER. */
@ -6308,8 +6306,15 @@ mark_buffer (struct buffer *buffer)
a special way just before the sweep phase, and after stripping
some of its elements that are not needed any more. */
mark_overlay (buffer->overlays_before);
mark_overlay (buffer->overlays_after);
if (buffer->overlays)
{
struct interval_node *node;
buffer_overlay_iter_start (buffer, PTRDIFF_MIN, PTRDIFF_MAX, ITREE_ASCENDING);
while ((node = buffer_overlay_iter_next (buffer)))
mark_overlay (XOVERLAY (node->data));
buffer_overlay_iter_finish (buffer);
}
/* If this is an indirect buffer, mark its base buffer. */
if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
@ -7090,6 +7095,11 @@ sweep_misc (void)
unchain_marker (&mblk->markers[i].m.u_marker);
else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
unchain_finalizer (&mblk->markers[i].m.u_finalizer);
else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Overlay)
{
xfree (mblk->markers[i].m.u_overlay.interval);
mblk->markers[i].m.u_overlay.interval = NULL;
}
#ifdef HAVE_MODULES
else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr)
{
@ -7145,6 +7155,7 @@ sweep_buffers (void)
if (!VECTOR_MARKED_P (buffer))
{
*bprev = buffer->next;
free_buffer_overlays (buffer);
lisp_free (buffer);
}
else

File diff suppressed because it is too large Load diff

View file

@ -26,6 +26,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "character.h"
#include "lisp.h"
#include "itree.h"
INLINE_HEADER_BEGIN
@ -877,16 +878,8 @@ struct buffer
/* Non-zero whenever the narrowing is changed in this buffer. */
bool_bf clip_changed : 1;
/* List of overlays that end at or before the current center,
in order of end-position. */
struct Lisp_Overlay *overlays_before;
/* List of overlays that end after the current center,
in order of start-position. */
struct Lisp_Overlay *overlays_after;
/* Position where the overlay lists are centered. */
ptrdiff_t overlay_center;
/* The inveral tree containing this buffer's overlays. */
struct interval_tree *overlays;
/* Changes in the buffer are recorded here for undo, and t means
don't record anything. This information belongs to the base
@ -896,6 +889,14 @@ struct buffer
Lisp_Object undo_list_;
};
struct sortvec
{
Lisp_Object overlay;
ptrdiff_t beg, end;
EMACS_INT priority;
EMACS_INT spriority; /* Secondary priority. */
};
INLINE bool
BUFFERP (Lisp_Object a)
{
@ -1109,8 +1110,11 @@ extern void delete_all_overlays (struct buffer *);
extern void reset_buffer (struct buffer *);
extern void compact_buffer (struct buffer *);
extern void evaporate_overlays (ptrdiff_t);
extern ptrdiff_t overlays_at (EMACS_INT, bool, Lisp_Object **,
ptrdiff_t *, ptrdiff_t *, ptrdiff_t *, bool);
extern ptrdiff_t overlays_at (ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *, ptrdiff_t *);
extern ptrdiff_t overlays_in (ptrdiff_t, ptrdiff_t, bool, Lisp_Object **,
ptrdiff_t *, bool, ptrdiff_t *);
extern ptrdiff_t previous_overlay_change (ptrdiff_t);
extern ptrdiff_t next_overlay_change (ptrdiff_t);
extern ptrdiff_t sort_overlays (Lisp_Object *, ptrdiff_t, struct window *);
extern void recenter_overlay_lists (struct buffer *, ptrdiff_t);
extern ptrdiff_t overlay_strings (ptrdiff_t, struct window *, unsigned char **);
@ -1162,18 +1166,16 @@ record_unwind_current_buffer (void)
If NEXTP is non-NULL, return next overlay there.
See overlay_at arg CHANGE_REQ for meaning of CHRQ arg. */
#define GET_OVERLAYS_AT(posn, overlays, noverlays, nextp, chrq) \
#define GET_OVERLAYS_AT(posn, overlays, noverlays, next) \
do { \
ptrdiff_t maxlen = 40; \
SAFE_NALLOCA (overlays, 1, maxlen); \
(noverlays) = overlays_at (posn, false, &(overlays), &maxlen, \
nextp, NULL, chrq); \
(noverlays) = overlays_at (posn, false, &(overlays), &maxlen, next); \
if ((noverlays) > maxlen) \
{ \
maxlen = noverlays; \
SAFE_NALLOCA (overlays, 1, maxlen); \
(noverlays) = overlays_at (posn, false, &(overlays), &maxlen, \
nextp, NULL, chrq); \
(noverlays) = overlays_at (posn, false, &(overlays), &maxlen, next); \
} \
} while (false)
@ -1208,7 +1210,8 @@ set_buffer_intervals (struct buffer *b, INTERVAL i)
INLINE bool
buffer_has_overlays (void)
{
return current_buffer->overlays_before || current_buffer->overlays_after;
return current_buffer->overlays
&& (interval_tree_size (current_buffer->overlays) > 0);
}
/* Return character code of multi-byte form at byte position POS. If POS
@ -1248,23 +1251,124 @@ buffer_window_count (struct buffer *b)
/* Overlays */
/* Return the marker that stands for where OV starts in the buffer. */
INLINE ptrdiff_t
overlay_start (struct Lisp_Overlay *ov)
{
if (! ov->buffer)
return -1;
return interval_node_begin (ov->buffer->overlays, ov->interval);
}
#define OVERLAY_START(OV) XOVERLAY (OV)->start
INLINE ptrdiff_t
overlay_end (struct Lisp_Overlay *ov)
{
if (! ov->buffer)
return -1;
return interval_node_end (ov->buffer->overlays, ov->interval);
}
/* Return the marker that stands for where OV ends in the buffer. */
INLINE void
set_overlay_region (struct Lisp_Overlay *ov, ptrdiff_t begin, ptrdiff_t end)
{
eassert (ov->buffer);
begin = clip_to_bounds (BEG, begin, ov->buffer->text->z);
end = clip_to_bounds (begin, end, ov->buffer->text->z);
interval_node_set_region (ov->buffer->overlays, ov->interval, begin, end);
}
#define OVERLAY_END(OV) XOVERLAY (OV)->end
INLINE void
maybe_alloc_buffer_overlays (struct buffer *b)
{
if (! b->overlays)
b->overlays = interval_tree_create ();
}
/* FIXME: Actually this does not free any overlay, but the tree
only. --ap */
INLINE void
free_buffer_overlays (struct buffer *b)
{
eassert (! b->overlays || 0 == interval_tree_size (b->overlays));
if (b->overlays)
{
interval_tree_destroy (b->overlays);
b->overlays = NULL;
}
}
INLINE void
add_buffer_overlay (struct buffer *b, struct Lisp_Overlay *ov)
{
eassert (! ov->buffer);
maybe_alloc_buffer_overlays (b);
ov->buffer = b;
interval_tree_insert (b->overlays, ov->interval);
}
INLINE void
remove_buffer_overlay (struct buffer *b, struct Lisp_Overlay *ov)
{
eassert (b->overlays);
eassert (ov->buffer == b);
interval_tree_remove (ov->buffer->overlays, ov->interval);
ov->buffer = NULL;
}
INLINE void
buffer_overlay_iter_start (struct buffer *b, ptrdiff_t begin, ptrdiff_t end,
enum interval_tree_order order)
{
if (b->overlays)
interval_tree_iter_start (b->overlays, begin, end, order);
}
INLINE struct interval_node*
buffer_overlay_iter_next (struct buffer *b)
{
if (! b->overlays)
return NULL;
return interval_tree_iter_next (b->overlays);
}
INLINE void
buffer_overlay_iter_finish (struct buffer *b)
{
if (b->overlays)
interval_tree_iter_finish (b->overlays);
}
INLINE void
buffer_overlay_iter_narrow (struct buffer *b, ptrdiff_t begin, ptrdiff_t end)
{
if (b->overlays)
interval_tree_iter_narrow (b->overlays, begin, end);
}
/* Return the start of OV in its buffer, or -1 if OV is not associated
with any buffer. */
#define OVERLAY_START(OV) (overlay_start (XOVERLAY (OV)))
/* Return the end of OV in its buffer, or -1. */
#define OVERLAY_END(OV) (overlay_end (XOVERLAY (OV)))
/* Return the plist of overlay OV. */
#define OVERLAY_PLIST(OV) XOVERLAY (OV)->plist
#define OVERLAY_PLIST(OV) (XOVERLAY (OV)->plist)
/* Return the actual buffer position for the marker P.
We assume you know which buffer it's pointing into. */
/* Return the buffer of overlay OV. */
#define OVERLAY_POSITION(P) \
(MARKERP (P) ? marker_position (P) : (emacs_abort (), 0))
#define OVERLAY_BUFFER(OV) (XOVERLAY (OV)->buffer)
/* Return true, if OV's rear-advance is set. */
#define OVERLAY_REAR_ADVANCE_P(OV) (XOVERLAY (OV)->interval->rear_advance)
/* Return true, if OV's front-advance is set. */
#define OVERLAY_FRONT_ADVANCE_P(OV) (XOVERLAY (OV)->interval->front_advance)
/***********************************************************************
@ -1405,4 +1509,7 @@ lowercasep (int c)
INLINE_HEADER_END
int compare_overlays (const void *v1, const void *v2);
void make_sortvec_item (struct sortvec *item, Lisp_Object overlay);
#endif /* EMACS_BUFFER_H */

View file

@ -457,51 +457,9 @@ If you set the marker not to point anywhere, the buffer will have no mark. */)
of length LEN. */
static ptrdiff_t
overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
overlays_around (ptrdiff_t pos, Lisp_Object *vec, ptrdiff_t len)
{
Lisp_Object overlay, start, end;
struct Lisp_Overlay *tail;
ptrdiff_t startpos, endpos;
ptrdiff_t idx = 0;
for (tail = current_buffer->overlays_before; tail; tail = tail->next)
{
XSETMISC (overlay, tail);
end = OVERLAY_END (overlay);
endpos = OVERLAY_POSITION (end);
if (endpos < pos)
break;
start = OVERLAY_START (overlay);
startpos = OVERLAY_POSITION (start);
if (startpos <= pos)
{
if (idx < len)
vec[idx] = overlay;
/* Keep counting overlays even if we can't return them all. */
idx++;
}
}
for (tail = current_buffer->overlays_after; tail; tail = tail->next)
{
XSETMISC (overlay, tail);
start = OVERLAY_START (overlay);
startpos = OVERLAY_POSITION (start);
if (pos < startpos)
break;
end = OVERLAY_END (overlay);
endpos = OVERLAY_POSITION (end);
if (pos <= endpos)
{
if (idx < len)
vec[idx] = overlay;
idx++;
}
}
return idx;
return overlays_in (pos - 1, pos, false, &vec, &len, false, NULL);
}
DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
@ -561,11 +519,10 @@ at POSITION. */)
if (!NILP (tem))
{
/* Check the overlay is indeed active at point. */
Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
if ((OVERLAY_POSITION (start) == posn
&& XMARKER (start)->insertion_type == 1)
|| (OVERLAY_POSITION (finish) == posn
&& XMARKER (finish)->insertion_type == 0))
if ((OVERLAY_START (ol) == posn
&& OVERLAY_FRONT_ADVANCE_P (ol))
|| (OVERLAY_END (ol) == posn
&& ! OVERLAY_REAR_ADVANCE_P (ol)))
; /* The overlay will not cover a char inserted at point. */
else
{
@ -5385,7 +5342,6 @@ Transposing beyond buffer boundaries is an error. */)
transpose_markers (start1, end1, start2, end2,
start1_byte, start1_byte + len1_byte,
start2_byte, start2_byte + len2_byte);
fix_start_end_in_overlays (start1, end2);
}
else
{

View file

@ -3656,8 +3656,7 @@ by calling `format-decode', which see. */)
bset_read_only (buf, Qnil);
bset_filename (buf, Qnil);
bset_undo_list (buf, Qt);
eassert (buf->overlays_before == NULL);
eassert (buf->overlays_after == NULL);
eassert (buf->overlays == NULL);
set_buffer_internal (buf);
Ferase_buffer ();

View file

@ -2240,10 +2240,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
return false;
if (OVERLAYP (o1))
{
if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
equal_kind, depth + 1, ht)
|| !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
equal_kind, depth + 1, ht))
if (OVERLAY_START (o1) != OVERLAY_START (o2)
|| OVERLAY_END (o1) != OVERLAY_END (o2)
|| OVERLAY_BUFFER (o1) != OVERLAY_BUFFER (o2))
return false;
o1 = XOVERLAY (o1)->plist;
o2 = XOVERLAY (o2)->plist;

View file

@ -225,9 +225,6 @@ skip_invisible (ptrdiff_t pos, ptrdiff_t *next_boundary_p, ptrdiff_t to, Lisp_Ob
XSETFASTINT (position, pos);
XSETBUFFER (buffer, current_buffer);
/* Give faster response for overlay lookup near POS. */
recenter_overlay_lists (current_buffer, pos);
/* We must not advance farther than the next overlay change.
The overlay change might change the invisible property;
or there might be overlay strings to be displayed there. */
@ -501,7 +498,7 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos)
{
ptrdiff_t start;
if (OVERLAYP (overlay))
*endpos = OVERLAY_POSITION (OVERLAY_END (overlay));
*endpos = OVERLAY_END (overlay);
else
get_property_and_range (pos, Qdisplay, &val, &start, endpos, Qnil);

View file

@ -276,7 +276,6 @@ adjust_markers_for_insert (ptrdiff_t from, ptrdiff_t from_byte,
ptrdiff_t to, ptrdiff_t to_byte, bool before_markers)
{
struct Lisp_Marker *m;
bool adjusted = 0;
ptrdiff_t nchars = to - from;
ptrdiff_t nbytes = to_byte - from_byte;
@ -292,8 +291,6 @@ adjust_markers_for_insert (ptrdiff_t from, ptrdiff_t from_byte,
{
m->bytepos = to_byte;
m->charpos = to;
if (m->insertion_type)
adjusted = 1;
}
}
else if (m->bytepos > from_byte)
@ -302,15 +299,6 @@ adjust_markers_for_insert (ptrdiff_t from, ptrdiff_t from_byte,
m->charpos += nchars;
}
}
/* Adjusting only markers whose insertion-type is t may result in
- disordered start and end in overlays, and
- disordered overlays in the slot `overlays_before' of current_buffer. */
if (adjusted)
{
fix_start_end_in_overlays (from, to);
fix_overlays_before (current_buffer, from, to);
}
}
/* Adjust point for an insertion of NBYTES bytes, which are NCHARS characters.

View file

@ -1810,8 +1810,8 @@ adjust_for_invis_intang (ptrdiff_t pos, ptrdiff_t test_offs, ptrdiff_t adj,
== (test_offs == 0 ? 1 : -1))
/* Invisible property is from an overlay. */
: (test_offs == 0
? XMARKER (OVERLAY_START (invis_overlay))->insertion_type == 0
: XMARKER (OVERLAY_END (invis_overlay))->insertion_type == 1)))
? ! OVERLAY_FRONT_ADVANCE_P (invis_overlay)
: OVERLAY_REAR_ADVANCE_P (invis_overlay))))
pos += adj;
return pos;

1138
src/itree.c Normal file

File diff suppressed because it is too large Load diff

88
src/itree.h Normal file
View file

@ -0,0 +1,88 @@
/* This file implements an efficient interval data-structure.
Copyright (C) 2017 Andreas Politz (politza@hochschule-trier.de)
This file is not 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 <http://www.gnu.org/licenses/>. */
#ifndef ITREE_H
#define ITREE_H
#include <config.h>
#include <stddef.h>
#include <inttypes.h>
/* The tree and node structs are mainly here, so they can be allocated.
NOTE: The only time where it is safe to modify node.begin and
node.end directly, is while the node is not part of any tree.
NOTE: It is safe to read node.begin and node.end directly, if the
node came from a generator, because it validates the nodes it
returns as a side-effect.
*/
struct interval_node;
struct interval_node
{
enum { ITREE_RED, ITREE_BLACK } color;
struct interval_node *parent;
struct interval_node *left;
struct interval_node *right;
ptrdiff_t begin; /* The beginning of this interval. */
ptrdiff_t end; /* The end of the interval. */
ptrdiff_t limit; /* The maximum end in this subtree. */
ptrdiff_t offset; /* The amount of shift to apply to this subtree. */
uintmax_t otick; /* offset modified tick */
Lisp_Object data; /* Exclusively used by the client. */
bool_bf visited; /* For traversal via generator. */
bool_bf rear_advance : 1; /* Same as for marker and overlays. */
bool_bf front_advance : 1; /* Same as for marker and overlays. */
};
struct interval_tree
{
struct interval_node *root;
struct interval_node nil; /* The tree's version of NULL. */
uintmax_t otick; /* offset tick, compared with node's otick. */
intmax_t size; /* Number of nodes in the tree. */
struct interval_generator *iter;
bool_bf iter_running;
};
enum interval_tree_order {
ITREE_ASCENDING = 0,
ITREE_DEFLT_ORDER = 0,
ITREE_DESCENDING,
ITREE_PRE_ORDER,
};
void interval_node_init(struct interval_node *, ptrdiff_t, ptrdiff_t, bool, bool, Lisp_Object);
ptrdiff_t interval_node_begin(struct interval_tree *, struct interval_node *);
ptrdiff_t interval_node_end(struct interval_tree *, struct interval_node *);
void interval_node_set_region(struct interval_tree *, struct interval_node *, ptrdiff_t, ptrdiff_t);
struct interval_tree *interval_tree_create(void);
void interval_tree_destroy(struct interval_tree *);
intmax_t interval_tree_size(struct interval_tree *);
void interval_tree_clear(struct interval_tree *);
void interval_tree_insert(struct interval_tree *, struct interval_node *);
bool interval_tree_contains(struct interval_tree *, struct interval_node *);
struct interval_node *interval_tree_remove(struct interval_tree *, struct interval_node *);
void interval_tree_iter_start(struct interval_tree *, ptrdiff_t, ptrdiff_t, enum interval_tree_order);
void interval_tree_iter_narrow(struct interval_tree *, ptrdiff_t, ptrdiff_t);
void interval_tree_iter_finish(struct interval_tree *);
struct interval_node *interval_tree_iter_next(struct interval_tree *);
void interval_tree_insert_gap(struct interval_tree *, ptrdiff_t, ptrdiff_t);
void interval_tree_delete_gap(struct interval_tree *, ptrdiff_t, ptrdiff_t);
#endif

View file

@ -1668,8 +1668,8 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
&& display_prop_intangible_p (val, overlay, PT, PT_BYTE)
&& (!OVERLAYP (overlay)
? get_property_and_range (PT, Qdisplay, &val, &beg, &end, Qnil)
: (beg = OVERLAY_POSITION (OVERLAY_START (overlay)),
end = OVERLAY_POSITION (OVERLAY_END (overlay))))
: (beg = OVERLAY_START (overlay),
end = OVERLAY_END (overlay)))
&& (beg < PT /* && end > PT <- It's always the case. */
|| (beg <= PT && STRINGP (val) && SCHARS (val) == 0)))
{

View file

@ -2217,15 +2217,14 @@ struct Lisp_Overlay
- next fields of start and end markers (singly linked list of markers).
I.e. 9words plus 2 bits, 3words of which are for external linked lists.
*/
{
ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Overlay */
bool_bf gcmarkbit : 1;
unsigned spacer : 15;
struct Lisp_Overlay *next;
Lisp_Object start;
Lisp_Object end;
Lisp_Object plist;
};
{
ENUM_BF (Lisp_Misc_Type) type : 16; /* = Lisp_Misc_Overlay */
bool_bf gcmarkbit : 1;
unsigned spacer : 15;
Lisp_Object plist;
struct buffer *buffer; /* eassert (live buffer || NULL). */
struct interval_node *interval;
};
/* Number of bits needed to store one of the values
SAVE_UNUSED..SAVE_OBJECT. */
@ -3704,7 +3703,7 @@ extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *,
Lisp_Object);
extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t);
extern void free_save_value (Lisp_Object);
extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
extern Lisp_Object build_overlay (ptrdiff_t, ptrdiff_t, bool, bool, Lisp_Object);
extern void free_marker (Lisp_Object);
extern void free_cons (struct Lisp_Cons *);
extern void init_alloc_once (void);

View file

@ -548,8 +548,7 @@ temp_output_buffer_setup (const char *bufname)
bset_read_only (current_buffer, Qnil);
bset_filename (current_buffer, Qnil);
bset_undo_list (current_buffer, Qt);
eassert (current_buffer->overlays_before == NULL);
eassert (current_buffer->overlays_after == NULL);
eassert (current_buffer->overlays == NULL);
bset_enable_multibyte_characters
(current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters));
specbind (Qinhibit_read_only, Qt);
@ -2074,7 +2073,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
obj = XCDR (obj);
if (!(i & 1))
halftail = XCDR (halftail);
}
}
/* OBJ non-nil here means it's the end of a dotted list. */
if (!NILP (obj))
@ -2114,15 +2113,14 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
case Lisp_Misc_Overlay:
print_c_string ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer)
if (! OVERLAY_BUFFER (obj))
print_c_string ("in no buffer", printcharfun);
else
{
int len = sprintf (buf, "from %"pD"d to %"pD"d in ",
marker_position (OVERLAY_START (obj)),
marker_position (OVERLAY_END (obj)));
OVERLAY_START (obj), OVERLAY_END (obj));
strout (buf, len, len, printcharfun);
print_string (BVAR (XMARKER (OVERLAY_START (obj))->buffer, name),
print_string (BVAR (OVERLAY_BUFFER (obj), name),
printcharfun);
}
printchar ('>', printcharfun);

View file

@ -617,36 +617,42 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop,
}
if (BUFFERP (object))
{
ptrdiff_t noverlays;
Lisp_Object *overlay_vec;
struct buffer *obuf = current_buffer;
struct buffer *b = XBUFFER (object);
struct interval_node *node;
struct sortvec items[2];
struct sortvec *result = NULL;
Lisp_Object result_tem = Qnil;
if (XINT (position) < BUF_BEGV (XBUFFER (object))
|| XINT (position) > BUF_ZV (XBUFFER (object)))
if (XINT (position) < BUF_BEGV (b) || XINT (position) > BUF_ZV (b))
xsignal1 (Qargs_out_of_range, position);
set_buffer_temp (XBUFFER (object));
USE_SAFE_ALLOCA;
GET_OVERLAYS_AT (XINT (position), overlay_vec, noverlays, NULL, false);
noverlays = sort_overlays (overlay_vec, noverlays, w);
set_buffer_temp (obuf);
buffer_overlay_iter_start(b, XINT (position), XINT (position) + 1,
ITREE_ASCENDING);
/* Now check the overlays in order of decreasing priority. */
while (--noverlays >= 0)
while ((node = buffer_overlay_iter_next (b)))
{
Lisp_Object tem = Foverlay_get (overlay_vec[noverlays], prop);
if (!NILP (tem))
{
if (overlay)
/* Return the overlay we got the property from. */
*overlay = overlay_vec[noverlays];
SAFE_FREE ();
return tem;
}
Lisp_Object tem = Foverlay_get (node->data, prop);
struct sortvec *this;
if (NILP (tem) || (w && ! overlay_matches_window (w, node->data)))
continue;
this = (result == items ? items + 1 : items);
make_sortvec_item (this, node->data);
if (! result || (compare_overlays (result, this) < 0))
{
result = this;
result_tem = tem;
}
}
SAFE_FREE ();
buffer_overlay_iter_finish (b);
if (result)
{
if (overlay)
*overlay = result->overlay;
return result_tem;
}
}
if (overlay)

View file

@ -1128,6 +1128,16 @@ output_cursor_to (struct window *w, int vpos, int hpos, int y, int x)
w->output_cursor.y = y;
}
/* Return true, if overlay OV's properties should have an effect in
window W. */
INLINE bool
overlay_matches_window (const struct window *w, Lisp_Object ov)
{
eassert (OVERLAYP (ov));
Lisp_Object window = Foverlay_get (ov, Qwindow);
return (! WINDOWP (window) || XWINDOW (window) == w);
}
INLINE_HEADER_END
#endif /* not WINDOW_H_INCLUDED */

View file

@ -873,7 +873,6 @@ static enum move_it_result
static void get_visually_first_element (struct it *);
static void compute_stop_pos (struct it *);
static int face_before_or_after_it_pos (struct it *, bool);
static ptrdiff_t next_overlay_change (ptrdiff_t);
static int handle_display_spec (struct it *, Lisp_Object, Lisp_Object,
Lisp_Object, struct text_pos *, ptrdiff_t, bool);
static int handle_single_display_spec (struct it *, Lisp_Object, Lisp_Object,
@ -3606,39 +3605,6 @@ compute_stop_pos (struct it *it)
&& it->stop_charpos >= IT_CHARPOS (*it)));
}
/* Return the position of the next overlay change after POS in
current_buffer. Value is point-max if no overlay change
follows. This is like `next-overlay-change' but doesn't use
xmalloc. */
static ptrdiff_t
next_overlay_change (ptrdiff_t pos)
{
ptrdiff_t i, noverlays;
ptrdiff_t endpos;
Lisp_Object *overlays;
USE_SAFE_ALLOCA;
/* Get all overlays at the given position. */
GET_OVERLAYS_AT (pos, overlays, noverlays, &endpos, true);
/* If any of these overlays ends before endpos,
use its ending point instead. */
for (i = 0; i < noverlays; ++i)
{
Lisp_Object oend;
ptrdiff_t oendpos;
oend = OVERLAY_END (overlays[i]);
oendpos = OVERLAY_POSITION (oend);
endpos = min (endpos, oendpos);
}
SAFE_FREE ();
return endpos;
}
/* How many characters forward to search for a display property or
display string. Searching too far forward makes the bidi display
sluggish, especially in small windows. */
@ -5071,7 +5037,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
overlay's display string/image twice. */
if (!NILP (overlay))
{
ptrdiff_t ovendpos = OVERLAY_POSITION (OVERLAY_END (overlay));
ptrdiff_t ovendpos = OVERLAY_END (overlay);
/* Some borderline-sane Lisp might call us with the current
buffer narrowed so that overlay-end is outside the
@ -5785,13 +5751,14 @@ static void
load_overlay_strings (struct it *it, ptrdiff_t charpos)
{
Lisp_Object overlay, window, str, invisible;
struct Lisp_Overlay *ov;
ptrdiff_t start, end;
ptrdiff_t n = 0, i, j;
int invis;
struct overlay_entry entriesbuf[20];
ptrdiff_t size = ARRAYELTS (entriesbuf);
struct overlay_entry *entries = entriesbuf;
struct interval_node *node;
USE_SAFE_ALLOCA;
if (charpos <= 0)
@ -5823,83 +5790,47 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
} \
while (false)
/* Process overlay before the overlay center. */
for (ov = current_buffer->overlays_before; ov; ov = ov->next)
if (current_buffer->overlays)
{
XSETMISC (overlay, ov);
eassert (OVERLAYP (overlay));
start = OVERLAY_POSITION (OVERLAY_START (overlay));
end = OVERLAY_POSITION (OVERLAY_END (overlay));
buffer_overlay_iter_start (current_buffer,
charpos - 1, charpos + 1, ITREE_DESCENDING);
/* Process overlays. */
while ((node = buffer_overlay_iter_next (current_buffer)))
{
overlay = node->data;
eassert (OVERLAYP (overlay));
start = node->begin;
end = node->end;
if (end < charpos)
break;
/* Skip this overlay if it doesn't start or end at IT's current
position. */
if (end != charpos && start != charpos)
continue;
/* Skip this overlay if it doesn't start or end at IT's current
position. */
if (end != charpos && start != charpos)
continue;
/* Skip this overlay if it doesn't apply to IT->w. */
window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != it->w)
continue;
/* Skip this overlay if it doesn't apply to IT->w. */
window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != it->w)
continue;
/* If the text ``under'' the overlay is invisible, both before-
and after-strings from this overlay are visible; start and
end position are indistinguishable. */
invisible = Foverlay_get (overlay, Qinvisible);
invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
/* If the text ``under'' the overlay is invisible, both before-
and after-strings from this overlay are visible; start and
end position are indistinguishable. */
invisible = Foverlay_get (overlay, Qinvisible);
invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
/* If overlay has a non-empty before-string, record it. */
if ((start == charpos || (end == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))
&& SCHARS (str))
RECORD_OVERLAY_STRING (overlay, str, false);
/* If overlay has a non-empty before-string, record it. */
if ((start == charpos || (end == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))
&& SCHARS (str))
RECORD_OVERLAY_STRING (overlay, str, false);
/* If overlay has a non-empty after-string, record it. */
if ((end == charpos || (start == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qafter_string), STRINGP (str))
&& SCHARS (str))
RECORD_OVERLAY_STRING (overlay, str, true);
}
/* Process overlays after the overlay center. */
for (ov = current_buffer->overlays_after; ov; ov = ov->next)
{
XSETMISC (overlay, ov);
eassert (OVERLAYP (overlay));
start = OVERLAY_POSITION (OVERLAY_START (overlay));
end = OVERLAY_POSITION (OVERLAY_END (overlay));
if (start > charpos)
break;
/* Skip this overlay if it doesn't start or end at IT's current
position. */
if (end != charpos && start != charpos)
continue;
/* Skip this overlay if it doesn't apply to IT->w. */
window = Foverlay_get (overlay, Qwindow);
if (WINDOWP (window) && XWINDOW (window) != it->w)
continue;
/* If the text ``under'' the overlay is invisible, it has a zero
dimension, and both before- and after-strings apply. */
invisible = Foverlay_get (overlay, Qinvisible);
invis = TEXT_PROP_MEANS_INVISIBLE (invisible);
/* If overlay has a non-empty before-string, record it. */
if ((start == charpos || (end == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qbefore_string), STRINGP (str))
&& SCHARS (str))
RECORD_OVERLAY_STRING (overlay, str, false);
/* If overlay has a non-empty after-string, record it. */
if ((end == charpos || (start == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qafter_string), STRINGP (str))
&& SCHARS (str))
RECORD_OVERLAY_STRING (overlay, str, true);
/* If overlay has a non-empty after-string, record it. */
if ((end == charpos || (start == charpos && invis != 0))
&& (str = Foverlay_get (overlay, Qafter_string), STRINGP (str))
&& SCHARS (str))
RECORD_OVERLAY_STRING (overlay, str, true);
}
buffer_overlay_iter_finish (current_buffer);
}
#undef RECORD_OVERLAY_STRING
@ -6463,7 +6394,7 @@ back_to_previous_visible_line_start (struct it *it)
&& !NILP (val = get_char_property_and_overlay
(make_number (pos), Qdisplay, Qnil, &overlay))
&& (OVERLAYP (overlay)
? (beg = OVERLAY_POSITION (OVERLAY_START (overlay)))
? (beg = OVERLAY_START (overlay))
: get_property_and_range (pos, Qdisplay, &val, &beg, &end, Qnil)))
{
RESTORE_IT (it, it, it2data);
@ -9568,7 +9499,6 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
}
/* Reset/increment for the next run. */
recenter_overlay_lists (current_buffer, IT_CHARPOS (*it));
it->current_x = line_start_x;
line_start_x = 0;
it->hpos = 0;
@ -21212,13 +21142,6 @@ display_line (struct it *it, int cursor_vpos)
row->starts_in_middle_of_char_p = it->starts_in_middle_of_char_p;
it->starts_in_middle_of_char_p = false;
/* Arrange the overlays nicely for our purposes. Usually, we call
display_line on only one line at a time, in which case this
can't really hurt too much, or we call it on lines which appear
one after another in the buffer, in which case all calls to
recenter_overlay_lists but the first will be pretty cheap. */
recenter_overlay_lists (current_buffer, IT_CHARPOS (*it));
/* If we are going to display the cursor's line, account for the
hscroll of that line. We subtract the window's min_hscroll,
because that was already accounted for in init_iterator. */
@ -31212,7 +31135,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
if (BUFFERP (object))
{
/* Put all the overlays we want in a vector in overlay_vec. */
GET_OVERLAYS_AT (pos, overlay_vec, noverlays, NULL, false);
GET_OVERLAYS_AT (pos, overlay_vec, noverlays, NULL);
/* Sort overlays into increasing priority order. */
noverlays = sort_overlays (overlay_vec, noverlays, w);
}

View file

@ -5931,8 +5931,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
USE_SAFE_ALLOCA;
{
ptrdiff_t next_overlay;
GET_OVERLAYS_AT (pos, overlay_vec, noverlays, &next_overlay, false);
GET_OVERLAYS_AT (pos, overlay_vec, noverlays, &next_overlay);
if (next_overlay < endpos)
endpos = next_overlay;
}
@ -5975,7 +5974,6 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
{
for (prop = Qnil, i = noverlays - 1; i >= 0 && NILP (prop); --i)
{
Lisp_Object oend;
ptrdiff_t oendpos;
prop = Foverlay_get (overlay_vec[i], propname);
@ -5988,8 +5986,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
merge_face_ref (f, prop, attrs, true, 0);
}
oend = OVERLAY_END (overlay_vec[i]);
oendpos = OVERLAY_POSITION (oend);
oendpos = OVERLAY_END (overlay_vec[i]);
if (oendpos < endpos)
endpos = oendpos;
}
@ -5998,18 +5995,16 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
{
for (i = 0; i < noverlays; i++)
{
Lisp_Object oend;
ptrdiff_t oendpos;
prop = Foverlay_get (overlay_vec[i], propname);
if (!NILP (prop))
merge_face_ref (f, prop, attrs, true, 0);
oend = OVERLAY_END (overlay_vec[i]);
oendpos = OVERLAY_POSITION (oend);
if (oendpos < endpos)
endpos = oendpos;
}
oendpos = OVERLAY_END (overlay_vec[i]);
if (oendpos < endpos)
endpos = oendpos;
}
}
*endptr = endpos;

1
test/manual/noverlay/.gitignore vendored Normal file
View file

@ -0,0 +1 @@
itree-tests

View file

@ -0,0 +1,32 @@
PROGRAM = itree-tests
LIBS = check
top_srcdir = @top_srcdir@
CFLAGS += -O0 -g3 $(shell pkg-config --cflags $(LIBS)) -I $(top_srcdir)/src
LDFLAGS += $(shell pkg-config --libs $(LIBS)) -lm
OBJECTS = itree-tests.o
CC = gcc
EMACS ?= ../../../src/emacs
.PHONY: all check have-libcheck
all: check
have-libcheck:
pkg-config --cflags $(LIBS)
check: have-libcheck $(PROGRAM)
./check-sanitize.sh ./$(PROGRAM)
itree-tests.o: emacs-compat.h itree-tests.c $(top_srcdir)/src/itree.c $(top_srcdir)/src/itree.h
$(PROGRAM): $(OBJECTS)
$(CC) $(CFLAGS) $(LDFLAGS) $(OBJECTS) -o $(PROGRAM)
perf:
-$(EMACS) -Q -l ./overlay-perf.el -f perf-run-batch
clean:
rm -f -- $(OBJECTS) $(PROGRAM)
distclean: clean
rm -f -- Makefile

View file

@ -0,0 +1,11 @@
#!/bin/bash
prog=$1
shift
[ -z "$prog" ] && {
echo "usage:$(basename $0) CHECK_PRGOGRAM";
exit 1;
}
"$prog" "$@" | sed -e 's/^\([^:]\+\):\([0-9]\+\):[PFE]:[^:]*:\([^:]*\):[^:]*: *\(.*\)/\1:\2:\3:\4/'

View file

@ -0,0 +1,52 @@
#ifndef TEST_COMPAT_H
#define TEST_COMPAT_H
#include <stdio.h>
#include <limits.h>
typedef int Lisp_Object;
void *
xmalloc (size_t size)
{
return malloc (size);
}
void
xfree (void *ptr)
{
free (ptr);
}
void *
xrealloc (void *block, size_t size)
{
return realloc (block, size);
}
void
emacs_abort ()
{
fprintf (stderr, "Aborting...\n");
exit (1);
}
#ifndef eassert
#define eassert(cond) \
do { \
if (! (cond)) { \
fprintf (stderr, "\n%s:%d:eassert condition failed: %s\n", \
__FILE__, __LINE__ ,#cond); \
exit (1); \
} \
} while (0)
#endif
#ifndef max
#define max(x,y) ((x) >= (y) ? (x) : (y))
#endif
#ifndef min
#define min(x,y) ((x) <= (y) ? (x) : (y))
#endif
#endif

File diff suppressed because it is too large Load diff

File diff suppressed because it is too large Load diff

View file

@ -0,0 +1,764 @@
;; -*- lexical-binding:t -*-
(require 'cl-lib)
(require 'subr-x)
(require 'seq)
(require 'hi-lock)
;; +===================================================================================+
;; | Framework
;; +===================================================================================+
(defmacro perf-define-constant-test (name &optional doc &rest body)
(declare (indent 1) (debug (symbol &optional string &rest form)))
`(progn
(put ',name 'perf-constant-test t)
(defun ,name nil ,doc ,@body)))
(defmacro perf-define-variable-test (name args &optional doc &rest body)
(declare (indent 2) (debug defun))
(unless (and (consp args)
(= (length args) 1))
(error "Function %s should accept exactly one argument." name))
`(progn
(put ',name 'perf-variable-test t)
(defun ,name ,args ,doc ,@body)))
(defmacro perf-define-test-suite (name &rest tests)
(declare (indent 1))
`(put ',name 'perf-test-suite
,(cons 'list tests)))
(defun perf-constant-test-p (test)
(get test 'perf-constant-test))
(defun perf-variable-test-p (test)
(get test 'perf-variable-test))
(defun perf-test-suite-p (suite)
(not (null (perf-test-suite-elements suite))))
(defun perf-test-suite-elements (suite)
(get suite 'perf-test-suite))
(defun perf-expand-suites (test-and-suites)
(apply #' append (mapcar (lambda (elt)
(if (perf-test-suite-p elt)
(perf-test-suite-elements elt)
(list elt)))
test-and-suites)))
(defun perf-test-p (symbol)
(or (perf-variable-test-p symbol)
(perf-constant-test-p symbol)))
(defun perf-all-tests ()
(let (result)
(mapatoms (lambda (symbol)
(when (and (fboundp symbol)
(perf-test-p symbol))
(push symbol result))))
(sort result #'string-lessp)))
(defvar perf-default-test-argument 4096)
(defun perf-run-1 (&optional k n &rest tests)
"Run TESTS K times using N as argument for non-constant ones.
Return test-total elapsed time."
(random "")
(when (and n (not (numberp n)))
(push k tests)
(push n tests)
(setq n nil k nil))
(when (and k (not (numberp k)))
(push k tests)
(setq k nil))
(let* ((k (or k 1))
(n (or n perf-default-test-argument))
(tests (perf-expand-suites (or tests
(perf-all-tests))))
(variable-tests (seq-filter #'perf-variable-test-p tests))
(constant-tests (seq-filter #'perf-constant-test-p tests))
(max-test-string-width (perf-max-symbol-length tests)))
(unless (seq-every-p #'perf-test-p tests)
(error "Some of these are not tests: %s" tests))
(cl-labels ((format-result (result)
(cond
((numberp result) (format "%.2f" result))
((stringp result) result)
((null result) "N/A")))
(format-test (fn)
(concat (symbol-name fn)
(make-string
(+ (- max-test-string-width
(length (symbol-name fn)))
1)
?\s)))
(format-summary (results _total)
(let ((min (apply #'min results))
(max (apply #'max results))
(avg (/ (apply #'+ results) (float (length results)))))
(format "n=%d min=%.2f avg=%.2f max=%.2f" (length results) min avg max)))
(run-test (fn)
(let ((total 0) results)
(dotimes (_ (max 0 k))
(garbage-collect)
(princ (concat " " (format-test fn)))
(let ((result (condition-case-unless-debug err
(cond
((perf-variable-test-p fn)
(random "") (car (funcall fn n)))
((perf-constant-test-p fn)
(random "") (car (funcall fn)))
(t "skip"))
(error (error-message-string err)))))
(when (numberp result)
(cl-incf total result)
(push result results))
(princ (format-result result))
(terpri)))
(when (> (length results) 1)
(princ (concat "#" (format-test fn)
(format-summary results total)))
(terpri)))))
(when variable-tests
(terpri)
(dolist (fn variable-tests)
(run-test fn)
(terpri)))
(when constant-tests
(dolist (fn constant-tests)
(run-test fn)
(terpri))))))
(defun perf-run (&optional k n &rest tests)
(interactive
(let* ((n (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
perf-default-test-argument))
(tests (mapcar #'intern
(completing-read-multiple
(format "Run tests (n=%d): " n)
(perf-all-tests) nil t nil 'perf-test-history))))
(cons 1 (cons n tests))))
(with-current-buffer (get-buffer-create "*perf-results*")
(let ((inhibit-read-only t)
(standard-output (current-buffer)))
(erase-buffer)
(apply #'perf-run-1 k n tests)
(display-buffer (current-buffer)))))
(defun perf-batch-parse-command-line (args)
(let ((k 1)
(n perf-default-test-argument)
tests)
(while args
(cond ((string-match-p "\\`-[cn]\\'" (car args))
(unless (and (cdr args)
(string-match-p "\\`[0-9]+\\'" (cadr args)))
(error "%s expectes a natnum argument" (car args)))
(if (equal (car args) "-c")
(setq k (string-to-number (cadr args)))
(setq n (string-to-number (cadr args))))
(setq args (cddr args)))
(t (push (intern (pop args)) tests))))
(list k n tests)))
(defun perf-run-batch ()
"Runs tests from `command-line-args-left' and kill emacs."
(let ((standard-output #'external-debugging-output))
(condition-case err
(cl-destructuring-bind (k n tests)
(perf-batch-parse-command-line command-line-args-left)
(apply #'perf-run-1 k n tests)
(save-buffers-kill-emacs))
(error
(princ (error-message-string err))
(save-buffers-kill-emacs)))))
(defconst perf-number-of-columns 70)
(defun perf-insert-lines (n)
"Insert N lines into the current buffer."
(dotimes (i n)
(insert (make-string 70 (if (= (% i 2) 0)
?.
?O))
?\n)))
(defun perf-switch-to-buffer-scroll-random (n &optional buffer)
(interactive)
(set-window-buffer nil (or buffer (current-buffer)))
(goto-char (point-min))
(redisplay t)
(dotimes (_ n)
(goto-char (random (point-max)))
(recenter)
(redisplay t)))
(defun perf-insert-overlays (n &optional create-callback random-p)
(if random-p
(perf-insert-overlays-random n create-callback)
(perf-insert-overlays-sequential n create-callback)))
(defun perf-insert-overlays-sequential (n &optional create-callback)
"Insert an overlay every Nth line."
(declare (indent 1))
(let ((i 0)
(create-callback (or create-callback #'ignore)))
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(when (= 0 (% i n))
(let ((ov (make-overlay (point-at-bol) (point-at-eol))))
(funcall create-callback ov)
(overlay-put ov 'priority (random (buffer-size)))))
(cl-incf i)
(forward-line)))))
(defun perf-insert-overlays-random (n &optional create-callback)
"Insert an overlay every Nth line."
(declare (indent 1))
(let ((create-callback (or create-callback #'ignore)))
(save-excursion
(while (>= (cl-decf n) 0)
(let* ((beg (1+ (random (point-max))))
(ov (make-overlay beg (+ beg (random 70)))))
(funcall create-callback ov)
(overlay-put ov 'priority (random (buffer-size))))))))
(defun perf-insert-overlays-hierarchical (n &optional create-callback)
(let ((create-callback (or create-callback #'ignore)))
(save-excursion
(goto-char (point-min))
(let ((spacing (floor (/ (/ (count-lines (point-min) (point-max))
(float 3))
n))))
(when (< spacing 1)
(error "Hierarchical overlay overflow !!"))
(dotimes (i n)
(funcall create-callback
(make-overlay (point)
(save-excursion
(goto-char (point-max))
(forward-line (- (* spacing i)))
(point))))
(when (eobp)
(error "End of buffer in hierarchical overlays"))
(forward-line spacing))))))
(defun perf-overlay-ascii-chart (&optional buffer width)
(interactive)
(save-current-buffer
(when buffer (set-buffer buffer))
(unless width (setq width 100))
(let* ((ovl (sort (overlays-in (point-min) (point-max))
(lambda (ov1 ov2)
(or (<= (overlay-start ov1)
(overlay-start ov2))
(and
(= (overlay-start ov1)
(overlay-start ov2))
(< (overlay-end ov1)
(overlay-end ov2)))))))
(ov-width (apply #'max (mapcar (lambda (ov)
(- (overlay-end ov)
(overlay-start ov)))
ovl)))
(ov-min (apply #'min (mapcar #'overlay-start ovl)))
(ov-max (apply #'max (mapcar #'overlay-end ovl)))
(scale (/ (float width) (+ ov-min ov-width))))
(with-current-buffer (get-buffer-create "*overlay-ascii-chart*")
(let ((inhibit-read-only t))
(erase-buffer)
(buffer-disable-undo)
(insert (format "%06d%s%06d\n" ov-min (make-string (- width 12) ?\s) ov-max))
(dolist (ov ovl)
(let ((length (round (* scale (- (overlay-end ov)
(overlay-start ov))))))
(insert (make-string (round (* scale (overlay-start ov))) ?\s))
(cl-case length
(0 (insert "O"))
(1 (insert "|"))
(t (insert (format "|%s|" (make-string (- length 2) ?-)))))
(insert "\n")))
(goto-char (point-min)))
(read-only-mode 1)
(pop-to-buffer (current-buffer))))))
(defconst perf-overlay-faces (mapcar #'intern (seq-take hi-lock-face-defaults 3)))
(defun perf-overlay-face-callback (ov)
(overlay-put ov 'face (nth (random (length perf-overlay-faces))
perf-overlay-faces)))
(defun perf-overlay-invisible-callback (ov)
(overlay-put ov 'invisble (= 1 (random 2))))
(defun perf-overlay-display-callback (ov)
(overlay-put ov 'display (make-string 70 ?*)))
(defmacro perf-define-display-test (overlay-type property-type scroll-type)
(let ((name (intern (format "perf-display-%s/%s/%s"
overlay-type property-type scroll-type)))
(arg (make-symbol "n")))
`(perf-define-variable-test ,name (,arg)
(with-temp-buffer
(perf-insert-lines ,arg)
(overlay-recenter (point-max))
,@(perf-define-display-test-1 arg overlay-type property-type scroll-type)))))
(defun perf-define-display-test-1 (arg overlay-type property-type scroll-type)
(list (append (cl-case overlay-type
(sequential
(list 'perf-insert-overlays-sequential 2))
(hierarchical
`(perf-insert-overlays-hierarchical (/ ,arg 10)))
(random
`(perf-insert-overlays-random (/ ,arg 2)))
(t (error "Invalid insert type: %s" overlay-type)))
(list
(cl-case property-type
(display '#'perf-overlay-display-callback)
(face '#'perf-overlay-face-callback)
(invisible '#'perf-overlay-invisible-callback)
(t (error "Invalid overlay type: %s" overlay-type)))))
(list 'benchmark-run 1
(cl-case scroll-type
(scroll '(perf-switch-to-buffer-scroll-up-and-down))
(random `(perf-switch-to-buffer-scroll-random (/ ,arg 50)))
(t (error "Invalid scroll type: %s" overlay-type))))))
(defun perf-max-symbol-length (symbols)
"Return the longest symbol in SYMBOLS, or -1 if symbols is nil."
(if (null symbols)
-1
(apply #'max (mapcar
(lambda (elt)
(length (symbol-name elt)))
symbols))))
(defun perf-insert-text (n)
"Insert N character into the current buffer."
(let ((ncols 68)
(char ?.))
(dotimes (_ (/ n ncols))
(insert (make-string (1- ncols) char) ?\n))
(when (> (% n ncols) 0)
(insert (make-string (1- (% n ncols)) char) ?\n))))
(defconst perf-insert-overlays-default-length 24)
(defun perf-insert-overlays-scattered (n &optional length)
"Insert N overlays of max length 24 randomly."
(dotimes (_ n)
(let ((begin (random (1+ (point-max)))))
(make-overlay
begin (+ begin (random (1+ (or length perf-insert-overlays-default-length 0))))))))
(defvar perf-marker-gc-protection nil)
(defun perf-insert-marker-scattered (n)
"Insert N marker randomly."
(setq perf-marker-gc-protection nil)
(dotimes (_ n)
(push (copy-marker (random (1+ (point-max))))
perf-marker-gc-protection)))
(defun perf-switch-to-buffer-scroll-up-and-down (&optional buffer)
(interactive)
(set-window-buffer nil (or buffer (current-buffer)))
(goto-char (point-min))
(redisplay t)
(while (condition-case nil
(progn (scroll-up) t)
(end-of-buffer nil))
(redisplay t))
(while (condition-case nil
(progn (scroll-down) t)
(beginning-of-buffer nil))
(redisplay t)))
(defun perf-emacs-lisp-setup ()
(add-to-list 'imenu-generic-expression
'(nil "^\\s-*(perf-define\\(?:\\w\\|\\s_\\)*\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)" 1)))
(add-hook 'emacs-lisp-mode 'perf-emacs-lisp-setup)
;; +===================================================================================+
;; | Basic performance tests
;; +===================================================================================+
(perf-define-variable-test perf-make-overlay (n)
(with-temp-buffer
(overlay-recenter (point-min))
(benchmark-run 1
(dotimes (_ n)
(make-overlay 1 1)))))
(perf-define-variable-test perf-make-overlay-continuous (n)
(with-temp-buffer
(perf-insert-text n)
(overlay-recenter (point-max))
(benchmark-run 1
(dotimes (i n)
(make-overlay i (1+ i))))))
(perf-define-variable-test perf-make-overlay-scatter (n)
(with-temp-buffer
(perf-insert-text n)
(benchmark-run 1
(perf-insert-overlays-scattered n))))
(perf-define-variable-test perf-delete-overlay (n)
(with-temp-buffer
(let ((ovls (cl-loop for i from 1 to n
collect (make-overlay 1 1))))
(overlay-recenter (point-min))
(benchmark-run 1
(mapc #'delete-overlay ovls)))))
(perf-define-variable-test perf-delete-overlay-continuous (n)
(with-temp-buffer
(perf-insert-text n)
(let ((ovls (cl-loop for i from 1 to n
collect (make-overlay i (1+ i)))))
(overlay-recenter (point-min))
(benchmark-run 1
(mapc #'delete-overlay ovls)))))
(perf-define-variable-test perf-delete-overlay-scatter (n)
(with-temp-buffer
(perf-insert-text n)
(let ((ovls (progn (perf-insert-overlays-scattered n)
(overlays-in (point-min) (point-max)))))
(benchmark-run 1
(mapc #'delete-overlay ovls)))))
(perf-define-variable-test perf-overlays-at (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(benchmark-run 1
(dotimes (i (point-max))
(overlays-at i)))))
(perf-define-variable-test perf-overlays-in (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(let ((len perf-insert-overlays-default-length))
(benchmark-run 1
(dotimes (i (- (point-max) len))
(overlays-in i (+ i len)))))))
(perf-define-variable-test perf-insert-before (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(goto-char 1)
(overlay-recenter (point-min))
(benchmark-run 1
(dotimes (_ (/ n 2))
(insert ?X)))))
(perf-define-variable-test perf-insert-before-empty (n)
(let ((perf-insert-overlays-default-length 0))
(perf-insert-before n)))
(perf-define-variable-test perf-insert-after-empty (n)
(let ((perf-insert-overlays-default-length 0))
(perf-insert-after n)))
(perf-define-variable-test perf-insert-scatter-empty (n)
(let ((perf-insert-overlays-default-length 0))
(perf-insert-scatter n)))
(perf-define-variable-test perf-delete-before-empty (n)
(let ((perf-insert-overlays-default-length 0))
(perf-delete-before n)))
(perf-define-variable-test perf-delete-after-empty (n)
(let ((perf-insert-overlays-default-length 0))
(perf-delete-after n)))
(perf-define-variable-test perf-delete-scatter-empty (n)
(let ((perf-insert-overlays-default-length 0))
(perf-delete-scatter n)))
(defmacro perf-define-marker-test (type where)
(let ((name (intern (format "perf-%s-%s-marker" type where))))
`(perf-define-variable-test ,name (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-marker-scattered n)
(goto-char ,(cl-case where
(after (list 'point-max))
(t (list 'point-min))))
(benchmark-run 1
(dotimes (_ (/ n 2))
,@(when (eq where 'scatter)
(list '(goto-char (max 1 (random (point-max))))))
,(cl-case type
(insert (list 'insert ?X))
(delete (list 'delete-char (if (eq where 'after) -1 1))))))))))
(perf-define-test-suite perf-marker-suite
(perf-define-marker-test insert before)
(perf-define-marker-test insert after)
(perf-define-marker-test insert scatter)
(perf-define-marker-test delete before)
(perf-define-marker-test delete after)
(perf-define-marker-test delete scatter))
(perf-define-variable-test perf-insert-after (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(goto-char (point-max))
(overlay-recenter (point-max))
(benchmark-run 1
(dotimes (_ (/ n 2))
(insert ?X)))))
(perf-define-variable-test perf-insert-scatter (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(goto-char (point-max))
(benchmark-run 1
(dotimes (_ (/ n 2))
(goto-char (1+ (random (point-max))))
(insert ?X)))))
(perf-define-variable-test perf-delete-before (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(goto-char 1)
(overlay-recenter (point-min))
(benchmark-run 1
(dotimes (_ (/ n 2))
(delete-char 1)))))
(perf-define-variable-test perf-delete-after (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(goto-char (point-max))
(overlay-recenter (point-max))
(benchmark-run 1
(dotimes (_ (/ n 2))
(delete-char -1)))))
(perf-define-variable-test perf-delete-scatter (n)
(with-temp-buffer
(perf-insert-text n)
(perf-insert-overlays-scattered n)
(goto-char (point-max))
(benchmark-run 1
(dotimes (_ (/ n 2))
(goto-char (max 1 (random (point-max))))
(delete-char 1)))))
(perf-define-test-suite perf-insert-delete-suite
'perf-insert-before
'perf-insert-after
'perf-insert-scatter
'perf-delete-before
'perf-delete-after
'perf-delete-scatter
)
;; +===================================================================================+
;; | Redisplay (new)
;; +===================================================================================+
;; 5000
;; 25000
;; 75000
;; Number of Overlays = N / 2
;;
;; (except for the hierarchical case, where it is divided by 10.)
;; . scrolling through a buffer with lots of overlays that affect faces
;; of characters in the buffer text
;; . scrolling through a buffer with lots of overlays that define
;; 'display' properties which are strings
;; . scrolling through a buffer with lots of overlays that define
;; 'invisible' properties
(perf-define-test-suite perf-display-suite
(perf-define-display-test sequential display scroll)
(perf-define-display-test sequential display random)
(perf-define-display-test sequential face scroll)
(perf-define-display-test sequential face random)
(perf-define-display-test sequential invisible scroll)
(perf-define-display-test sequential invisible random)
(perf-define-display-test random display scroll)
(perf-define-display-test random display random)
(perf-define-display-test random face scroll)
(perf-define-display-test random face random)
(perf-define-display-test random invisible scroll)
(perf-define-display-test random invisible random))
;; |------------|
;; |--------|
;; |----|
(perf-define-display-test hierarchical face scroll)
;; +===================================================================================+
;; | Real World
;; +===================================================================================+
(require 'python)
(defconst perf-many-errors-file
(expand-file-name "many-errors.py"
(and load-file-name (file-name-directory load-file-name))))
(perf-define-constant-test perf-realworld-flycheck
(interactive)
(package-initialize)
(when (and (require 'flycheck nil t)
(file-exists-p perf-many-errors-file)
(or (executable-find "pylint")
(executable-find "flake8")))
(setq flycheck-python-pylint-executable
(executable-find "pylint"))
(setq flycheck-python-flake8-executable
(executable-find "flake8"))
(setq python-indent-guess-indent-offset-verbose nil)
(setq flycheck-check-syntax-automatically nil)
(setq flycheck-checker-error-threshold nil)
(setq flycheck-display-errors-function nil)
(with-current-buffer (find-file-noselect perf-many-errors-file)
(let* ((done)
(flycheck-after-syntax-check-hook
(list (lambda () (setq done t)))))
(flycheck-mode 1)
(flycheck-buffer)
(benchmark-run 1
(while (not done)
(accept-process-output))
(perf-switch-to-buffer-scroll-up-and-down)
(flycheck-mode -1))))))
;; https://lists.gnu.org/archive/html/emacs-devel/2009-04/msg00242.html
(defun make-lines-invisible (regexp &optional arg)
"Make all lines matching a regexp invisible and intangible.
With a prefix arg, make it visible again. It is not necessary
that REGEXP matches the whole line; if a hit is found, the
affected line gets automatically selected.
This command affects the whole buffer."
(interactive "MRegexp: \nP")
(let (ov
ovs
count)
(cond
((equal arg '(4))
(setq ovs (overlays-in (point-min) (point-max)))
(mapc (lambda (o)
(if (overlay-get o 'make-lines-invisible)
(delete-overlay o)))
ovs))
(t
(save-excursion
(goto-char (point-min))
(setq count 0)
(while (re-search-forward regexp nil t)
(setq count (1+ count))
(if (= (% count 100) 0)
(message "%d" count))
(setq ov (make-overlay (line-beginning-position)
(1+ (line-end-position))))
(overlay-put ov 'make-lines-invisible t)
(overlay-put ov 'invisible t)
(overlay-put ov 'intangible t)
(goto-char (line-end-position))))))))
(perf-define-constant-test perf-realworld-make-lines-invisible
(with-temp-buffer
(insert-file-contents "/usr/share/dict/words")
(set-window-buffer nil (current-buffer))
(redisplay t)
(overlay-recenter (point-max))
(benchmark-run 1
(make-lines-invisible "a"))))
(perf-define-constant-test perf-realworld-line-numbering
(interactive)
(with-temp-buffer
(insert-file-contents "/usr/share/dict/words")
(overlay-recenter (point-max))
(goto-char (point-min))
(let* ((nlines (count-lines (point-min) (point-max)))
(line 1)
(width 0))
(dotimes (i nlines) ;;-with-progress-reporter "Creating overlays"
(let ((ov (make-overlay (point) (point)))
(str (propertize (format "%04d" line) 'face 'shadow)))
(overlay-put ov 'before-string
(propertize " " 'display `((margin left-margin) ,str)))
(setq width (max width (length str)))
(cl-incf line)
(forward-line)))
(benchmark-run 1
(let ((left-margin-width width))
(perf-switch-to-buffer-scroll-up-and-down))))))
(perf-define-test-suite perf-realworld-suite
'perf-realworld-flycheck
'perf-realworld-make-lines-invisible
'perf-realworld-line-numbering)
;; +===================================================================================+
;; | next-overlay-change
;; +===================================================================================+
(perf-define-variable-test perf-noc-hierarchical/forward/linear (n)
"Search linear for the next change on every line."
(with-temp-buffer
(perf-insert-lines (* 3 n))
(perf-insert-overlays-hierarchical n)
(goto-char (point-min))
(benchmark-run 1
(while (not (eobp))
(next-overlay-change (point))
(forward-line)))))
(perf-define-variable-test perf-noc-sequential/forward/linear (n)
"Search linear for the next change on every line."
(with-temp-buffer
(perf-insert-lines (* 3 n))
(perf-insert-overlays-sequential n)
(goto-char (point-min))
(benchmark-run 1
(while (not (eobp))
(next-overlay-change (point))
(forward-line)))))
(perf-define-variable-test perf-noc-hierarchical/forward/backnforth (n)
"Search back and forth for the next change from `point-min' to `point-max'."
(with-temp-buffer
(perf-insert-lines (* 3 n))
(overlay-recenter (point-max))
(perf-insert-overlays-hierarchical n)
(goto-char (point-min))
(benchmark-run 1
(while (not (eobp))
(next-overlay-change (point))
(next-overlay-change (+ (point) 2))
(forward-char)))))
(perf-define-test-suite perf-noc-suite
'perf-noc-hierarchical/forward/linear
'perf-noc-hierarchical/forward/backnforth
'perf-noc-hierarchical/forward/backnforth)

File diff suppressed because it is too large Load diff