aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erts/emulator/beam/beam_emu.c23
-rw-r--r--erts/emulator/beam/erl_gc.c6
-rw-r--r--erts/emulator/beam/erl_message.c17
-rw-r--r--erts/emulator/beam/erl_message.h11
-rw-r--r--erts/emulator/beam/erl_nif.c14
-rw-r--r--erts/emulator/beam/erl_process.h9
-rw-r--r--erts/emulator/beam/utils.c3
-rw-r--r--erts/emulator/sys/common/erl_poll.c14
-rw-r--r--erts/include/internal/erl_misc_utils.h29
-rw-r--r--erts/lib_src/pthread/ethr_event.c74
-rw-r--r--lib/tools/emacs/erlang-test.el106
-rw-r--r--lib/tools/emacs/erlang.el112
12 files changed, 305 insertions, 113 deletions
diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c
index b3e6ebf651..ef4cdf9d5a 100644
--- a/erts/emulator/beam/beam_emu.c
+++ b/erts/emulator/beam/beam_emu.c
@@ -1960,6 +1960,8 @@ void process_main(void)
ErtsMessage* msgp;
PROCESS_MAIN_CHK_LOCKS(c_p);
+ ERTS_CHK_MBUF_SZ(c_p);
+
PreFetch(0, next);
msgp = PEEK_MESSAGE(c_p);
@@ -2047,6 +2049,7 @@ void process_main(void)
}
ERTS_DBG_CHK_REDS(c_p, FCALLS);
+ ERTS_CHK_MBUF_SZ(c_p);
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2583,7 +2586,9 @@ do { \
c_p->fcalls = FCALLS;
PROCESS_MAIN_CHK_LOCKS(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p));
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, tmp_reg);
+ ERTS_CHK_MBUF_SZ(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2614,7 +2619,9 @@ do { \
c_p->fcalls = FCALLS;
PROCESS_MAIN_CHK_LOCKS(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p));
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, tmp_reg);
+ ERTS_CHK_MBUF_SZ(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2644,7 +2651,9 @@ do { \
SWAPOUT;
PROCESS_MAIN_CHK_LOCKS(c_p);
ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p);
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, reg, live);
+ ERTS_CHK_MBUF_SZ(c_p);
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2685,7 +2694,9 @@ do { \
SWAPOUT;
PROCESS_MAIN_CHK_LOCKS(c_p);
ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p);
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, reg, live);
+ ERTS_CHK_MBUF_SZ(c_p);
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2728,7 +2739,9 @@ do { \
SWAPOUT;
PROCESS_MAIN_CHK_LOCKS(c_p);
ERTS_SMP_UNREQ_PROC_MAIN_LOCK(c_p);
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, reg, live);
+ ERTS_CHK_MBUF_SZ(c_p);
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
ERTS_SMP_REQ_PROC_MAIN_LOCK(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2766,7 +2779,9 @@ do { \
c_p->fcalls = FCALLS;
PROCESS_MAIN_CHK_LOCKS(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p));
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, tmp_reg);
+ ERTS_CHK_MBUF_SZ(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2793,7 +2808,9 @@ do { \
bf = (BifFunction) Arg(0);
PROCESS_MAIN_CHK_LOCKS(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p));
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, tmp_reg);
+ ERTS_CHK_MBUF_SZ(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
@@ -2843,7 +2860,9 @@ do { \
ASSERT(!ERTS_PROC_IS_EXITING(c_p));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
live_hf_end = c_p->mbuf;
+ ERTS_CHK_MBUF_SZ(c_p);
result = (*bf)(c_p, reg, I);
+ ERTS_CHK_MBUF_SZ(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p) || is_non_value(result));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
ERTS_HOLE_CHECK(c_p);
@@ -3556,11 +3575,13 @@ do { \
ASSERT(c_p->scheduler_data);
#endif
live_hf_end = c_p->mbuf;
+ ERTS_CHK_MBUF_SZ(c_p);
erts_pre_nif(&env, c_p, (struct erl_module_nif*)I[2], NULL);
nif_bif_result = (*fp)(&env, bif_nif_arity, reg);
if (env.exception_thrown)
nif_bif_result = THE_NON_VALUE;
erts_post_nif(&env);
+ ERTS_CHK_MBUF_SZ(c_p);
PROCESS_MAIN_CHK_LOCKS(c_p);
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
@@ -3612,7 +3633,9 @@ do { \
Eterm (*bf)(Process*, Eterm*, BeamInstr*) = vbf;
ASSERT(!ERTS_PROC_IS_EXITING(c_p));
live_hf_end = c_p->mbuf;
+ ERTS_CHK_MBUF_SZ(c_p);
nif_bif_result = (*bf)(c_p, reg, I);
+ ERTS_CHK_MBUF_SZ(c_p);
ASSERT(!ERTS_PROC_IS_EXITING(c_p) ||
is_non_value(nif_bif_result));
ERTS_VERIFY_UNUSED_TEMP_ALLOC(c_p);
diff --git a/erts/emulator/beam/erl_gc.c b/erts/emulator/beam/erl_gc.c
index 8b0dd9a5a6..75f8ebefbd 100644
--- a/erts/emulator/beam/erl_gc.c
+++ b/erts/emulator/beam/erl_gc.c
@@ -517,6 +517,8 @@ delay_garbage_collection(Process *p, ErlHeapFragment *live_hf_end, int need, int
erts_proc_sched_data((p))->virtual_reds += vreds;
}
+ ERTS_CHK_MBUF_SZ(p);
+
ASSERT(CONTEXT_REDS >= erts_proc_sched_data(p)->virtual_reds);
return reds_left;
}
@@ -527,6 +529,8 @@ young_gen_usage(Process *p)
Uint hsz;
Eterm *aheap;
+ ERTS_CHK_MBUF_SZ(p);
+
hsz = p->mbuf_sz;
if (p->flags & F_ON_HEAP_MSGQ) {
@@ -590,6 +594,8 @@ garbage_collect(Process* p, ErlHeapFragment *live_hf_end,
DTRACE_CHARBUF(pidbuf, DTRACE_TERM_BUF_SIZE);
#endif
+ ERTS_CHK_MBUF_SZ(p);
+
ASSERT(CONTEXT_REDS - ERTS_REDS_LEFT(p, fcalls)
>= erts_proc_sched_data(p)->virtual_reds);
diff --git a/erts/emulator/beam/erl_message.c b/erts/emulator/beam/erl_message.c
index 91e06cde2d..e4c696ae3b 100644
--- a/erts/emulator/beam/erl_message.c
+++ b/erts/emulator/beam/erl_message.c
@@ -1842,3 +1842,20 @@ void erts_factory_undo(ErtsHeapFactory* factory)
factory->heap_frags = NULL;
#endif
}
+
+Uint
+erts_mbuf_size(Process *p)
+{
+ Uint sz = 0;
+ ErlHeapFragment* bp;
+ ErtsMessage* mp;
+
+ for (bp = p->mbuf; bp; bp = bp->next)
+ sz += bp->used_size;
+
+ for (mp = p->msg_frag; mp; mp = mp->next)
+ for (bp = erts_message_to_heap_frag(mp); bp; bp = bp->next)
+ sz += bp->used_size;
+
+ return sz;
+}
diff --git a/erts/emulator/beam/erl_message.h b/erts/emulator/beam/erl_message.h
index 6df969367b..42ed14e69c 100644
--- a/erts/emulator/beam/erl_message.h
+++ b/erts/emulator/beam/erl_message.h
@@ -499,4 +499,15 @@ erts_msgq_replace_msg_ref(ErlMessageQueue *msgq, ErtsMessage *newp, ErtsMessage
#endif
+Uint erts_mbuf_size(Process *p);
+#if defined(DEBUG) || 0
+# define ERTS_CHK_MBUF_SZ(P) \
+ do { \
+ Uint actual_mbuf_sz__ = erts_mbuf_size((P)); \
+ ERTS_ASSERT((P)->mbuf_sz >= actual_mbuf_sz__); \
+ } while (0)
+#else
+# define ERTS_CHK_MBUF_SZ(P) ((void) 1)
+#endif
+
#endif
diff --git a/erts/emulator/beam/erl_nif.c b/erts/emulator/beam/erl_nif.c
index ef2fb93106..27392a5996 100644
--- a/erts/emulator/beam/erl_nif.c
+++ b/erts/emulator/beam/erl_nif.c
@@ -156,7 +156,9 @@ static Eterm* alloc_heap_heavy(ErlNifEnv* env, size_t need, Eterm* hp)
HEAP_TOP(env->proc) = env->hp;
}
else {
- env->heap_frag->used_size = hp - env->heap_frag->mem;
+ Uint usz = env->hp - env->heap_frag->mem;
+ env->proc->mbuf_sz += usz - env->heap_frag->used_size;
+ env->heap_frag->used_size = usz;
ASSERT(env->heap_frag->used_size <= env->heap_frag->alloc_size);
}
hp = erts_heap_alloc(env->proc, need, MIN_HEAP_FRAG_SZ);
@@ -308,11 +310,14 @@ static void full_flush_env(ErlNifEnv* env)
HEAP_TOP(c_p) = env->hp;
}
else {
+ Uint usz;
ASSERT(env->hp_end != HEAP_LIMIT(c_p));
ASSERT(env->hp_end - env->hp <= env->heap_frag->alloc_size);
HEAP_TOP(c_p) = HEAP_TOP(env->proc);
- env->heap_frag->used_size = env->hp - env->heap_frag->mem;
+ usz = env->hp - env->heap_frag->mem;
+ env->proc->mbuf_sz += usz - env->heap_frag->used_size;
+ env->heap_frag->used_size = usz;
ASSERT(env->heap_frag->used_size <= env->heap_frag->alloc_size);
@@ -394,9 +399,12 @@ static void flush_env(ErlNifEnv* env)
HEAP_TOP(env->proc) = env->hp;
}
else {
+ Uint usz;
ASSERT(env->hp_end != HEAP_LIMIT(env->proc));
ASSERT(env->hp_end - env->hp <= env->heap_frag->alloc_size);
- env->heap_frag->used_size = env->hp - env->heap_frag->mem;
+ usz = env->hp - env->heap_frag->mem;
+ env->proc->mbuf_sz += usz - env->heap_frag->used_size;
+ env->heap_frag->used_size = usz;
ASSERT(env->heap_frag->used_size <= env->heap_frag->alloc_size);
}
}
diff --git a/erts/emulator/beam/erl_process.h b/erts/emulator/beam/erl_process.h
index 94c13bb948..3347a7a60e 100644
--- a/erts/emulator/beam/erl_process.h
+++ b/erts/emulator/beam/erl_process.h
@@ -1328,10 +1328,13 @@ ERTS_GLB_INLINE void erts_heap_frag_shrink(Process* p, Eterm* hp);
ERTS_GLB_INLINE void erts_heap_frag_shrink(Process* p, Eterm* hp)
{
ErlHeapFragment* hf = MBUF(p);
+ Uint sz;
ASSERT(hf!=NULL && (hp - hf->mem < hf->alloc_size));
- hf->used_size = hp - hf->mem;
+ sz = hp - hf->mem;
+ p->mbuf_sz -= hf->used_size - sz;
+ hf->used_size = sz;
}
#endif /* inline */
@@ -1549,9 +1552,9 @@ extern int erts_system_profile_ts_type;
#define ERTS_SCHEDULER_IS_DIRTY(ESDP) \
((ESDP)->dirty_no.s.num != 0)
#define ERTS_SCHEDULER_IS_DIRTY_CPU(ESDP) \
- ((ESDP)->dirty_no.s.type == 0)
+ (ERTS_SCHEDULER_IS_DIRTY((ESDP)) & ((ESDP)->dirty_no.s.type == 0))
#define ERTS_SCHEDULER_IS_DIRTY_IO(ESDP) \
- ((ESDP)->dirty_no.s.type == 1)
+ (ERTS_SCHEDULER_IS_DIRTY((ESDP)) & ((ESDP)->dirty_no.s.type == 1))
#else
#define ERTS_SCHEDULER_IS_DIRTY(ESDP) 0
#define ERTS_SCHEDULER_IS_DIRTY_CPU(ESDP) 0
diff --git a/erts/emulator/beam/utils.c b/erts/emulator/beam/utils.c
index 85647b8500..6786657faf 100644
--- a/erts/emulator/beam/utils.c
+++ b/erts/emulator/beam/utils.c
@@ -102,6 +102,7 @@ erts_heap_alloc(Process* p, Uint need, Uint xtra)
if (bp != NULL && need <= (bp->alloc_size - bp->used_size)) {
Eterm* ret = bp->mem + bp->used_size;
bp->used_size += need;
+ p->mbuf_sz += need;
return ret;
}
#ifdef DEBUG
@@ -124,7 +125,7 @@ erts_heap_alloc(Process* p, Uint need, Uint xtra)
MBUF(p) = bp;
bp->alloc_size = n;
bp->used_size = need;
- MBUF_SIZE(p) += n;
+ MBUF_SIZE(p) += need;
bp->off_heap.first = NULL;
bp->off_heap.overhead = 0;
return bp->mem;
diff --git a/erts/emulator/sys/common/erl_poll.c b/erts/emulator/sys/common/erl_poll.c
index e394d84f73..b8a28bcc18 100644
--- a/erts/emulator/sys/common/erl_poll.c
+++ b/erts/emulator/sys/common/erl_poll.c
@@ -75,6 +75,7 @@
#include "erl_driver.h"
#include "erl_alloc.h"
#include "erl_msacc.h"
+#include "erl_misc_utils.h"
#if !defined(ERTS_POLL_USE_EPOLL) \
&& !defined(ERTS_POLL_USE_DEVPOLL) \
@@ -2132,16 +2133,19 @@ get_timeout(ErtsPollSet ps,
if (timeout > (ErtsMonotonicTime) INT_MAX)
timeout = (ErtsMonotonicTime) INT_MAX;
save_timeout_time += ERTS_MSEC_TO_MONOTONIC(timeout);
+ timeout -= ERTS_PREMATURE_TIMEOUT(timeout, 1000);
break;
case 1000000:
/* Round up to nearest even micro second */
timeout = ERTS_MONOTONIC_TO_USEC(diff_time - 1) + 1;
save_timeout_time += ERTS_USEC_TO_MONOTONIC(timeout);
+ timeout -= ERTS_PREMATURE_TIMEOUT(timeout, 1000*1000);
break;
case 1000000000:
/* Round up to nearest even nano second */
timeout = ERTS_MONOTONIC_TO_NSEC(diff_time - 1) + 1;
save_timeout_time += ERTS_NSEC_TO_MONOTONIC(timeout);
+ timeout -= ERTS_PREMATURE_TIMEOUT(timeout, 1000*1000*1000);
break;
default:
ERTS_INTERNAL_ERROR("Invalid resolution");
@@ -2452,7 +2456,15 @@ ERTS_POLL_EXPORT(erts_poll_wait)(ErtsPollSet ps,
}
#endif
- res = check_fd_events(ps, to, no_fds);
+ while (1) {
+ res = check_fd_events(ps, to, no_fds);
+ if (res != 0)
+ break;
+ if (to == ERTS_POLL_NO_TIMEOUT)
+ break;
+ if (erts_get_monotonic_time(NULL) >= timeout_time)
+ break;
+ }
woke_up(ps);
diff --git a/erts/include/internal/erl_misc_utils.h b/erts/include/internal/erl_misc_utils.h
index a4a5d1d510..55566ddf74 100644
--- a/erts/include/internal/erl_misc_utils.h
+++ b/erts/include/internal/erl_misc_utils.h
@@ -56,4 +56,33 @@ int erts_map_win_error_to_errno(DWORD win_error);
int erts_get_last_win_errno(void);
#endif
+#if defined(__APPLE__) && defined(__MACH__) && !defined(__DARWIN__)
+#define __DARWIN__ 1
+#endif
+
+/*
+ * ERTS_PREMATURE_TIMEOUT() expects time units
+ * 1000 (millisec), 1000000 (microsec), or
+ * 1000000000 (nanosec). Might not work properly
+ * otherwise.
+ */
+#undef ERTS_USE_PREMATURE_TIMEOUT
+#undef ERTS_PREMATURE_TIMEOUT
+
+#if defined(__DARWIN__)
+#define ERTS_USE_PREMATURE_TIMEOUT 1
+#define ERTS_PREMATURE_TIMEOUT(TMO, TU) \
+ ((TMO) >= 1 * ((TU) / 1000) \
+ ? ((TMO) >= 20 * ((TU) / 1000) \
+ ? 15 * ((TU) / 1000) \
+ : ((TMO) >= 5 * ((TU) / 1000) \
+ ? 3 * ((TU) / 1000) \
+ : 5 * ((TU) / 10000))) \
+ : 0)
+
+#else
+#define ERTS_USE_PREMATURE_TIMEOUT 0
+#define ERTS_PREMATURE_TIMEOUT(TMO, TU) (0)
+#endif
+
#endif /* #ifndef ERL_MISC_UTILS_H_ */
diff --git a/erts/lib_src/pthread/ethr_event.c b/erts/lib_src/pthread/ethr_event.c
index eef88d5002..464875570a 100644
--- a/erts/lib_src/pthread/ethr_event.c
+++ b/erts/lib_src/pthread/ethr_event.c
@@ -184,6 +184,8 @@ return_event_on:
#include <errno.h>
#include <string.h>
+#include "erl_misc_utils.h"
+
#ifdef __DARWIN__
struct ethr_event_fdsets___ {
@@ -346,12 +348,9 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
ethr_sint32_t val;
int res, ulres;
int until_yield = ETHR_YIELD_AFTER_BUSY_LOOPS;
- ethr_sint64_t time = 0; /* SHUT UP annoying faulty warning... */
+ ethr_sint64_t time = 0;
#ifdef ETHR_HAVE_ETHR_GET_MONOTONIC_TIME
- ethr_sint64_t start = 0; /* SHUT UP annoying faulty warning... */
-#endif
-#ifdef ETHR_HAVE_PTHREAD_COND_TIMEDWAIT_MONOTONIC
- struct timespec cond_timeout;
+ ethr_sint64_t timeout_time = 0; /* SHUT UP annoying faulty warning... */
#endif
val = ethr_atomic32_read(&e->state);
@@ -365,30 +364,27 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
if (timeout == 0)
return ETIMEDOUT;
else {
- time = timeout;
- switch (e->fd[0]) {
- case ETHR_EVENT_INVALID_FD__:
#ifdef ETHR_HAVE_ETHR_GET_MONOTONIC_TIME
- start = ethr_get_monotonic_time();
+ timeout_time = ethr_get_monotonic_time();
+ timeout_time += timeout;
#endif
+ switch (e->fd[0]) {
+ case ETHR_EVENT_INVALID_FD__:
+ time = timeout;
setup_nonblocking_pipe(e);
break;
#ifdef ETHR_HAVE_PTHREAD_COND_TIMEDWAIT_MONOTONIC
case ETHR_EVENT_COND_TIMEDWAIT__:
- time += ethr_get_monotonic_time();
- cond_timeout.tv_sec = time / (1000*1000*1000);
- cond_timeout.tv_nsec = time % (1000*1000*1000);
+ time = -1;
if (spincount == 0)
goto set_event_off_waiter;
break;
#endif
default:
+ time = timeout;
/* Already initialized pipe... */
if (spincount == 0)
goto set_select_timeout;
-#ifdef ETHR_HAVE_ETHR_GET_MONOTONIC_TIME
- start = ethr_get_monotonic_time();
-#endif
break;
}
}
@@ -418,6 +414,9 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
|| e->fd[0] == ETHR_EVENT_COND_TIMEDWAIT__
#endif
) {
+#ifdef ETHR_HAVE_PTHREAD_COND_TIMEDWAIT_MONOTONIC
+ struct timespec cond_timeout;
+#endif
set_event_off_waiter:
@@ -446,9 +445,35 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
#ifdef ETHR_HAVE_PTHREAD_COND_TIMEDWAIT_MONOTONIC
if (timeout > 0) {
+ if (time != timeout_time) {
+ time = timeout_time;
+
+#if ERTS_USE_PREMATURE_TIMEOUT
+ {
+ ethr_sint64_t rtmo;
+
+ rtmo = timeout_time - ethr_get_monotonic_time();
+ if (rtmo <= 0) {
+ res = ETIMEDOUT;
+ break;
+ }
+ time = timeout_time;
+ time -= ERTS_PREMATURE_TIMEOUT(rtmo, 1000*1000*1000);
+ }
+#endif
+
+ cond_timeout.tv_sec = time / (1000*1000*1000);
+ cond_timeout.tv_nsec = time % (1000*1000*1000);
+ }
res = pthread_cond_timedwait(&e->cnd, &e->mtx, &cond_timeout);
- if (res == EINTR || res == ETIMEDOUT)
+ if (res == EINTR
+ || (res == ETIMEDOUT
+#if ERTS_USE_PREMATURE_TIMEOUT
+ && time == timeout_time
+#endif
+ )) {
break;
+ }
}
else
#endif
@@ -477,7 +502,11 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
struct timeval select_timeout;
#ifdef ETHR_HAVE_ETHR_GET_MONOTONIC_TIME
- time -= ethr_get_monotonic_time() - start;
+#if ERTS_USE_PREMATURE_TIMEOUT
+ restart_select:
+#endif
+
+ time = timeout_time - ethr_get_monotonic_time();
if (time <= 0)
return ETIMEDOUT;
#endif
@@ -492,6 +521,11 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
*/
time = ((time - 1) / 1000) + 1;
+#if defined(ETHR_HAVE_ETHR_GET_MONOTONIC_TIME) \
+ && ERTS_USE_PREMATURE_TIMEOUT
+ time -= ERTS_PREMATURE_TIMEOUT(time, 1000*1000);
+#endif
+
select_timeout.tv_sec = time / (1000*1000);
select_timeout.tv_usec = time % (1000*1000);
@@ -559,7 +593,11 @@ wait__(ethr_event *e, int spincount, ethr_sint64_t timeout)
val = ethr_atomic32_read(&e->state);
if (val == ETHR_EVENT_ON__)
goto return_event_on;
-
+#if defined(ETHR_HAVE_ETHR_GET_MONOTONIC_TIME) \
+ && ERTS_USE_PREMATURE_TIMEOUT
+ if (res == ETIMEDOUT)
+ goto restart_select; /* Verify timeout */
+#endif
}
return res;
diff --git a/lib/tools/emacs/erlang-test.el b/lib/tools/emacs/erlang-test.el
index 9a146632c5..ba6190d194 100644
--- a/lib/tools/emacs/erlang-test.el
+++ b/lib/tools/emacs/erlang-test.el
@@ -52,28 +52,42 @@ concatenated to form an erlang file to test on.")
(ert-deftest erlang-test-tags ()
(let* ((dir (make-temp-file "erlang-test" t))
- (erlang-file (expand-file-name "erlang_test.erl" dir))
- (tags-file (expand-file-name "TAGS" dir))
- tags-file-name tags-table-list erlang-buffer)
- (unwind-protect
- (progn
- (erlang-test-create-erlang-file erlang-file)
- (erlang-test-compile-tags erlang-file tags-file)
- (setq erlang-buffer (find-file-noselect erlang-file))
- (with-current-buffer erlang-buffer
- (setq-local tags-file-name tags-file))
- ;; Setting global tags-file-name is a workaround for
- ;; GNU Emacs bug#23164.
- (setq tags-file-name tags-file)
- (erlang-test-completion-table)
- (erlang-test-xref-find-definitions erlang-file erlang-buffer))
- (when (buffer-live-p erlang-buffer)
- (kill-buffer erlang-buffer))
- (let ((tags-buffer (find-buffer-visiting tags-file)))
- (when (buffer-live-p tags-buffer)
- (kill-buffer tags-buffer)))
- (when (file-exists-p dir)
- (delete-directory dir t)))))
+ (erlang-file (expand-file-name "erlang_test.erl" dir))
+ (tags-file (expand-file-name "TAGS" dir))
+ (old-tags-file-name (default-value 'tags-file-name))
+ (old-tags-table-list (default-value 'tags-table-list))
+ tags-file-name
+ tags-table-list
+ tags-table-set-list
+ erlang-buffer
+ erlang-mode-hook
+ prog-mode-hook
+ erlang-shell-mode-hook
+ tags-add-tables)
+ (unwind-protect
+ (progn
+ (setq-default tags-file-name nil)
+ (setq-default tags-table-list nil)
+ (erlang-test-create-erlang-file erlang-file)
+ (erlang-test-compile-tags erlang-file tags-file)
+ (setq erlang-buffer (find-file-noselect erlang-file))
+ (with-current-buffer erlang-buffer
+ (setq-local tags-file-name tags-file))
+ ;; Setting global tags-file-name is a workaround for
+ ;; GNU Emacs bug#23164.
+ (setq tags-file-name tags-file)
+ (erlang-test-complete-at-point tags-file)
+ (erlang-test-completion-table)
+ (erlang-test-xref-find-definitions erlang-file erlang-buffer))
+ (when (buffer-live-p erlang-buffer)
+ (kill-buffer erlang-buffer))
+ (let ((tags-buffer (find-buffer-visiting tags-file)))
+ (when (buffer-live-p tags-buffer)
+ (kill-buffer tags-buffer)))
+ (when (file-exists-p dir)
+ (delete-directory dir t))
+ (setq-default tags-file-name old-tags-file-name)
+ (setq-default tags-table-list old-tags-table-list))))
(defun erlang-test-create-erlang-file (erlang-file)
(with-temp-file erlang-file
@@ -116,6 +130,54 @@ concatenated to form an erlang file to test on.")
(should (eq expected-line (line-number-at-pos)))
(should (= (point-at-bol) (point))))
+(defun erlang-test-complete-at-point (tags-file)
+ (with-temp-buffer
+ (erlang-mode)
+ (setq-local tags-file-name tags-file)
+ (insert "\nerlang_test:fun")
+ (erlang-complete-tag)
+ (should (looking-back "erlang_test:function"))
+ (insert "\nfun")
+ (erlang-complete-tag)
+ (should (looking-back "function"))
+ (insert "\nerlang_")
+ (erlang-complete-tag)
+ (should (looking-back "erlang_test:"))))
+
+
+(ert-deftest erlang-test-compile-options ()
+ (erlang-test-format-opt t
+ "t")
+ (erlang-test-format-opt nil
+ "nil")
+ (erlang-test-format-opt (cons 1 2)
+ "{1, 2}")
+ (erlang-test-format-opt (list 1)
+ "[1]")
+ (erlang-test-format-opt (list 1 2)
+ "[1, 2]")
+ (erlang-test-format-opt (list 1 2 3)
+ "[1, 2, 3]")
+ (erlang-test-format-opt 'symbol
+ "symbol")
+ (erlang-test-format-opt "string"
+ "\"string\"")
+ (erlang-test-format-opt []
+ "{}")
+ (erlang-test-format-opt [1]
+ "{1}")
+ (erlang-test-format-opt [1 2]
+ "{1, 2}")
+ (erlang-test-format-opt [1 2 (3 [4 5 6] 7)]
+ "{1, 2, [3, {4, 5, 6}, 7]}"))
+
+(defun erlang-test-format-opt (elisp &optional expected-erlang)
+ (let ((erlang (inferior-erlang-format-opt elisp)))
+ (message "%s -> %s" elisp erlang)
+ (when expected-erlang
+ (should (equal erlang expected-erlang)))
+ erlang))
+
(provide 'erlang-test)
diff --git a/lib/tools/emacs/erlang.el b/lib/tools/emacs/erlang.el
index a2062180f3..73c6b8d768 100644
--- a/lib/tools/emacs/erlang.el
+++ b/lib/tools/emacs/erlang.el
@@ -1436,8 +1436,6 @@ Other commands:
(erlang-skel-init)
(when (fboundp 'tempo-use-tag-list)
(tempo-use-tag-list 'erlang-tempo-tags))
- (when (boundp 'xref-backend-functions)
- (add-hook 'xref-backend-functions #'erlang-etags--xref-backend nil t))
(run-hooks 'erlang-mode-hook)
(if (zerop (buffer-size))
(run-hooks 'erlang-new-file-hook)))
@@ -1548,9 +1546,7 @@ Other commands:
(set (make-local-variable 'outline-regexp) "[[:lower:]0-9_]+ *(.*) *-> *$")
(set (make-local-variable 'outline-level) (lambda () 1))
(set (make-local-variable 'add-log-current-defun-function)
- 'erlang-current-defun)
- (set (make-local-variable 'find-tag-default-function)
- 'erlang-find-tag-for-completion))
+ 'erlang-current-defun))
(defun erlang-font-lock-init ()
"Initialize Font Lock for Erlang mode."
@@ -3233,18 +3229,16 @@ With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(while (and (looking-at "[ \t]*[%\n]")
- (zerop (forward-line 1))))
+ (zerop (forward-line 1))))
;; Move to the next clause.
(erlang-beginning-of-clause (- arg))
(beginning-of-line);; Just to be sure...
(let ((continue t))
(while (and (not (bobp)) continue)
(forward-line -1)
- (skip-chars-forward " \t")
- (if (looking-at "[%\n]")
- nil
- (end-of-line)
- (setq continue nil)))))
+ (unless (looking-at "[ \t]*[%\n]")
+ (end-of-line)
+ (setq continue nil)))))
(defun erlang-mark-clause ()
"Put mark at end of clause, point at beginning."
@@ -4352,11 +4346,6 @@ as on the old form `tag'.
In the completion list, `module:tag' and `module:' shows up.
-Call this function from an appropriate init file, or add it to
-Erlang mode hook with the commands:
- (add-hook 'erlang-mode-hook 'erlang-tags-init)
- (add-hook 'erlang-shell-mode-hook 'erlang-tags-init)
-
This function only works under Emacs 18 and Emacs 19. Currently, It
is not implemented under XEmacs. (Hint: The Emacs 19 etags module
works under XEmacs.)"
@@ -4367,11 +4356,16 @@ works under XEmacs.)"
(setq erlang-tags-installed t))
(t
(require 'etags)
- ;; Test on a function available in the Emacs 19 version
- ;; of tags but not in the XEmacs version.
- (when (fboundp 'find-tag-noselect)
- (erlang-tags-define-keys (current-local-map))
- (setq erlang-tags-installed t)))))
+ (set (make-local-variable 'find-tag-default-function)
+ 'erlang-find-tag-for-completion)
+ (if (>= emacs-major-version 25)
+ (add-hook 'xref-backend-functions
+ #'erlang-etags--xref-backend nil t)
+ ;; Test on a function available in the Emacs 19 version
+ ;; of tags but not in the XEmacs version.
+ (when (fboundp 'find-tag-noselect)
+ (erlang-tags-define-keys (current-local-map))
+ (setq erlang-tags-installed t))))))
@@ -4775,8 +4769,6 @@ for a tag on the form `module:tag'."
;;; completion-table' containing all normal tags plus tags on the form
;;; `module:tag' and `module:'.
-;; PENDING - Should probably make use of the
-;; `completion-at-point-functions' hook instead of this advice.
(when (and (locate-library "etags")
(require 'etags)
(fboundp 'etags-tags-completion-table)
@@ -4784,11 +4776,7 @@ for a tag on the form `module:tag'."
(if (fboundp 'advice-add)
;; Emacs 24.4+
(advice-add 'etags-tags-completion-table :around
- (lambda (oldfun)
- (if erlang-replace-etags-tags-completion-table
- (erlang-etags-tags-completion-table)
- (funcall oldfun)))
- (list :name 'erlang-replace-tags-table))
+ #'erlang-etags-tags-completion-table-advice)
;; Emacs 23.1-24.3
(defadvice etags-tags-completion-table (around
erlang-replace-tags-table
@@ -4797,6 +4785,11 @@ for a tag on the form `module:tag'."
(setq ad-return-value (erlang-etags-tags-completion-table))
ad-do-it))))
+(defun erlang-etags-tags-completion-table-advice (oldfun)
+ (if erlang-replace-etags-tags-completion-table
+ (erlang-etags-tags-completion-table)
+ (funcall oldfun)))
+
(defun erlang-complete-tag ()
"Perform tags completion on the text around point.
Completes to the set of names listed in the current tags table.
@@ -4807,8 +4800,7 @@ about Erlang modules."
(condition-case nil
(require 'etags)
(error nil))
- (cond ((and erlang-tags-installed
- (fboundp 'etags-tags-completion-table)
+ (cond ((and (fboundp 'etags-tags-completion-table)
(fboundp 'tags-lazy-completion-table)) ; Emacs 23.1+
(let ((erlang-replace-etags-tags-completion-table t))
(complete-tag)))
@@ -5213,19 +5205,10 @@ The following special commands are available:
(setq comint-input-ignoredups t)
(setq comint-scroll-show-maximum-output t)
(setq comint-scroll-to-bottom-on-output t)
- ;; In Emacs 19.30, `add-hook' has got a `local' flag, use it. If
- ;; the call fails, just call the normal `add-hook'.
- (condition-case nil
- (progn
- (add-hook 'comint-output-filter-functions
- 'inferior-erlang-strip-delete nil t)
- (add-hook 'comint-output-filter-functions
- 'inferior-erlang-strip-ctrl-m nil t))
- (error
- (funcall (symbol-function 'make-local-hook)
- 'comint-output-filter-functions) ; obsolete as of Emacs 21.1
- (add-hook 'comint-output-filter-functions 'inferior-erlang-strip-delete)
- (add-hook 'comint-output-filter-functions 'inferior-erlang-strip-ctrl-m)))
+ (add-hook 'comint-output-filter-functions
+ 'inferior-erlang-strip-delete nil t)
+ (add-hook 'comint-output-filter-functions
+ 'inferior-erlang-strip-ctrl-m nil t)
;; Some older versions of comint don't have an input ring.
(if (fboundp 'comint-read-input-ring)
(progn
@@ -5251,6 +5234,7 @@ The following special commands are available:
(define-key map [menu-bar compilation]
(cons "Errors" compilation-menu-map)))
map)))))
+ (erlang-tags-init)
(run-hooks 'erlang-shell-mode-hook))
@@ -5730,31 +5714,29 @@ unless the optional NO-DISPLAY is non-nil."
(defun inferior-erlang-format-comma-opts (opts)
(if (null opts)
""
- (concat ", " (inferior-erlang-format-opts opts))))
-
-(defun inferior-erlang-format-opts (opts)
- (concat "[" (inferior-erlang-string-join (mapcar 'inferior-erlang-format-opt
- opts)
- ", ")
- "]"))
+ (concat ", " (inferior-erlang-format-opt opts))))
(defun inferior-erlang-format-opt (opt)
(cond ((stringp opt) (concat "\"" opt "\""))
- ((atom opt) (format "%s" opt))
- ((consp opt) (concat "{" (inferior-erlang-string-join
- (mapcar 'inferior-erlang-format-opt
- (list (car opt) (cdr opt)))
- ", ")
- "}"))
- (t (error (format "Unexpected opt %s" opt)))))
-
-(defun inferior-erlang-string-join (strs sep)
- (let ((result (or (car strs) "")))
- (setq strs (cdr strs))
- (while strs
- (setq result (concat result sep (car strs)))
- (setq strs (cdr strs)))
- result))
+ ((vectorp opt) (inferior-erlang-tuple (append opt nil)))
+ ((atom opt) (format "%s" opt))
+ ((consp opt) (if (listp (cdr opt))
+ (inferior-erlang-list opt)
+ (inferior-erlang-tuple (list (car opt) (cdr opt)))))
+ (t (error "Unexpected erlang compile option %s" opt))))
+
+(defun inferior-erlang-tuple (opts)
+ (concat "{" (mapconcat 'inferior-erlang-format-opt
+ opts
+ ", ")
+ "}"))
+
+(defun inferior-erlang-list (opts)
+ (concat "[" (mapconcat 'inferior-erlang-format-opt
+ opts
+ ", ")
+ "]"))
+
(defun erlang-local-buffer-file-name ()
;; When editing a file remotely via tramp,
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 06:29:35 +0000