diff options
88 files changed, 2509 insertions, 658 deletions
diff --git a/HOWTO/INSTALL.md b/HOWTO/INSTALL.md index adfc44baae..2ae1ed3c8d 100644 --- a/HOWTO/INSTALL.md +++ b/HOWTO/INSTALL.md @@ -68,7 +68,7 @@ also find the utilities needed for building the documentation. Required for building the application `crypto`. Further, `ssl` and `ssh` require a working crypto application and will also be skipped if OpenSSL is missing. The `public_key` - application will available without `crypto`, but the functionality + application is available without `crypto`, but the functionality will be very limited. The development package of OpenSSL including the header files are needed as well diff --git a/configure.in b/configure.in index fc9aeee455..8a7f372a50 100644 --- a/configure.in +++ b/configure.in @@ -234,8 +234,8 @@ AS_HELP_STRING([--enable-native-libs], [compile Erlang libraries to native code])) AC_ARG_WITH(dynamic-trace, -AS_HELP_STRING([--with-dynamic-trace={dtrace|systemtap}], - [specify use of dynamic trace framework, dtrace or systemtap]) +AS_HELP_STRING([--with-dynamic-trace={dtrace|lttng|systemtap}], + [specify use of dynamic trace framework, dtrace, lttng or systemtap]) AS_HELP_STRING([--without-dynamic-trace], [don't enable any dynamic tracing (default)])) AC_ARG_ENABLE(vm-probes, diff --git a/erts/configure.in b/erts/configure.in index 77a4d32787..0257079c3b 100644 --- a/erts/configure.in +++ b/erts/configure.in @@ -234,8 +234,8 @@ AS_HELP_STRING([--enable-m32-build], ],enable_m32_build=no) AC_ARG_WITH(dynamic-trace, -AS_HELP_STRING([--with-dynamic-trace={dtrace|systemtap}], - [specify use of dynamic trace framework, dtrace or systemtap]) +AS_HELP_STRING([--with-dynamic-trace={dtrace|lttng|systemtap}], + [specify use of dynamic trace framework, dtrace, lttng or systemtap]) AS_HELP_STRING([--without-dynamic-trace], [don't enable any dynamic tracing (default)])) @@ -245,6 +245,10 @@ fi case "$with_dynamic_trace" in no) DYNAMIC_TRACE_FRAMEWORK=;; + lttng) + AC_DEFINE(USE_LTTNG,[1], + [Define if you want to use lttng for dynamic tracing]) + DYNAMIC_TRACE_FRAMEWORK=lttng;; dtrace) AC_DEFINE(USE_DTRACE,[1], [Define if you want to use dtrace for dynamic tracing]) @@ -280,10 +284,12 @@ AS_HELP_STRING([--enable-vm-probes], fi) AC_SUBST(USE_VM_PROBES) -if test X"$use_vm_probes" = X"yes"; then - USE_VM_PROBES=yes - AC_DEFINE(USE_VM_PROBES,[1], - [Define to enable VM dynamic trace probes]) +if test X"$DYNAMIC_TRACE_FRAMEWORK" != X"lttng"; then + if test X"$use_vm_probes" = X"yes"; then + USE_VM_PROBES=yes + AC_DEFINE(USE_VM_PROBES,[1], + [Define to enable VM dynamic trace probes]) + fi fi AC_ARG_WITH(assumed-cache-line-size, @@ -3756,14 +3762,20 @@ dnl LM_FIND_EMU_CC dnl -dnl DTrace +dnl DTrace & LTTNG dnl case $DYNAMIC_TRACE_FRAMEWORK in dtrace|systemtap) AC_CHECK_TOOL(DTRACE, dtrace, none) test "$DTRACE" = "none" && AC_MSG_ERROR([No dtrace utility found.]); + enable_lttng_test=no enable_dtrace_test=yes;; - *) enable_dtrace_test=no;; + lttng) + enable_lttng_test=yes + enable_dtrace_test=no;; + *) + enable_lttng_test=no + enable_dtrace_test=no;; esac AC_SUBST(DTRACE) @@ -3830,6 +3842,37 @@ if test "$enable_dtrace_test" = "yes" ; then fi fi +if test "$enable_lttng_test" = "yes" ; then + AC_CHECK_HEADERS(lttng/tracepoint.h) + AC_CHECK_HEADERS(lttng/tracepoint-event.h) + dnl The macro tracepoint_enabled is not present in older lttng versions + dnl checking for tracepoint_enabled + AC_MSG_CHECKING([for tracepoint_enabled in lttng/tracepoint.h]) + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [#include <lttng/tracepoint.h> + #define TRACEPOINT_PROVIDER com_ericsson_otp + TRACEPOINT_EVENT( + com_ericsson_otp, + dummy, + TP_ARGS(int, my_int), + TP_FIELDS(ctf_integer(int, my_int, my_int))) + #define TRACEPOINT_CREATE_PROBES + #define TRACEPOINT_DEFINE], + [if(tracepoint_enabled(com_ericsson_otp,dummy)) do {} while(0)])], + [AC_MSG_RESULT([yes])], + [AC_MSG_ERROR([no (must be present)])]) + if test "x$ac_cv_header_lttng_tracepoint_h" = "xyes" \ + -a "x$ac_cv_header_lttng_tracepoint_event_h" = "xyes"; then + # No straight forward way to test for liblttng-ust when no public symbol exists, + # just add the lib. + LIBS="$LIBS -llttng-ust -ldl" + else + AC_MSG_ERROR([No LTTng support found.]) + fi +fi + + dnl dnl SSL, SSH and CRYPTO need the OpenSSL libraries dnl diff --git a/erts/emulator/Makefile.in b/erts/emulator/Makefile.in index 12148ad9c7..3a5cfddc30 100644 --- a/erts/emulator/Makefile.in +++ b/erts/emulator/Makefile.in @@ -779,6 +779,8 @@ RUN_OBJS = \ $(OBJDIR)/erl_ptab.o $(OBJDIR)/erl_map.o \ $(OBJDIR)/erl_msacc.o +LTTNG_OBJS = $(OBJDIR)/erlang_lttng.o + ifeq ($(TARGET),win32) DRV_OBJS = \ $(OBJDIR)/registry_drv.o \ @@ -885,7 +887,7 @@ ifdef HIPE_ENABLED EXTRA_BASE_OBJS += $(HIPE_OBJS) endif -BASE_OBJS = $(EMU_OBJS) $(RUN_OBJS) $(OS_OBJS) $(EXTRA_BASE_OBJS) +BASE_OBJS = $(EMU_OBJS) $(RUN_OBJS) $(OS_OBJS) $(EXTRA_BASE_OBJS) $(LTTNG_OBJS) before_DTrace_OBJS = $(BASE_OBJS) $(DRV_OBJS) diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c index a390422040..d648a2f23c 100644 --- a/erts/emulator/beam/beam_emu.c +++ b/erts/emulator/beam/beam_emu.c @@ -3360,48 +3360,18 @@ do { \ goto do_schedule; } - OpCase(raise_ss): { - /* This was not done very well in R10-0; then, we passed the tag in - the first argument and hoped that the existing c_p->ftrace was - still correct. But the ftrace-object already includes the tag - (or rather, the freason). Now, we pass the original ftrace in - the first argument. We also handle atom tags in the first - argument for backwards compatibility. - */ - Eterm raise_val1; - Eterm raise_val2; - GetArg2(0, raise_val1, raise_val2); - c_p->fvalue = raise_val2; - if (c_p->freason == EXC_NULL) { - /* a safety check for the R10-0 case; should not happen */ - c_p->ftrace = NIL; - c_p->freason = EXC_ERROR; - } - /* for R10-0 code, keep existing c_p->ftrace and hope it's correct */ - switch (raise_val1) { - case am_throw: - c_p->freason = EXC_THROWN & ~EXF_SAVETRACE; - break; - case am_error: - c_p->freason = EXC_ERROR & ~EXF_SAVETRACE; - break; - case am_exit: - c_p->freason = EXC_EXIT & ~EXF_SAVETRACE; - break; - default: - {/* R10-1 and later - XXX note: should do sanity check on given trace if it can be - passed from a user! Currently only expecting generated calls. - */ - struct StackTrace *s; - c_p->ftrace = raise_val1; - s = get_trace_from_exc(raise_val1); - if (s == NULL) { - c_p->freason = EXC_ERROR; - } else { - c_p->freason = PRIMARY_EXCEPTION(s->freason); - } - } + OpCase(i_raise): { + Eterm raise_trace = x(2); + Eterm raise_value = x(1); + struct StackTrace *s; + + c_p->fvalue = raise_value; + c_p->ftrace = raise_trace; + s = get_trace_from_exc(raise_trace); + if (s == NULL) { + c_p->freason = EXC_ERROR; + } else { + c_p->freason = PRIMARY_EXCEPTION(s->freason); } goto find_func_info; } @@ -4102,7 +4072,7 @@ do { \ StoreBifResult(1, result); } - OpCase(i_bs_put_utf16_jIs): { + OpCase(bs_put_utf16_jIs): { Eterm arg; GetArg1(2, arg); diff --git a/erts/emulator/beam/beam_load.c b/erts/emulator/beam/beam_load.c index 16cbdbffea..a98900460e 100644 --- a/erts/emulator/beam/beam_load.c +++ b/erts/emulator/beam/beam_load.c @@ -2028,42 +2028,47 @@ load_code(LoaderState* stp) ASSERT(arity == last_op->arity); do_transform: - if (stp->genop == NULL) { - last_op_next = NULL; - goto get_next_instr; - } - + ASSERT(stp->genop != NULL); if (gen_opc[stp->genop->op].transform != -1) { - int need; - tmp_op = stp->genop; - - for (need = gen_opc[stp->genop->op].min_window-1; need > 0; need--) { - if (tmp_op == NULL) { - goto get_next_instr; - } - tmp_op = tmp_op->next; + if (stp->genop->next == NULL) { + /* + * Simple heuristic: Most transformations requires + * at least two instructions, so make sure that + * there are. That will reduce the number of + * TE_SHORT_WINDOWs. + */ + goto get_next_instr; } switch (transform_engine(stp)) { case TE_FAIL: - last_op_next = NULL; - last_op = NULL; + /* + * No transformation found. stp->genop != NULL and + * last_op_next is still valid. Go ahead and load + * the instruction. + */ break; case TE_OK: + /* + * Some transformation was applied. last_op_next is + * no longer valid and stp->genop may be NULL. + * Try to transform again. + */ + if (stp->genop == NULL) { + last_op_next = &stp->genop; + goto get_next_instr; + } last_op_next = NULL; - last_op = NULL; goto do_transform; case TE_SHORT_WINDOW: - last_op_next = NULL; - last_op = NULL; + /* + * No transformation applied. stp->genop != NULL and + * last_op_next is still valid. Fetch a new instruction + * before trying the transformation again. + */ goto get_next_instr; } } - if (stp->genop == NULL) { - last_op_next = NULL; - goto get_next_instr; - } - /* * From the collected generic instruction, find the specific * instruction. @@ -2584,7 +2589,10 @@ load_code(LoaderState* stp) { GenOp* next = stp->genop->next; FREE_GENOP(stp, stp->genop); - stp->genop = next; + if ((stp->genop = next) == NULL) { + last_op_next = &stp->genop; + goto get_next_instr; + } goto do_transform; } } @@ -2728,13 +2736,6 @@ mixed_types(LoaderState* stp, GenOpArg Size, GenOpArg* Rest) } static int -same_label(LoaderState* stp, GenOpArg Target, GenOpArg Label) -{ - return Target.type = TAG_f && Label.type == TAG_u && - Target.val == Label.val; -} - -static int is_killed_apply(LoaderState* stp, GenOpArg Reg, GenOpArg Live) { return Reg.type == TAG_x && Live.type == TAG_u && @@ -4805,31 +4806,25 @@ transform_engine(LoaderState* st) Uint op; int ap; /* Current argument. */ Uint* restart; /* Where to restart if current match fails. */ - GenOpArg def_vars[TE_MAX_VARS]; /* Default buffer for variables. */ - GenOpArg* var = def_vars; - int num_vars = 0; + GenOpArg var[TE_MAX_VARS]; /* Buffer for variables. */ + GenOpArg* rest_args = NULL; + int num_rest_args = 0; int i; /* General index. */ Uint mask; GenOp* instr; + GenOp* first = st->genop; + GenOp* keep = NULL; Uint* pc; - int rval; static Uint restart_fail[1] = {TOP_fail}; - ASSERT(gen_opc[st->genop->op].transform != -1); - pc = op_transform + gen_opc[st->genop->op].transform; - restart = pc; + ASSERT(gen_opc[first->op].transform != -1); + restart = op_transform + gen_opc[first->op].transform; restart: - if (var != def_vars) { - erts_free(ERTS_ALC_T_LOADER_TMP, (void *) var); - var = def_vars; - } ASSERT(restart != NULL); pc = restart; ASSERT(*pc < NUM_TOPS); /* Valid instruction? */ - instr = st->genop; - -#define RETURN(r) rval = (r); goto do_return; + instr = first; #ifdef DEBUG restart = NULL; @@ -4847,7 +4842,7 @@ transform_engine(LoaderState* st) * We'll need at least one more instruction to decide whether * this combination matches or not. */ - RETURN(TE_SHORT_WINDOW); + return TE_SHORT_WINDOW; } if (*pc++ != instr->op) goto restart; @@ -5009,19 +5004,9 @@ transform_engine(LoaderState* st) #if defined(TOP_rest_args) case TOP_rest_args: { - int n = *pc++; int formal_arity = gen_opc[instr->op].arity; - int j = formal_arity; - - num_vars = n + (instr->arity - formal_arity); - var = erts_alloc(ERTS_ALC_T_LOADER_TMP, - num_vars * sizeof(GenOpArg)); - for (i = 0; i < n; i++) { - var[i] = def_vars[i]; - } - while (i < num_vars) { - var[i++] = instr->a[j++]; - } + num_rest_args = instr->arity - formal_arity; + rest_args = instr->a + formal_arity; } break; #endif @@ -5030,21 +5015,22 @@ transform_engine(LoaderState* st) break; case TOP_commit: instr = instr->next; /* The next_instr was optimized away. */ - - /* - * The left-hand side of this transformation matched. - * Delete all matched instructions. - */ - while (st->genop != instr) { - GenOp* next = st->genop->next; - FREE_GENOP(st, st->genop); - st->genop = next; - } + keep = instr; + st->genop = instr; #ifdef DEBUG instr = 0; #endif break; - +#if defined(TOP_keep) + case TOP_keep: + /* Keep the current instruction unchanged. */ + keep = instr; + st->genop = instr; +#ifdef DEBUG + instr = 0; +#endif + break; +#endif #if defined(TOP_call_end) case TOP_call_end: { @@ -5069,22 +5055,19 @@ transform_engine(LoaderState* st) lastp = &((*lastp)->next); } - instr = instr->next; /* The next_instr was optimized away. */ - - /* - * The left-hand side of this transformation matched. - * Delete all matched instructions. - */ - while (st->genop != instr) { - GenOp* next = st->genop->next; - FREE_GENOP(st, st->genop); - st->genop = next; - } - *lastp = st->genop; + keep = instr->next; /* The next_instr was optimized away. */ + *lastp = keep; st->genop = new_instr; } - RETURN(TE_OK); + /* FALLTHROUGH */ #endif + case TOP_end: + while (first != keep) { + GenOp* next = first->next; + FREE_GENOP(st, first); + first = next; + } + return TE_OK; case TOP_new_instr: /* * Note that the instructions are generated in reverse order. @@ -5096,6 +5079,12 @@ transform_engine(LoaderState* st) instr->arity = gen_opc[op].arity; ap = 0; break; +#ifdef TOP_rename + case TOP_rename: + instr->op = op = *pc++; + instr->arity = gen_opc[op].arity; + return TE_OK; +#endif case TOP_store_type: i = *pc++; instr->a[ap].type = i; @@ -5115,14 +5104,10 @@ transform_engine(LoaderState* st) #if defined(TOP_store_rest_args) case TOP_store_rest_args: { - int n = *pc++; - int num_extra = num_vars - n; - - ASSERT(n <= num_vars); - GENOP_ARITY(instr, instr->arity+num_extra); + GENOP_ARITY(instr, instr->arity+num_rest_args); memcpy(instr->a, instr->def_args, ap*sizeof(GenOpArg)); - memcpy(instr->a+ap, var+n, num_extra*sizeof(GenOpArg)); - ap += num_extra; + memcpy(instr->a+ap, rest_args, num_rest_args*sizeof(GenOpArg)); + ap += num_rest_args; } break; #endif @@ -5134,21 +5119,12 @@ transform_engine(LoaderState* st) case TOP_try_me_else_fail: restart = restart_fail; break; - case TOP_end: - RETURN(TE_OK); case TOP_fail: - RETURN(TE_FAIL); + return TE_FAIL; default: ASSERT(0); } } -#undef RETURN - - do_return: - if (var != def_vars) { - erts_free(ERTS_ALC_T_LOADER_TMP, (void *) var); - } - return rval; } static void diff --git a/erts/emulator/beam/beam_load.h b/erts/emulator/beam/beam_load.h index 22ab71c868..68f4b96893 100644 --- a/erts/emulator/beam/beam_load.h +++ b/erts/emulator/beam/beam_load.h @@ -33,7 +33,6 @@ typedef struct gen_op_entry { int specific; int num_specific; int transform; - int min_window; } GenOpEntry; extern GenOpEntry gen_opc[]; diff --git a/erts/emulator/beam/erl_alloc.h b/erts/emulator/beam/erl_alloc.h index 71e4713624..ee2013bd93 100644 --- a/erts/emulator/beam/erl_alloc.h +++ b/erts/emulator/beam/erl_alloc.h @@ -235,9 +235,9 @@ void *erts_alloc(ErtsAlcType_t type, Uint size) void *res; ERTS_MSACC_PUSH_AND_SET_STATE_X(ERTS_MSACC_STATE_ALLOC); res = (*erts_allctrs[ERTS_ALC_T2A(type)].alloc)( - ERTS_ALC_T2N(type), - erts_allctrs[ERTS_ALC_T2A(type)].extra, - size); + ERTS_ALC_T2N(type), + erts_allctrs[ERTS_ALC_T2A(type)].extra, + size); if (!res) erts_alloc_n_enomem(ERTS_ALC_T2N(type), size); ERTS_MSACC_POP_STATE_X(); @@ -564,5 +564,3 @@ NAME##_free(TYPE *p) \ #undef ERTS_ALC_ATTRIBUTES #endif /* #ifndef ERL_ALLOC_H__ */ - - diff --git a/erts/emulator/beam/erl_alloc_util.c b/erts/emulator/beam/erl_alloc_util.c index 5e7dd7cce8..6e682019ba 100644 --- a/erts/emulator/beam/erl_alloc_util.c +++ b/erts/emulator/beam/erl_alloc_util.c @@ -52,6 +52,7 @@ #ifdef ERTS_ENABLE_LOCK_COUNT #include "erl_lock_count.h" #endif +#include "lttng-wrapper.h" #if defined(ERTS_ALLOC_UTIL_HARD_DEBUG) && defined(__GNUC__) #warning "* * * * * * * * * *" @@ -3125,6 +3126,7 @@ cpool_insert(Allctr_t *allctr, Carrier_t *crr) erts_smp_atomic_set_wb(&crr->allctr, ((erts_aint_t) allctr)|ERTS_CRR_ALCTR_FLG_IN_POOL); + LTTNG3(carrier_pool_put, ERTS_ALC_A2AD(allctr->alloc_no), allctr->ix, CARRIER_SZ(crr)); } static void @@ -3240,6 +3242,7 @@ cpool_fetch(Allctr_t *allctr, UWord size) first_old_traitor = allctr->cpool.traitor_list.next; cpool_entrance = NULL; + LTTNG3(carrier_pool_get, ERTS_ALC_A2AD(allctr->alloc_no), allctr->ix, (unsigned long)size); /* * Search my own pooled_list, * i.e my abandoned carriers that were in the pool last time I checked. @@ -3925,6 +3928,21 @@ create_carrier(Allctr_t *allctr, Uint umem_sz, UWord flags) } +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(carrier_create)) { + lttng_decl_carrier_stats(mbc_stats); + lttng_decl_carrier_stats(sbc_stats); + LTTNG_CARRIER_STATS_TO_LTTNG_STATS(&(allctr->mbcs), mbc_stats); + LTTNG_CARRIER_STATS_TO_LTTNG_STATS(&(allctr->sbcs), sbc_stats); + LTTNG5(carrier_create, + ERTS_ALC_A2AD(allctr->alloc_no), + allctr->ix, + crr_sz, + mbc_stats, + sbc_stats); + } +#endif + DEBUG_SAVE_ALIGNMENT(crr); return blk; } @@ -4148,6 +4166,21 @@ destroy_carrier(Allctr_t *allctr, Block_t *blk, Carrier_t **busy_pcrr_pp) allctr->remove_mbc(allctr, crr); } +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(carrier_destroy)) { + lttng_decl_carrier_stats(mbc_stats); + lttng_decl_carrier_stats(sbc_stats); + LTTNG_CARRIER_STATS_TO_LTTNG_STATS(&(allctr->mbcs), mbc_stats); + LTTNG_CARRIER_STATS_TO_LTTNG_STATS(&(allctr->sbcs), sbc_stats); + LTTNG5(carrier_destroy, + ERTS_ALC_A2AD(allctr->alloc_no), + allctr->ix, + crr_sz, + mbc_stats, + sbc_stats); + } +#endif + #ifdef ERTS_SMP schedule_dealloc_carrier(allctr, crr); #else diff --git a/erts/emulator/beam/erl_alloc_util.h b/erts/emulator/beam/erl_alloc_util.h index b7d717ed23..afdff1a71e 100644 --- a/erts/emulator/beam/erl_alloc_util.h +++ b/erts/emulator/beam/erl_alloc_util.h @@ -30,6 +30,7 @@ #endif #include "erl_mseg.h" +#include "lttng-wrapper.h" #define ERTS_AU_PREF_ALLOC_BITS 11 #define ERTS_AU_MAX_PREF_ALLOC_INSTANCES (1 << ERTS_AU_PREF_ALLOC_BITS) @@ -417,6 +418,18 @@ typedef struct { } blocks; } CarriersStats_t; +#ifdef USE_LTTNG_VM_TRACEPOINTS +#define LTTNG_CARRIER_STATS_TO_LTTNG_STATS(CSP, LSP) \ + do { \ + (LSP)->carriers.size = (CSP)->curr.norm.mseg.size \ + + (CSP)->curr.norm.sys_alloc.size; \ + (LSP)->carriers.no = (CSP)->curr.norm.mseg.no \ + + (CSP)->curr.norm.sys_alloc.no; \ + (LSP)->blocks.size = (CSP)->blocks.curr.size; \ + (LSP)->blocks.no = (CSP)->blocks.curr.no; \ + } while (0) +#endif + #ifdef ERTS_SMP typedef union ErtsAllctrDDBlock_t_ ErtsAllctrDDBlock_t; diff --git a/erts/emulator/beam/erl_async.c b/erts/emulator/beam/erl_async.c index cdeeb5281b..69240f7886 100644 --- a/erts/emulator/beam/erl_async.c +++ b/erts/emulator/beam/erl_async.c @@ -28,6 +28,7 @@ #include "erl_thr_queue.h" #include "erl_async.h" #include "dtrace-wrapper.h" +#include "lttng-wrapper.h" #define ERTS_MAX_ASYNC_READY_CALLS_IN_SEQ 20 @@ -281,6 +282,13 @@ static ERTS_INLINE void async_add(ErtsAsync *a, ErtsAsyncQ* q) #endif erts_thr_q_enqueue(&q->thr_q, a); +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(aio_pool_add)) { + lttng_decl_portbuf(port_str); + lttng_portid_to_str(a->port, port_str); + LTTNG2(aio_pool_add, port_str, -1); + } +#endif #ifdef USE_VM_PROBES if (DTRACE_ENABLED(aio_pool_add)) { DTRACE_CHARBUF(port_str, 16); @@ -317,6 +325,14 @@ static ERTS_INLINE ErtsAsync *async_get(ErtsThrQ_t *q, if (saved_fin_deq) erts_thr_q_append_finalize_dequeue_data(&a->q.fin_deq, &fin_deq); #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(aio_pool_get)) { + lttng_decl_portbuf(port_str); + int length = erts_thr_q_length_dirty(q); + lttng_portid_to_str(a->port, port_str); + LTTNG2(aio_pool_get, port_str, length); + } +#endif #ifdef USE_VM_PROBES if (DTRACE_ENABLED(aio_pool_get)) { DTRACE_CHARBUF(port_str, 16); diff --git a/erts/emulator/beam/erl_bif_ddll.c b/erts/emulator/beam/erl_bif_ddll.c index f006856b6a..b526eda41d 100644 --- a/erts/emulator/beam/erl_bif_ddll.c +++ b/erts/emulator/beam/erl_bif_ddll.c @@ -48,6 +48,7 @@ #include "erl_version.h" #include "erl_bif_unique.h" #include "dtrace-wrapper.h" +#include "lttng-wrapper.h" #ifdef ERTS_SMP #define DDLL_SMP 1 @@ -1619,6 +1620,7 @@ static int do_unload_driver_entry(DE_Handle *dh, Eterm *save_name) if (q->finish) { int fpe_was_unmasked = erts_block_fpe(); DTRACE1(driver_finish, q->name); + LTTNG1(driver_finish, q->name); (*(q->finish))(); erts_unblock_fpe(fpe_was_unmasked); } diff --git a/erts/emulator/beam/erl_bif_info.c b/erts/emulator/beam/erl_bif_info.c index d35bbb80b8..0b2c26a548 100644 --- a/erts/emulator/beam/erl_bif_info.c +++ b/erts/emulator/beam/erl_bif_info.c @@ -126,6 +126,9 @@ static char erts_system_version[] = ("Erlang/OTP " ERLANG_OTP_RELEASE #ifdef ERTS_FRMPTR " [frame-pointer]" #endif +#ifdef USE_LTTNG + " [lttng]" +#endif #ifdef USE_DTRACE " [dtrace]" #endif @@ -2748,6 +2751,9 @@ BIF_RETTYPE system_info_1(BIF_ALIST_1) #elif defined(USE_SYSTEMTAP) DECL_AM(systemtap); BIF_RET(AM_systemtap); +#elif defined(USE_LTTNG) + DECL_AM(lttng); + BIF_RET(AM_lttng); #else BIF_RET(am_none); #endif diff --git a/erts/emulator/beam/erl_message.c b/erts/emulator/beam/erl_message.c index 88efb2c59f..bc0a55068b 100644 --- a/erts/emulator/beam/erl_message.c +++ b/erts/emulator/beam/erl_message.c @@ -766,17 +766,7 @@ erts_send_message(Process* sender, utag = DT_UTAG(sender); else utag = copy_struct(DT_UTAG(sender), dt_utag_size, &hp, ohp); -#ifdef DTRACE_TAG_HARDDEBUG - erts_fprintf(stderr, - "Dtrace -> (%T) Spreading tag (%T) with " - "message %T!\r\n",sender->common.id, utag, message); -#endif } -#endif - BM_MESSAGE_COPIED(msize); - BM_SWAP_TIMER(copy,send); - -#ifdef USE_VM_PROBES if (DTRACE_ENABLED(message_send)) { if (have_seqtrace(stoken)) { tok_label = signed_val(SEQ_TRACE_T_LABEL(stoken)); @@ -787,6 +777,9 @@ erts_send_message(Process* sender, msize, tok_label, tok_lastcnt, tok_serial); } #endif + BM_MESSAGE_COPIED(msize); + BM_SWAP_TIMER(copy,send); + } else { Eterm *hp; @@ -822,8 +815,10 @@ erts_send_message(Process* sender, BM_MESSAGE_COPIED(msz); BM_SWAP_TIMER(copy,send); } +#ifdef USE_VM_PROBES DTRACE6(message_send, sender_name, receiver_name, msize, tok_label, tok_lastcnt, tok_serial); +#endif } res = queue_message(sender, diff --git a/erts/emulator/beam/erl_port_task.c b/erts/emulator/beam/erl_port_task.c index b200344af5..ec07d145ab 100644 --- a/erts/emulator/beam/erl_port_task.c +++ b/erts/emulator/beam/erl_port_task.c @@ -35,6 +35,7 @@ #include "dist.h" #include "erl_check_io.h" #include "dtrace-wrapper.h" +#include "lttng-wrapper.h" #include <stdarg.h> /* @@ -69,6 +70,18 @@ static void chk_task_queues(Port *pp, ErtsPortTask *execq, int processing_busy_q #else #define DTRACE_DRIVER(PROBE_NAME, PP) do {} while(0) #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS +#define LTTNG_DRIVER(TRACEPOINT, PP) \ + if (LTTNG_ENABLED(TRACEPOINT)) { \ + lttng_decl_portbuf(port_str); \ + lttng_decl_procbuf(proc_str); \ + lttng_pid_to_str(ERTS_PORT_GET_CONNECTED(PP), proc_str); \ + lttng_port_to_str((PP), port_str); \ + LTTNG3(TRACEPOINT, proc_str, port_str, (PP)->name); \ + } +#else +#define LTTNG_DRIVER(TRACEPOINT, PP) do {} while(0) +#endif #define ERTS_SMP_LC_VERIFY_RQ(RQ, PP) \ do { \ @@ -1752,6 +1765,7 @@ erts_port_task_execute(ErtsRunQueue *runq, Port **curr_port_pp) reds = ERTS_PORT_REDS_TIMEOUT; if (!(state & ERTS_PORT_SFLGS_DEAD)) { DTRACE_DRIVER(driver_timeout, pp); + LTTNG_DRIVER(driver_timeout, pp); (*pp->drv_ptr->timeout)((ErlDrvData) pp->drv_data); } } @@ -1760,6 +1774,7 @@ erts_port_task_execute(ErtsRunQueue *runq, Port **curr_port_pp) reds = ERTS_PORT_REDS_INPUT; ASSERT((state & ERTS_PORT_SFLGS_DEAD) == 0); DTRACE_DRIVER(driver_ready_input, pp); + LTTNG_DRIVER(driver_ready_input, pp); /* NOTE some windows drivers use ->ready_input for input and output */ (*pp->drv_ptr->ready_input)((ErlDrvData) pp->drv_data, @@ -1771,6 +1786,7 @@ erts_port_task_execute(ErtsRunQueue *runq, Port **curr_port_pp) reds = ERTS_PORT_REDS_OUTPUT; ASSERT((state & ERTS_PORT_SFLGS_DEAD) == 0); DTRACE_DRIVER(driver_ready_output, pp); + LTTNG_DRIVER(driver_ready_output, pp); (*pp->drv_ptr->ready_output)((ErlDrvData) pp->drv_data, ptp->u.alive.td.io.event); reset_executed_io_task_handle(ptp); @@ -1780,6 +1796,7 @@ erts_port_task_execute(ErtsRunQueue *runq, Port **curr_port_pp) reds = ERTS_PORT_REDS_EVENT; ASSERT((state & ERTS_PORT_SFLGS_DEAD) == 0); DTRACE_DRIVER(driver_event, pp); + LTTNG_DRIVER(driver_event, pp); (*pp->drv_ptr->event)((ErlDrvData) pp->drv_data, ptp->u.alive.td.io.event, ptp->u.alive.td.io.event_data); diff --git a/erts/emulator/beam/erl_process.c b/erts/emulator/beam/erl_process.c index 794af60b2f..57a7b0f288 100644 --- a/erts/emulator/beam/erl_process.c +++ b/erts/emulator/beam/erl_process.c @@ -43,6 +43,7 @@ #include "erl_thr_queue.h" #include "erl_async.h" #include "dtrace-wrapper.h" +#include "lttng-wrapper.h" #include "erl_ptab.h" #include "erl_bif_unique.h" #define ERTS_WANT_TIMER_WHEEL_API @@ -3217,6 +3218,7 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq) ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_CHECK_IO); ASSERT(!erts_port_task_have_outstanding_io_tasks()); + LTTNG2(scheduler_poll, esdp->no, 1); erl_sys_schedule(1); /* Might give us something to do */ ERTS_MSACC_POP_STATE_M(); @@ -3340,6 +3342,7 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq) ASSERT(!erts_port_task_have_outstanding_io_tasks()); ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_CHECK_IO); + LTTNG2(scheduler_poll, esdp->no, 0); erl_sys_schedule(0); @@ -9558,7 +9561,10 @@ Process *schedule(Process *p, int calls) erts_sys_schedule_interrupt(0); #endif erts_smp_runq_unlock(rq); - ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_CHECK_IO); + + ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_CHECK_IO); + LTTNG2(scheduler_poll, esdp->no, 1); + erl_sys_schedule(1); ERTS_MSACC_POP_STATE_M(); diff --git a/erts/emulator/beam/erl_thr_queue.c b/erts/emulator/beam/erl_thr_queue.c index 7ff456b915..30c9d70c59 100644 --- a/erts/emulator/beam/erl_thr_queue.c +++ b/erts/emulator/beam/erl_thr_queue.c @@ -780,3 +780,35 @@ erts_thr_q_dequeue(ErtsThrQ_t *q) return res; #endif } + +#ifdef USE_LTTNG_VM_TRACEPOINTS +int +erts_thr_q_length_dirty(ErtsThrQ_t *q) +{ + int n = 0; +#ifndef USE_THREADS + void *res; + ErtsThrQElement_t *tmp; + + for (tmp = q->first; tmp != NULL; tmp = tmp->next) { + n++; + } +#else + ErtsThrQElement_t *e; + erts_aint_t inext; + + e = ErtsThrQDirtyReadEl(&q->head.head); + inext = erts_atomic_read_acqb(&e->next); + + while (inext != ERTS_AINT_NULL) { + e = (ErtsThrQElement_t *) inext; + if (e != &q->tail.data.marker) { + /* don't count marker */ + n++; + } + inext = erts_atomic_read_acqb(&e->next); + } +#endif + return n; +} +#endif diff --git a/erts/emulator/beam/erl_thr_queue.h b/erts/emulator/beam/erl_thr_queue.h index 27a6d03224..f5e5522948 100644 --- a/erts/emulator/beam/erl_thr_queue.h +++ b/erts/emulator/beam/erl_thr_queue.h @@ -190,6 +190,10 @@ void erts_thr_q_append_finalize_dequeue_data(ErtsThrQFinDeQ_t *, int erts_thr_q_finalize_dequeue(ErtsThrQFinDeQ_t *); void erts_thr_q_finalize_dequeue_state_init(ErtsThrQFinDeQ_t *); +#ifdef USE_LTTNG_VM_TRACEPOINTS +int erts_thr_q_length_dirty(ErtsThrQ_t *); +#endif + #ifdef ERTS_SMP ERTS_GLB_INLINE ErtsThrPrgrVal erts_thr_q_need_thr_progress(ErtsThrQ_t *q); #endif diff --git a/erts/emulator/beam/erlang_lttng.c b/erts/emulator/beam/erlang_lttng.c new file mode 100644 index 0000000000..fce40eedc1 --- /dev/null +++ b/erts/emulator/beam/erlang_lttng.c @@ -0,0 +1,32 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2016. All Rights Reserved. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * %CopyrightEnd% + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#ifdef USE_LTTNG +#define TRACEPOINT_CREATE_PROBES +/* + * The header containing our TRACEPOINT_EVENTs. + */ +#define TRACEPOINT_DEFINE +#include "erlang_lttng.h" +#endif /* USE_LTTNG */ diff --git a/erts/emulator/beam/erlang_lttng.h b/erts/emulator/beam/erlang_lttng.h new file mode 100644 index 0000000000..43ceeda671 --- /dev/null +++ b/erts/emulator/beam/erlang_lttng.h @@ -0,0 +1,424 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2016. All Rights Reserved. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * %CopyrightEnd% + */ + +#ifdef USE_LTTNG +#undef TRACEPOINT_PROVIDER +#define TRACEPOINT_PROVIDER com_ericsson_otp + +#undef TRACEPOINT_INCLUDE +#define TRACEPOINT_INCLUDE "erlang_lttng.h" + +#if !defined(__ERLANG_LTTNG_H__) || defined(TRACEPOINT_HEADER_MULTI_READ) +#define __ERLANG_LTTNG_H__ + +#include <lttng/tracepoint.h> + +/* Schedulers */ + +TRACEPOINT_EVENT( + com_ericsson_otp, + scheduler_poll, + TP_ARGS( + int, id, + int, runnable + ), + TP_FIELDS( + ctf_integer(int, scheduler, id) + ctf_integer(int, runnable, runnable) + ) +) + +#ifndef LTTNG_CARRIER_STATS +#define LTTNG_CARRIER_STATS +typedef struct { + unsigned long no; + unsigned long size; +} lttng_stat_values_t; + +typedef struct { + lttng_stat_values_t carriers; + lttng_stat_values_t blocks; +} lttng_carrier_stats_t; +#endif + + +/* Port and Driver Scheduling */ + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_start, + TP_ARGS( + char*, pid, + char*, driver, + char*, port + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(driver, driver) + ctf_string(port, port) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_init, + TP_ARGS( + char*, driver, + int, major, + int, minor, + int, flags + ), + TP_FIELDS( + ctf_string(driver, driver) + ctf_integer(int, major, major) + ctf_integer(int, minor, minor) + ctf_integer(int, flags, flags) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_outputv, + TP_ARGS( + char*, pid, + char*, port, + char*, driver, + size_t, bytes + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ctf_integer(size_t, bytes, bytes) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_output, + TP_ARGS( + char*, pid, + char*, port, + char*, driver, + size_t, bytes + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ctf_integer(size_t, bytes, bytes) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_ready_input, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_ready_output, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_event, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_timeout, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_stop_select, + TP_ARGS( + char*, driver + ), + TP_FIELDS( + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_flush, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_stop, + TP_ARGS( + char*, pid, + char*, driver, + char*, port + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(driver, driver) + ctf_string(port, port) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_process_exit, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_ready_async, + TP_ARGS( + char*, pid, + char*, port, + char*, driver + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_finish, + TP_ARGS( + char*, driver + ), + TP_FIELDS( + ctf_string(driver, driver) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_call, + TP_ARGS( + char*, pid, + char*, port, + char*, driver, + unsigned int, command, + size_t, bytes + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ctf_integer(unsigned int, command, command) + ctf_integer(size_t, bytes, bytes) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + driver_control, + TP_ARGS( + char*, pid, + char*, port, + char*, driver, + unsigned int, command, + size_t, bytes + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(port, port) + ctf_string(driver, driver) + ctf_integer(unsigned int, command, command) + ctf_integer(size_t, bytes, bytes) + ) +) + +/* Async pool */ + +TRACEPOINT_EVENT( + com_ericsson_otp, + aio_pool_get, + TP_ARGS( + char*, port, + int, length + ), + TP_FIELDS( + ctf_string(port, port) + ctf_integer(int, length, length) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + aio_pool_add, + TP_ARGS( + char*, port, + int, length + ), + TP_FIELDS( + ctf_string(port, port) + ctf_integer(int, length, length) + ) +) + + +/* Memory Allocator */ + +TRACEPOINT_EVENT( + com_ericsson_otp, + carrier_create, + TP_ARGS( + const char*, type, + int, instance, + unsigned long, size, + lttng_carrier_stats_t *, mbcs, + lttng_carrier_stats_t *, sbcs + ), + TP_FIELDS( + ctf_string(type, type) + ctf_integer(int, instance, instance) + ctf_integer(unsigned long, size, size) + ctf_integer(unsigned long, mbc_carriers, mbcs->carriers.no) + ctf_integer(unsigned long, mbc_carriers_size, mbcs->carriers.size) + ctf_integer(unsigned long, mbc_blocks, mbcs->blocks.no) + ctf_integer(unsigned long, mbc_blocks_size, mbcs->blocks.size) + ctf_integer(unsigned long, sbc_carriers, sbcs->carriers.no) + ctf_integer(unsigned long, sbc_carriers_size, sbcs->carriers.size) + ctf_integer(unsigned long, sbc_blocks, sbcs->blocks.no) + ctf_integer(unsigned long, sbc_blocks_size, sbcs->blocks.size) + ) +) + + +TRACEPOINT_EVENT( + com_ericsson_otp, + carrier_destroy, + TP_ARGS( + const char*, type, + int, instance, + unsigned long, size, + lttng_carrier_stats_t *, mbcs, + lttng_carrier_stats_t *, sbcs + ), + TP_FIELDS( + ctf_string(type, type) + ctf_integer(int, instance, instance) + ctf_integer(unsigned long, size, size) + ctf_integer(unsigned long, mbc_carriers, mbcs->carriers.no) + ctf_integer(unsigned long, mbc_carriers_size, mbcs->carriers.size) + ctf_integer(unsigned long, mbc_blocks, mbcs->blocks.no) + ctf_integer(unsigned long, mbc_blocks_size, mbcs->blocks.size) + ctf_integer(unsigned long, sbc_carriers, sbcs->carriers.no) + ctf_integer(unsigned long, sbc_carriers_size, sbcs->carriers.size) + ctf_integer(unsigned long, sbc_blocks, sbcs->blocks.no) + ctf_integer(unsigned long, sbc_blocks_size, sbcs->blocks.size) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + carrier_pool_put, + TP_ARGS( + const char*, name, + int, instance, + unsigned long, size + ), + TP_FIELDS( + ctf_string(type, name) + ctf_integer(int, instance, instance) + ctf_integer(unsigned long, size, size) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_otp, + carrier_pool_get, + TP_ARGS( + const char*, name, + int, instance, + unsigned long, size + ), + TP_FIELDS( + ctf_string(type, name) + ctf_integer(int, instance, instance) + ctf_integer(unsigned long, size, size) + ) +) + +#endif /* __ERLANG_LTTNG_H__ */ +#include <lttng/tracepoint-event.h> +#endif /* USE_LTTNG */ diff --git a/erts/emulator/beam/io.c b/erts/emulator/beam/io.c index 29f28cc9dc..b85b581cdc 100644 --- a/erts/emulator/beam/io.c +++ b/erts/emulator/beam/io.c @@ -47,6 +47,7 @@ #define ERTS_WANT_EXTERNAL_TAGS #include "external.h" #include "dtrace-wrapper.h" +#include "lttng-wrapper.h" #include "erl_map.h" #include "erl_bif_unique.h" #include "erl_hl_timer.h" @@ -717,7 +718,19 @@ erts_open_driver(erts_driver_t* driver, /* Pointer to driver. */ DTRACE3(driver_start, process_str, driver->name, port_str); } #endif + ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_PORT); + +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_start)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(pid, proc_str); + lttng_port_to_str(port, port_str); + LTTNG3(driver_start, proc_str, driver->name, port_str); + } +#endif + fpe_was_unmasked = erts_block_fpe(); drv_data = (*driver->start)(ERTS_Port2ErlDrvPort(port), name, opts); if (((SWord) drv_data) == -1) @@ -1735,6 +1748,15 @@ call_driver_outputv(int bang_op, DTRACE4(driver_outputv, process_str, port_str, prt->name, size); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_outputv)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(caller, proc_str); + lttng_port_to_str(prt, port_str); + LTTNG4(driver_outputv, proc_str, port_str, prt->name, size); + } +#endif prt->caller = caller; (*drv->outputv)((ErlDrvData) prt->drv_data, evp); @@ -1836,6 +1858,15 @@ call_driver_output(int bang_op, DTRACE4(driver_output, process_str, port_str, prt->name, size); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_output)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(caller, proc_str); + lttng_port_to_str(prt, port_str); + LTTNG4(driver_output, proc_str, port_str, prt->name, size); + } +#endif prt->caller = caller; (*drv->output)((ErlDrvData) prt->drv_data, bufp, size); @@ -2141,7 +2172,6 @@ erts_port_output(Process *c_p, DTRACE4(port_command, process_str, port_str, prt->name, "command"); } #endif - if (drv->outputv) { ErlIOVec ev; SysIOVec iv[SMALL_WRITE_VEC]; @@ -3697,6 +3727,17 @@ static void flush_port(Port *p) DTRACE3(driver_flush, process_str, port_str, p->name); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_flush)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(ERTS_PORT_GET_CONNECTED(p), proc_str); + lttng_port_to_str(p, port_str); + LTTNG3(driver_flush, proc_str, port_str, p->name); + } +#endif + + if (IS_TRACED_FL(p, F_TRACE_SCHED_PORTS)) { trace_sched_ports_where(p, am_in, am_flush); } @@ -3760,6 +3801,16 @@ terminate_port(Port *prt) DTRACE3(driver_stop, process_str, drv->name, port_str); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_stop)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(connected_id, proc_str); + lttng_port_to_str(prt, port_str); + LTTNG3(driver_stop, proc_str, drv->name, port_str); + } +#endif + (*drv->stop)((ErlDrvData)prt->drv_data); erts_unblock_fpe(fpe_was_unmasked); ERTS_MSACC_POP_STATE_M(); @@ -4091,6 +4142,16 @@ call_driver_control(Eterm caller, ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_PORT); +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_control)) { + lttng_decl_procbuf(proc_str); + lttng_decl_portbuf(port_str); + lttng_pid_to_str(caller, proc_str); + lttng_port_to_str(prt, port_str); + LTTNG5(driver_control, proc_str, port_str, prt->name, command, size); + } +#endif + prt->caller = caller; cres = prt->drv_ptr->control((ErlDrvData) prt->drv_data, command, @@ -4504,6 +4565,15 @@ call_driver_call(Eterm caller, DTRACE5(driver_call, process_str, port_str, prt->name, command, size); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_call)) { + lttng_decl_procbuf(proc_str); + lttng_decl_portbuf(port_str); + lttng_pid_to_str(caller,proc_str); + lttng_port_to_str(prt, port_str); + LTTNG5(driver_call, proc_str, port_str, prt->name, command, size); + } +#endif ERTS_MSACC_SET_STATE_CACHED_M(ERTS_MSACC_STATE_PORT); @@ -5266,6 +5336,15 @@ int async_ready(Port *p, void* data) DTRACE3(driver_ready_async, process_str, port_str, p->name); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_ready_async)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(ERTS_PORT_GET_CONNECTED(p), proc_str); + lttng_port_to_str(p, port_str); + LTTNG3(driver_ready_async, proc_str, port_str, p->name); + } +#endif (*p->drv_ptr->ready_async)((ErlDrvData)p->drv_data, data); need_free = 0; ERTS_MSACC_POP_STATE_M(); @@ -7312,6 +7391,15 @@ void erts_fire_port_monitor(Port *prt, Eterm ref) DTRACE3(driver_process_exit, process_str, port_str, prt->name); } #endif +#ifdef USE_LTTNG_VM_TRACEPOINTS + if (LTTNG_ENABLED(driver_process_exit)) { + lttng_decl_portbuf(port_str); + lttng_decl_procbuf(proc_str); + lttng_pid_to_str(ERTS_PORT_GET_CONNECTED(prt), proc_str); + lttng_port_to_str(prt, port_str); + LTTNG3(driver_process_exit, proc_str, port_str, prt->name); + } +#endif fpe_was_unmasked = erts_block_fpe(); (*callback)((ErlDrvData) (prt->drv_data), &drv_monitor); erts_unblock_fpe(fpe_was_unmasked); @@ -7789,6 +7877,8 @@ init_driver(erts_driver_t *drv, ErlDrvEntry *de, DE_Handle *handle) int fpe_was_unmasked = erts_block_fpe(); DTRACE4(driver_init, drv->name, drv->version.major, drv->version.minor, drv->flags); + LTTNG4(driver_init, drv->name, drv->version.major, drv->version.minor, + drv->flags); res = (*de->init)(); erts_unblock_fpe(fpe_was_unmasked); return res; diff --git a/erts/emulator/beam/lttng-wrapper.h b/erts/emulator/beam/lttng-wrapper.h new file mode 100644 index 0000000000..294872c365 --- /dev/null +++ b/erts/emulator/beam/lttng-wrapper.h @@ -0,0 +1,107 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-2016. All Rights Reserved. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * %CopyrightEnd% + */ + +#ifndef __LTTNG_WRAPPER_H__ +#define __LTTNG_WRAPPER_H__ + +#ifdef USE_LTTNG + +#include "erlang_lttng.h" +#define USE_LTTNG_VM_TRACEPOINTS + +#define LTTNG_BUFFER_SZ (256) +#define LTTNG_PROC_BUFFER_SZ (16) +#define LTTNG_PORT_BUFFER_SZ (20) +#define LTTNG_MFA_BUFFER_SZ (256) + +#define lttng_decl_procbuf(Name) \ + char Name[LTTNG_PROC_BUFFER_SZ] + +#define lttng_decl_portbuf(Name) \ + char Name[LTTNG_PORT_BUFFER_SZ] + +#define lttng_decl_mfabuf(Name) \ + char Name[LTTNG_MFA_BUFFER_SZ] + +#define lttng_decl_carrier_stats(Name) \ + lttng_carrier_stats_t Name##_STATSTRUCT, *Name = &Name##_STATSTRUCT + +#define lttng_pid_to_str(pid, name) \ + erts_snprintf(name, LTTNG_PROC_BUFFER_SZ, "%T", (pid)) + +#define lttng_portid_to_str(pid, name) \ + erts_snprintf(name, LTTNG_PORT_BUFFER_SZ, "%T", (pid)) + +#define lttng_proc_to_str(p, name) \ + lttng_pid_to_str(((p) ? (p)->common.id : ERTS_INVALID_PID), name) + +#define lttng_port_to_str(p, name) \ + lttng_portid_to_str(((p) ? (p)->common.id : ERTS_INVALID_PORT), name) + +#define lttng_mfa_to_str(m,f,a, Name) \ + erts_snprintf(Name, LTTNG_MFA_BUFFER_SZ, "%T:%T/%lu", (Eterm)(m), (Eterm)(f), (Uint)(a)) + +#define lttng_proc_to_mfa_str(p, Name) \ + do { \ + if (ERTS_PROC_IS_EXITING((p))) { \ + strcpy(Name, "<exiting>"); \ + } else { \ + BeamInstr *_fptr = find_function_from_pc((p)->i); \ + if (_fptr) { \ + lttng_mfa_to_str(_fptr[0],_fptr[1],_fptr[2], Name); \ + } else { \ + strcpy(Name, "<unknown>"); \ + } \ + } \ + } while(0) + +/* ErtsRunQueue->ErtsSchedulerData->Uint */ +#define lttng_rq_to_id(RQ) \ + (RQ)->scheduler->no + +#define LTTNG_ENABLED(Name) \ + tracepoint_enabled(com_ericsson_otp, Name) + +/* include a special LTTNG_DO for do_tracepoint ? */ +#define LTTNG1(Name, Arg1) \ + tracepoint(com_ericsson_otp, Name, (Arg1)) + +#define LTTNG2(Name, Arg1, Arg2) \ + tracepoint(com_ericsson_otp, Name, (Arg1), (Arg2)) + +#define LTTNG3(Name, Arg1, Arg2, Arg3) \ + tracepoint(com_ericsson_otp, Name, (Arg1), (Arg2), (Arg3)) + +#define LTTNG4(Name, Arg1, Arg2, Arg3, Arg4) \ + tracepoint(com_ericsson_otp, Name, (Arg1), (Arg2), (Arg3), (Arg4)) + +#define LTTNG5(Name, Arg1, Arg2, Arg3, Arg4, Arg5) \ + tracepoint(com_ericsson_otp, Name, (Arg1), (Arg2), (Arg3), (Arg4), (Arg5)) + +#else /* USE_LTTNG */ + +#define LTTNG1(Name, Arg1) do {} while(0) +#define LTTNG2(Name, Arg1, Arg2) do {} while(0) +#define LTTNG3(Name, Arg1, Arg2, Arg3) do {} while(0) +#define LTTNG4(Name, Arg1, Arg2, Arg3, Arg4) do {} while(0) +#define LTTNG5(Name, Arg1, Arg2, Arg3, Arg4, Arg5) do {} while(0) + +#endif /* USE_LTTNG */ +#endif /* __LTTNG_WRAPPER_H__ */ diff --git a/erts/emulator/beam/ops.tab b/erts/emulator/beam/ops.tab index 772460c177..96a3a72bb5 100644 --- a/erts/emulator/beam/ops.tab +++ b/erts/emulator/beam/ops.tab @@ -181,11 +181,6 @@ i_jump_on_val_zero y f I i_jump_on_val x f I I i_jump_on_val y f I I -jump Target | label Lbl | same_label(Target, Lbl) => label Lbl - -is_ne_exact L1 S1 S2 | jump Fail | label L2 | same_label(L1, L2) => \ - is_eq_exact Fail S1 S2 | label L2 - %macro: get_list GetList -pack get_list x x x get_list x x y @@ -256,7 +251,14 @@ case_end x badmatch x if_end -raise s s + +# Operands for raise/2 are almost always in x(2) and x(1). +# Optimize for that case. +raise x==2 x==1 => i_raise +raise Trace=y Value=y => move Trace x=2 | move Value x=1 | i_raise +raise Trace Value => move Trace x=3 | move Value x=1 | move x=3 x=2 | i_raise + +i_raise # Internal now, but could be useful to make known to the compiler. badarg j @@ -1355,9 +1357,7 @@ bs_put_utf8 Fail u Src=s => i_bs_put_utf8 Fail Src i_bs_put_utf8 j s -bs_put_utf16 Fail Flags=u Src=s => i_bs_put_utf16 Fail Flags Src - -i_bs_put_utf16 j I s +bs_put_utf16 j I s bs_put_utf32 Fail=j Flags=u Src=s => \ i_bs_validate_unicode Fail Src | bs_put_integer Fail i=32 u=1 Flags Src @@ -1539,7 +1539,6 @@ gen_minus p Live Reg=d Int=i Dst | negation_is_small(Int) => \ # GCing arithmetic instructions. # -gen_plus Fail Live Y=y X=x Dst => i_plus Fail Live X Y Dst gen_plus Fail Live S1 S2 Dst => i_plus Fail Live S1 S2 Dst gen_minus Fail Live S1 S2 Dst => i_minus Fail Live S1 S2 Dst diff --git a/erts/emulator/drivers/common/efile_drv.c b/erts/emulator/drivers/common/efile_drv.c index 3088dfd572..ee14bd8bba 100644 --- a/erts/emulator/drivers/common/efile_drv.c +++ b/erts/emulator/drivers/common/efile_drv.c @@ -2900,12 +2900,12 @@ file_output(ErlDrvData e, char* buf, ErlDrvSizeT count) d = EF_SAFE_ALLOC(sizeof(struct t_data) - 1 + FILENAME_BYTELEN(buf + 9*4) + FILENAME_CHARSIZE); - d->info.mode = get_int32(buf + 0 * 4); - d->info.uid = get_int32(buf + 1 * 4); - d->info.gid = get_int32(buf + 2 * 4); - d->info.accessTime = (time_t)((Sint64)get_int64(buf + 3 * 4)); - d->info.modifyTime = (time_t)((Sint64)get_int64(buf + 5 * 4)); - d->info.cTime = (time_t)((Sint64)get_int64(buf + 7 * 4)); + d->info.mode = get_int32(buf + 0 * 4); + d->info.uid = get_int32(buf + 1 * 4); + d->info.gid = get_int32(buf + 2 * 4); + d->info.accessTime = get_int64(buf + 3 * 4); + d->info.modifyTime = get_int64(buf + 5 * 4); + d->info.cTime = get_int64(buf + 7 * 4); FILENAME_COPY(d->b, buf + 9*4); #ifdef USE_VM_PROBES diff --git a/erts/emulator/drivers/common/erl_efile.h b/erts/emulator/drivers/common/erl_efile.h index be5a891486..7ffeed6b9d 100644 --- a/erts/emulator/drivers/common/erl_efile.h +++ b/erts/emulator/drivers/common/erl_efile.h @@ -105,9 +105,9 @@ typedef struct _Efile_info { Uint32 inode; /* Inode number. */ Uint32 uid; /* User id of owner. */ Uint32 gid; /* Group id of owner. */ - time_t accessTime; /* Last time the file was accessed. */ - time_t modifyTime; /* Last time the file was modified. */ - time_t cTime; /* Creation time (Windows) or last + Sint64 accessTime; /* Last time the file was accessed. */ + Sint64 modifyTime; /* Last time the file was modified. */ + Sint64 cTime; /* Creation time (Windows) or last * inode change (Unix). */ } Efile_info; diff --git a/erts/emulator/drivers/unix/unix_efile.c b/erts/emulator/drivers/unix/unix_efile.c index ac9b681d03..0861435264 100644 --- a/erts/emulator/drivers/unix/unix_efile.c +++ b/erts/emulator/drivers/unix/unix_efile.c @@ -537,9 +537,9 @@ efile_fileinfo(Efile_error* errInfo, Efile_info* pInfo, else pInfo->type = FT_OTHER; - pInfo->accessTime = statbuf.st_atime; - pInfo->modifyTime = statbuf.st_mtime; - pInfo->cTime = statbuf.st_ctime; + pInfo->accessTime = (Sint64)statbuf.st_atime; + pInfo->modifyTime = (Sint64)statbuf.st_mtime; + pInfo->cTime = (Sint64)statbuf.st_ctime; pInfo->mode = statbuf.st_mode; pInfo->links = statbuf.st_nlink; @@ -578,8 +578,8 @@ efile_write_info(Efile_error *errInfo, Efile_info *pInfo, char *name) } } - tval.actime = pInfo->accessTime; - tval.modtime = pInfo->modifyTime; + tval.actime = (time_t)pInfo->accessTime; + tval.modtime = (time_t)pInfo->modifyTime; return check_error(utime(name, &tval), errInfo); } @@ -638,12 +638,21 @@ efile_writev(Efile_error* errInfo, /* Where to return error codes */ do { w = writev(fd, &iov[cnt], b); } while (w < 0 && errno == EINTR); + if (w < 0 && errno == EINVAL) { + goto single_write; + } } else + single_write: /* Degenerated io vector - use regular write */ #endif { do { - w = write(fd, iov[cnt].iov_base, iov[cnt].iov_len); + size_t iov_len = iov[cnt].iov_len; + size_t limit = 1024*1024*1024; /* 1GB */ + if (iov_len > limit) { + iov_len = limit; + } + w = write(fd, iov[cnt].iov_base, iov_len); } while (w < 0 && errno == EINTR); ASSERT(w <= iov[cnt].iov_len || (w == -1 && errno != EINTR)); diff --git a/erts/emulator/sys/common/erl_check_io.c b/erts/emulator/sys/common/erl_check_io.c index f87196d724..0d5043fa2a 100644 --- a/erts/emulator/sys/common/erl_check_io.c +++ b/erts/emulator/sys/common/erl_check_io.c @@ -39,6 +39,7 @@ #include "erl_check_io.h" #include "erl_thr_progress.h" #include "dtrace-wrapper.h" +#include "lttng-wrapper.h" #define ERTS_WANT_TIMER_WHEEL_API #include "erl_time.h" @@ -395,6 +396,7 @@ forget_removed(struct pollset_info* psi) if (drv_ptr) { int was_unmasked = erts_block_fpe(); DTRACE1(driver_stop_select, drv_ptr->name); + LTTNG1(driver_stop_select, drv_ptr->name); (*drv_ptr->stop_select) ((ErlDrvEvent) fd, NULL); erts_unblock_fpe(was_unmasked); if (drv_ptr->handle) { @@ -1055,6 +1057,7 @@ done_unknown: if (stop_select_fn) { int was_unmasked = erts_block_fpe(); DTRACE1(driver_stop_select, name); + LTTNG1(driver_stop_select, "unknown"); (*stop_select_fn)(e, NULL); erts_unblock_fpe(was_unmasked); } diff --git a/erts/emulator/test/Makefile b/erts/emulator/test/Makefile index 318db4b45e..0f716c11a1 100644 --- a/erts/emulator/test/Makefile +++ b/erts/emulator/test/Makefile @@ -70,6 +70,7 @@ MODULES= \ hash_SUITE \ hibernate_SUITE \ list_bif_SUITE \ + lttng_SUITE \ map_SUITE \ match_spec_SUITE \ module_info_SUITE \ diff --git a/erts/emulator/test/alloc_SUITE.erl b/erts/emulator/test/alloc_SUITE.erl index 1f690c5015..03b020c521 100644 --- a/erts/emulator/test/alloc_SUITE.erl +++ b/erts/emulator/test/alloc_SUITE.erl @@ -55,21 +55,13 @@ end_per_testcase(_Case, Config) when is_list(Config) -> %% %% basic(Cfg) -> drv_case(Cfg). - coalesce(Cfg) -> drv_case(Cfg). - threads(Cfg) -> drv_case(Cfg). - realloc_copy(Cfg) -> drv_case(Cfg). - bucket_index(Cfg) -> drv_case(Cfg). - bucket_mask(Cfg) -> drv_case(Cfg). - rbtree(Cfg) -> drv_case(Cfg). - mseg_clear_cache(Cfg) -> drv_case(Cfg). - cpool(Cfg) -> drv_case(Cfg). migration(Cfg) -> @@ -81,7 +73,7 @@ migration(Cfg) -> end. erts_mmap(Config) when is_list(Config) -> - case test_server:os_type() of + case os:type() of {unix, _} -> [erts_mmap_do(Config, SCO, SCRPM, SCRFSD) || SCO <-[true,false], SCRFSD <-[1234,0], SCRPM <- [true,false]]; @@ -109,25 +101,26 @@ erts_mmap_do(Config, SCO, SCRPM, SCRFSD) -> {ok, Node} = start_node(Config, Opts), Self = self(), Ref = make_ref(), - F = fun () -> - SI = erlang:system_info({allocator,mseg_alloc}), - {erts_mmap,EM} = lists:keyfind(erts_mmap, 1, SI), - {supercarrier,SC} = lists:keyfind(supercarrier, 1, EM), - {sizes,Sizes} = lists:keyfind(sizes, 1, SC), - {free_segs,Segs} = lists:keyfind(free_segs,1,SC), - {total,Total} = lists:keyfind(total,1,Sizes), - Total = SCS*1024*1024, - - {reserved,Reserved} = lists:keyfind(reserved,1,Segs), - true = (Reserved >= SCRFSD), - - case {SCO,lists:keyfind(os,1,EM)} of - {true, false} -> ok; - {false, {os,_}} -> ok - end, - - Self ! {Ref, ok} - end, + F = fun() -> + SI = erlang:system_info({allocator,mseg_alloc}), + {erts_mmap,EM} = lists:keyfind(erts_mmap, 1, SI), + {supercarrier,SC} = lists:keyfind(supercarrier, 1, EM), + {sizes,Sizes} = lists:keyfind(sizes, 1, SC), + {free_segs,Segs} = lists:keyfind(free_segs,1,SC), + {total,Total} = lists:keyfind(total,1,Sizes), + io:format("Expecting total ~w, got ~w~n", [SCS*1024*1024,Total]), + Total = SCS*1024*1024, + + {reserved,Reserved} = lists:keyfind(reserved,1,Segs), + true = (Reserved >= SCRFSD), + + case {SCO,lists:keyfind(os,1,EM)} of + {true, false} -> ok; + {false, {os,_}} -> ok + end, + + Self ! {Ref, ok} + end, spawn_link(Node, F), Result = receive {Ref, Rslt} -> Rslt end, @@ -144,7 +137,7 @@ drv_case(Config) -> drv_case(Config, one_shot, ""). drv_case(Config, Mode, NodeOpts) when is_list(Config) -> - case test_server:os_type() of + case os:type() of {Family, _} when Family == unix; Family == win32 -> {ok, Node} = start_node(Config, NodeOpts), Self = self(), diff --git a/erts/emulator/test/distribution_SUITE.erl b/erts/emulator/test/distribution_SUITE.erl index f116ec979b..b068a4c8d2 100644 --- a/erts/emulator/test/distribution_SUITE.erl +++ b/erts/emulator/test/distribution_SUITE.erl @@ -1034,6 +1034,7 @@ atom_roundtrip(Config) when is_list(Config) -> atom_roundtrip_r15b(Config) when is_list(Config) -> case test_server:is_release_available("r15b") of true -> + ct:timetrap({minutes, 6}), AtomData = atom_data(), verify_atom_data(AtomData), {ok, Node} = start_node(Config, [], "r15b"), diff --git a/erts/emulator/test/erl_drv_thread_SUITE.erl b/erts/emulator/test/erl_drv_thread_SUITE.erl index 41a761229c..294d9ee05f 100644 --- a/erts/emulator/test/erl_drv_thread_SUITE.erl +++ b/erts/emulator/test/erl_drv_thread_SUITE.erl @@ -65,7 +65,7 @@ drv_case(Config, CaseName, Command, TimeTrap) when is_list(Config), is_atom(CaseName), is_list(Command), is_integer(TimeTrap) -> - case test_server:os_type() of + case os:type() of {Family, _} when Family == unix; Family == win32 -> run_drv_case(Config, CaseName, Command, TimeTrap); SkipOs -> diff --git a/erts/emulator/test/ignore_cores.erl b/erts/emulator/test/ignore_cores.erl index 7373303a39..da6f6850c6 100644 --- a/erts/emulator/test/ignore_cores.erl +++ b/erts/emulator/test/ignore_cores.erl @@ -94,7 +94,7 @@ setup(Suite, Testcase, Config, SetCwd) when is_atom(Suite), end, ok = file:write_file(filename:join([IgnDir, "ignore_core_files"]), <<>>), %% cores are dumped in /cores on MacOS X - CoresDir = case {test_server:os_type(), filelib:is_dir("/cores")} of + CoresDir = case {os:type(), filelib:is_dir("/cores")} of {{unix,darwin}, true} -> filelib:fold_files("/cores", "^core.*$", diff --git a/erts/emulator/test/lttng_SUITE.erl b/erts/emulator/test/lttng_SUITE.erl new file mode 100644 index 0000000000..d0f6292d5b --- /dev/null +++ b/erts/emulator/test/lttng_SUITE.erl @@ -0,0 +1,499 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-2011. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(lttng_SUITE). + +-export([all/0, suite/0]). +-export([init_per_suite/1, end_per_suite/1]). +-export([init_per_testcase/2, end_per_testcase/2]). + +-export([t_lttng_list/1, + t_carrier_pool/1, + t_memory_carrier/1, + t_async_io_pool/1, + t_driver_control_ready_async/1, + t_driver_start_stop/1, + t_driver_ready_input_output/1, + t_driver_timeout/1, + t_driver_caller/1, + t_driver_flush/1, + t_scheduler_poll/1]). + +-include_lib("common_test/include/ct.hrl"). + +suite() -> + [{ct_hooks,[ts_install_cth]}, + {timetrap, {seconds, 10}}]. + +all() -> + [t_lttng_list, + t_carrier_pool, + t_async_io_pool, + t_driver_start_stop, + t_driver_ready_input_output, + t_driver_control_ready_async, + t_driver_timeout, + t_driver_caller, + t_driver_flush, + t_scheduler_poll, + t_memory_carrier]. + + +init_per_suite(Config) -> + case erlang:system_info(dynamic_trace) of + lttng -> + ensure_lttng_stopped("--all"), + Config; + _ -> + {skip, "No LTTng configured on system."} + end. + +end_per_suite(_Config) -> + ensure_lttng_stopped("--all"), + ok. + +init_per_testcase(Case, Config) -> + Name = atom_to_list(Case), + ok = ensure_lttng_started(Name, Config), + [{session, Name}|Config]. + +end_per_testcase(Case, _Config) -> + Name = atom_to_list(Case), + ok = ensure_lttng_stopped(Name), + ok. + +%% Not tested yet +%% com_ericsson_otp:driver_process_exit +%% com_ericsson_otp:driver_event + +%% tracepoints +%% +%% com_ericsson_otp:carrier_pool_get +%% com_ericsson_otp:carrier_pool_put +%% com_ericsson_otp:carrier_destroy +%% com_ericsson_otp:carrier_create +%% com_ericsson_otp:aio_pool_add +%% com_ericsson_otp:aio_pool_get +%% com_ericsson_otp:driver_control +%% com_ericsson_otp:driver_call +%% com_ericsson_otp:driver_finish +%% com_ericsson_otp:driver_ready_async +%% com_ericsson_otp:driver_process_exit +%% com_ericsson_otp:driver_stop +%% com_ericsson_otp:driver_flush +%% com_ericsson_otp:driver_stop_select +%% com_ericsson_otp:driver_timeout +%% com_ericsson_otp:driver_event +%% com_ericsson_otp:driver_ready_output +%% com_ericsson_otp:driver_ready_input +%% com_ericsson_otp:driver_output +%% com_ericsson_otp:driver_outputv +%% com_ericsson_otp:driver_init +%% com_ericsson_otp:driver_start +%% com_ericsson_otp:scheduler_poll + +%% +%% Testcases +%% + +t_lttng_list(_Config) -> + {ok, _} = cmd("lttng list -u"), + ok. + +%% com_ericsson_otp:carrier_pool_get +%% com_ericsson_otp:carrier_pool_put +t_carrier_pool(Config) -> + case have_carriers() of + false -> + {skip, "No Memory Carriers configured on system."}; + true -> + ok = lttng_start_event("com_ericsson_otp:carrier_pool*", Config), + + ok = ets_load(), + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:carrier_pool_get", Res), + ok = check_tracepoint("com_ericsson_otp:carrier_pool_put", Res), + ok + end. + +%% com_ericsson_otp:carrier_destroy +%% com_ericsson_otp:carrier_create +t_memory_carrier(Config) -> + case have_carriers() of + false -> + {skip, "No Memory Carriers configured on system."}; + true -> + ok = lttng_start_event("com_ericsson_otp:carrier_*", Config), + + ok = ets_load(), + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:carrier_destroy", Res), + ok = check_tracepoint("com_ericsson_otp:carrier_create", Res), + ok + end. + +%% com_ericsson_otp:aio_pool_add +%% com_ericsson_otp:aio_pool_get +t_async_io_pool(Config) -> + case have_async_threads() of + false -> + {skip, "No Async Threads configured on system."}; + true -> + ok = lttng_start_event("com_ericsson_otp:aio_pool_*", Config), + + Path1 = proplists:get_value(priv_dir, Config), + {ok, [[Path2]]} = init:get_argument(home), + {ok, _} = file:list_dir(Path1), + {ok, _} = file:list_dir(Path2), + {ok, _} = file:list_dir(Path1), + {ok, _} = file:list_dir(Path2), + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:aio_pool_add", Res), + ok = check_tracepoint("com_ericsson_otp:aio_pool_get", Res), + ok + end. + + +%% com_ericsson_otp:driver_start +%% com_ericsson_otp:driver_stop +t_driver_start_stop(Config) -> + ok = lttng_start_event("com_ericsson_otp:driver_*", Config), + Path = proplists:get_value(priv_dir, Config), + Name = filename:join(Path, "sometext.txt"), + Bin = txt(), + ok = file:write_file(Name, Bin), + {ok, Bin} = file:read_file(Name), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:driver_start", Res), + ok = check_tracepoint("com_ericsson_otp:driver_stop", Res), + ok = check_tracepoint("com_ericsson_otp:driver_control", Res), + ok = check_tracepoint("com_ericsson_otp:driver_outputv", Res), + ok = check_tracepoint("com_ericsson_otp:driver_ready_async", Res), + ok. + +%% com_ericsson_otp:driver_control +%% com_ericsson_otp:driver_outputv +%% com_ericsson_otp:driver_ready_async +t_driver_control_ready_async(Config) -> + ok = lttng_start_event("com_ericsson_otp:driver_control", Config), + ok = lttng_start_event("com_ericsson_otp:driver_outputv", Config), + ok = lttng_start_event("com_ericsson_otp:driver_ready_async", Config), + Path = proplists:get_value(priv_dir, Config), + Name = filename:join(Path, "sometext.txt"), + Bin = txt(), + ok = file:write_file(Name, Bin), + {ok, Bin} = file:read_file(Name), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:driver_control", Res), + ok = check_tracepoint("com_ericsson_otp:driver_outputv", Res), + ok = check_tracepoint("com_ericsson_otp:driver_ready_async", Res), + ok. + +%% com_ericsson_otp:driver_ready_input +%% com_ericsson_otp:driver_ready_output +t_driver_ready_input_output(Config) -> + ok = lttng_start_event("com_ericsson_otp:driver_ready_*", Config), + Me = self(), + Pid = spawn_link(fun() -> tcp_server(Me, active) end), + receive {Pid, accept} -> ok end, + Bin = txt(), + Sz = byte_size(Bin), + + {ok, Sock} = gen_tcp:connect("localhost", 5679, [binary, {packet, 2}]), + ok = gen_tcp:send(Sock, <<Sz:16, Bin/binary>>), + ok = gen_tcp:send(Sock, <<Sz:16, Bin/binary>>), + ok = gen_tcp:close(Sock), + receive {Pid, done} -> ok end, + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:driver_ready_input", Res), + ok = check_tracepoint("com_ericsson_otp:driver_ready_output", Res), + ok. + + +%% com_ericsson_otp:driver_stop_select +%% com_ericsson_otp:driver_timeout +t_driver_timeout(Config) -> + ok = lttng_start_event("com_ericsson_otp:driver_*", Config), + Me = self(), + Pid = spawn_link(fun() -> tcp_server(Me, timeout) end), + receive {Pid, accept} -> ok end, + {ok, Sock} = gen_tcp:connect("localhost", 5679, [binary]), + ok = gen_tcp:send(Sock, <<"hej">>), + receive {Pid, done} -> ok end, + ok = gen_tcp:close(Sock), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:driver_timeout", Res), + ok = check_tracepoint("com_ericsson_otp:driver_stop_select", Res), + ok. + +%% com_ericsson_otp:driver_call +%% com_ericsson_otp:driver_output +%% com_ericsson_otp:driver_init +%% com_ericsson_otp:driver_finish +t_driver_caller(Config) -> + ok = lttng_start_event("com_ericsson_otp:driver_*", Config), + + Drv = 'caller_drv', + os:putenv("CALLER_DRV_USE_OUTPUTV", "false"), + + ok = load_driver(proplists:get_value(data_dir, Config), Drv), + Port = open_port({spawn, Drv}, []), + true = is_port(Port), + + chk_caller(Port, start, self()), + chk_caller(Port, output, spawn_link(fun() -> + port_command(Port, "") + end)), + Port ! {self(), {command, ""}}, + chk_caller(Port, output, self()), + chk_caller(Port, control, spawn_link(fun () -> + port_control(Port, 0, "") + end)), + chk_caller(Port, call, spawn_link(fun() -> + erlang:port_call(Port, 0, "") + end)), + + true = port_close(Port), + erl_ddll:unload_driver(Drv), + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:driver_call", Res), + ok = check_tracepoint("com_ericsson_otp:driver_output", Res), + ok = check_tracepoint("com_ericsson_otp:driver_init", Res), + ok = check_tracepoint("com_ericsson_otp:driver_finish", Res), + ok. + +%% com_ericsson_otp:scheduler_poll +t_scheduler_poll(Config) -> + ok = lttng_start_event("com_ericsson_otp:scheduler_poll", Config), + + ok = memory_load(), + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:scheduler_poll", Res), + ok. + +%% com_ericsson_otp:driver_flush +t_driver_flush(Config) -> + ok = lttng_start_event("com_ericsson_otp:driver_flush", Config), + + Me = self(), + Pid = spawn_link(fun() -> tcp_server(Me, passive_no_read) end), + receive {Pid, accept} -> ok end, + Bin = iolist_to_binary([txt() || _ <- lists:seq(1,100)]), + Sz = byte_size(Bin), + + %% We want to create a scenario where sendings stalls and we + %% queue packets in the driver. + %% When we close the socket it has to flush the queue. + {ok, Sock} = gen_tcp:connect("localhost", 5679, [binary, {packet, 2}, + {send_timeout, 10}, + {sndbuf, 10000000}]), + Pids = [spawn_link(fun() -> + gen_tcp:send(Sock, <<Sz:16, Bin/binary>>), + Me ! {self(), ok} + end) || _ <- lists:seq(1,100)], + [receive {P, ok} -> ok end || P <- Pids], + ok = gen_tcp:close(Sock), + Pid ! die, + receive {Pid, done} -> ok end, + + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_otp:driver_flush", Res), + ok. + +%% +%% AUX +%% + +chk_caller(Port, Callback, ExpectedCaller) -> + receive + {caller, Port, Callback, Caller} -> + ExpectedCaller = Caller + end. + + +ets_load() -> + Tid = ets:new(ets_load, [public,set]), + N = erlang:system_info(schedulers_online), + Pids = [spawn_link(fun() -> ets_shuffle(Tid) end) || _ <- lists:seq(1,N)], + ok = ets_kill(Pids, 500), + ok. + + +ets_kill([], _) -> ok; +ets_kill([Pid|Pids], Time) -> + timer:sleep(Time), + Pid ! done, + ets_kill(Pids, Time). + +ets_shuffle(Tid) -> + Payload = lists:duplicate(100, $x), + ets_shuffle(Tid, 100, Payload). +ets_shuffle(Tid, I, Data) -> + ets_shuffle(Tid, I, I, Data, Data). + +ets_shuffle(Tid, 0, N, _, Data) -> + ets_shuffle(Tid, N, N, Data, Data); +ets_shuffle(Tid, I, N, Data, Data0) -> + receive + done -> ok + after 0 -> + Key = rand:uniform(1000), + Data1 = [I|Data], + ets:insert(Tid, {Key, Data1}), + ets_shuffle(Tid, I - 1, N, Data1, Data0) + end. + + + + +memory_load() -> + Me = self(), + Pids0 = [spawn_link(fun() -> memory_loop(Me, 20, <<42>>) end) || _ <- lists:seq(1,30)], + timer:sleep(50), + Pids1 = [spawn_link(fun() -> memory_loop(Me, 20, <<42>>) end) || _ <- lists:seq(1,30)], + [receive {Pid, done} -> ok end || Pid <- Pids0 ++ Pids1], + timer:sleep(500), + ok. + +memory_loop(Parent, N, Bin) -> + memory_loop(Parent, N, Bin, []). + +memory_loop(Parent, 0, _Bin, _) -> + Parent ! {self(), done}; +memory_loop(Parent, N, Bin0, Ls) -> + Bin = binary:copy(<<Bin0/binary, Bin0/binary>>), + memory_loop(Parent, N - 1, Bin, [a,b,c|Ls]). + +tcp_server(Pid, Type) -> + {ok, LSock} = gen_tcp:listen(5679, [binary, + {reuseaddr, true}, + {active, false}]), + Pid ! {self(), accept}, + {ok, Sock} = gen_tcp:accept(LSock), + case Type of + passive_no_read -> + receive die -> ok end; + active -> + inet:setopts(Sock, [{active, once}, {packet,2}]), + receive Msg1 -> io:format("msg1: ~p~n", [Msg1]) end, + inet:setopts(Sock, [{active, once}, {packet,2}]), + receive Msg2 -> io:format("msg2: ~p~n", [Msg2]) end, + ok = gen_tcp:close(Sock); + timeout -> + Res = gen_tcp:recv(Sock, 2000, 1000), + io:format("res ~p~n", [Res]) + end, + Pid ! {self(), done}, + ok. + +txt() -> + <<"%% tracepoints\n" + "%%\n" + "%% com_ericsson_otp:carrier_pool_get\n" + "%% com_ericsson_otp:carrier_pool_put\n" + "%% com_ericsson_otp:carrier_destroy\n" + "%% com_ericsson_otp:carrier_create\n" + "%% com_ericsson_otp:aio_pool_add\n" + "%% com_ericsson_otp:aio_pool_get\n" + "%% com_ericsson_otp:driver_control\n" + "%% com_ericsson_otp:driver_call\n" + "%% com_ericsson_otp:driver_finish\n" + "%% com_ericsson_otp:driver_ready_async\n" + "%% com_ericsson_otp:driver_process_exit\n" + "%% com_ericsson_otp:driver_stop\n" + "%% com_ericsson_otp:driver_flush\n" + "%% com_ericsson_otp:driver_stop_select\n" + "%% com_ericsson_otp:driver_timeout\n" + "%% com_ericsson_otp:driver_event\n" + "%% com_ericsson_otp:driver_ready_output\n" + "%% com_ericsson_otp:driver_ready_input\n" + "%% com_ericsson_otp:driver_output\n" + "%% com_ericsson_otp:driver_outputv\n" + "%% com_ericsson_otp:driver_init\n" + "%% com_ericsson_otp:driver_start\n" + "%% com_ericsson_otp:scheduler_poll">>. + +load_driver(Dir, Driver) -> + case erl_ddll:load_driver(Dir, Driver) of + ok -> ok; + {error, Error} = Res -> + io:format("~s\n", [erl_ddll:format_error(Error)]), + Res + end. + +%% check + +have_carriers() -> + Cap = element(3,erlang:system_info(allocator)), + case Cap -- [sys_alloc,sys_aligned_alloc] of + [] -> false; + _ -> true + end. + +have_async_threads() -> + Tps = erlang:system_info(thread_pool_size), + if Tps =:= 0 -> false; + true -> true + end. + +%% lttng +lttng_stop_and_view(Config) -> + Path = proplists:get_value(priv_dir, Config), + Name = proplists:get_value(session, Config), + {ok,_} = cmd("lttng stop " ++ Name), + {ok,Res} = cmd("lttng view " ++ Name ++ " --trace-path=" ++ Path), + Res. + +check_tracepoint(TP, Data) -> + case re:run(Data, TP, [global]) of + {match, _} -> ok; + _ -> notfound + end. + +lttng_start_event(Event, Config) -> + Name = proplists:get_value(session, Config), + {ok, _} = cmd("lttng enable-event -u " ++ Event ++ " --session=" ++ Name), + {ok, _} = cmd("lttng start " ++ Name), + ok. + +ensure_lttng_started(Name, Config) -> + Out = case proplists:get_value(priv_dir, Config) of + undefined -> []; + Path -> "--output="++Path++" " + end, + {ok,_} = cmd("lttng create " ++ Out ++ Name), + ok. + +ensure_lttng_stopped(Name) -> + {ok,_} = cmd("lttng stop"), + {ok,_} = cmd("lttng destroy " ++ Name), + ok. + +cmd(Cmd) -> + io:format("<< ~ts~n", [Cmd]), + Res = os:cmd(Cmd), + io:format(">> ~ts~n", [Res]), + {ok,Res}. diff --git a/erts/emulator/test/lttng_SUITE_data/Makefile.src b/erts/emulator/test/lttng_SUITE_data/Makefile.src new file mode 100644 index 0000000000..fe7a1b6ef3 --- /dev/null +++ b/erts/emulator/test/lttng_SUITE_data/Makefile.src @@ -0,0 +1,7 @@ + +MISC_DRVS = caller_drv@dll@ + + +all: $(MISC_DRVS) + +@SHLIB_RULES@ diff --git a/erts/emulator/test/lttng_SUITE_data/caller_drv.c b/erts/emulator/test/lttng_SUITE_data/caller_drv.c new file mode 100644 index 0000000000..86fd0a2995 --- /dev/null +++ b/erts/emulator/test/lttng_SUITE_data/caller_drv.c @@ -0,0 +1,159 @@ +/* ``Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * The Initial Developer of the Original Code is Ericsson Utvecklings AB. + * Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings + * AB. All Rights Reserved.'' + * + * $Id$ + */ + +#include <stdlib.h> +#include <string.h> +#include "erl_driver.h" + +static int init(); +static void stop(ErlDrvData drv_data); +static void finish(); +static void flush(ErlDrvData drv_data); +static ErlDrvData start(ErlDrvPort port, char *command); +static void output(ErlDrvData drv_data, char *buf, ErlDrvSizeT len); +static void outputv(ErlDrvData drv_data, ErlIOVec *ev); +static ErlDrvSSizeT control(ErlDrvData drv_data, + unsigned int command, char *buf, + ErlDrvSizeT len, char **rbuf, ErlDrvSizeT rlen); +static ErlDrvSSizeT call(ErlDrvData drv_data, + unsigned int command, + char *buf, ErlDrvSizeT len, + char **rbuf, ErlDrvSizeT rlen, + unsigned int *flags); + +static ErlDrvEntry caller_drv_entry = { + init, + start, + stop, + output, + NULL /* ready_input */, + NULL /* ready_output */, + "caller_drv", + finish, + NULL /* handle */, + control, + NULL /* timeout */, + outputv, + NULL /* ready_async */, + flush, + call, + NULL /* event */, + ERL_DRV_EXTENDED_MARKER, + ERL_DRV_EXTENDED_MAJOR_VERSION, + ERL_DRV_EXTENDED_MINOR_VERSION, + ERL_DRV_FLAG_USE_PORT_LOCKING, + NULL /* handle2 */, + NULL /* handle_monitor */ +}; + +DRIVER_INIT(caller_drv) +{ + char buf[10]; + size_t bufsz = sizeof(buf); + char *use_outputv; + use_outputv = (erl_drv_getenv("CALLER_DRV_USE_OUTPUTV", buf, &bufsz) == 0 + ? buf + : "false"); + if (strcmp(use_outputv, "true") != 0) + caller_drv_entry.outputv = NULL; + return &caller_drv_entry; +} + +void +send_caller(ErlDrvData drv_data, char *func) +{ + int res; + ErlDrvPort port = (ErlDrvPort) drv_data; + ErlDrvTermData msg[] = { + ERL_DRV_ATOM, driver_mk_atom("caller"), + ERL_DRV_PORT, driver_mk_port(port), + ERL_DRV_ATOM, driver_mk_atom(func), + ERL_DRV_PID, driver_caller(port), + ERL_DRV_TUPLE, (ErlDrvTermData) 4 + }; + res = erl_drv_output_term(driver_mk_port(port), msg, sizeof(msg)/sizeof(ErlDrvTermData)); + if (res <= 0) + driver_failure_atom(port, "erl_drv_output_term failed"); +} + +static int +init() { + return 0; +} + +static void +stop(ErlDrvData drv_data) +{ + +} + +static void +flush(ErlDrvData drv_data) +{ + +} + +static void +finish() +{ + +} + +static ErlDrvData +start(ErlDrvPort port, char *command) +{ + send_caller((ErlDrvData) port, "start"); + return (ErlDrvData) port; +} + +static void +output(ErlDrvData drv_data, char *buf, ErlDrvSizeT len) +{ + send_caller(drv_data, "output"); +} + +static void +outputv(ErlDrvData drv_data, ErlIOVec *ev) +{ + send_caller(drv_data, "outputv"); +} + +static ErlDrvSSizeT +control(ErlDrvData drv_data, + unsigned int command, char *buf, + ErlDrvSizeT len, char **rbuf, ErlDrvSizeT rlen) +{ + send_caller(drv_data, "control"); + return 0; +} + +static ErlDrvSSizeT +call(ErlDrvData drv_data, + unsigned int command, + char *buf, ErlDrvSizeT len, + char **rbuf, ErlDrvSizeT rlen, + unsigned int *flags) +{ + /* echo call */ + if (len > rlen) + *rbuf = driver_alloc(len); + memcpy((void *) *rbuf, (void *) buf, len); + send_caller(drv_data, "call"); + return len; +} diff --git a/erts/emulator/test/multi_load_SUITE.erl b/erts/emulator/test/multi_load_SUITE.erl index 784b239116..e8769ea208 100644 --- a/erts/emulator/test/multi_load_SUITE.erl +++ b/erts/emulator/test/multi_load_SUITE.erl @@ -19,32 +19,16 @@ %% -module(multi_load_SUITE). --export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, - init_per_group/2,end_per_group/2, - many/1,on_load/1,errors/1]). +-export([all/0, suite/0, many/1, on_load/1, errors/1]). -include_lib("common_test/include/ct.hrl"). -suite() -> [{ct_hooks,[ts_install_cth]}]. +suite() -> + [{ct_hooks,[ts_install_cth]}]. all() -> [many,on_load,errors]. -groups() -> - []. - -init_per_suite(Config) -> - Config. - -end_per_suite(_Config) -> - ok. - -init_per_group(_GroupName, Config) -> - Config. - -end_per_group(_GroupName, Config) -> - Config. - many(_Config) -> Ms = make_modules(100, fun many_module/1), @@ -57,7 +41,6 @@ many(_Config) -> io:put_chars("Heavy load\n" "=========="), many_measure(Ms), - ok. many_module(M) -> @@ -81,9 +64,12 @@ many_measure(Ms) -> "Sequential: ~9w µs\n" "Parallel: ~9w µs\n" "Ratio: ~9w\n", - [length(Ms),Us1,Us2,round(Us1/Us2)]), + [length(Ms),Us1,Us2,divide(Us1,Us2)]), ok. +divide(A,B) when B > 0 -> A div B; +divide(_,_) -> inf. + many_load_seq(Ms) -> [erlang:finish_loading([M]) || M <- Ms], ok. @@ -135,7 +121,6 @@ on_load(_Config) -> SingleOnPrep = tl(OnPrep), {on_load,[OnLoadMod]} = erlang:finish_loading(SingleOnPrep), ok = erlang:call_on_load_function(OnLoadMod), - ok. on_load_module(M) -> diff --git a/erts/emulator/test/node_container_SUITE.erl b/erts/emulator/test/node_container_SUITE.erl index 71400142af..662e5423b9 100644 --- a/erts/emulator/test/node_container_SUITE.erl +++ b/erts/emulator/test/node_container_SUITE.erl @@ -28,8 +28,6 @@ -module(node_container_SUITE). -author('[email protected]'). -%-define(line_trace, 1). - -include_lib("common_test/include/ct.hrl"). -export([all/0, suite/0, init_per_suite/1, end_per_suite/1, @@ -56,7 +54,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap, {minutes, 10}}]. + {timetrap, {minutes, 12}}]. all() -> @@ -712,7 +710,7 @@ run_otp_4715(Config) when is_list(Config) -> pid_wrap(Config) when is_list(Config) -> pp_wrap(pid). port_wrap(Config) when is_list(Config) -> - case test_server:os_type() of + case os:type() of {unix, _} -> pp_wrap(port); _ -> @@ -842,11 +840,10 @@ iter_max_procs(Config) when is_list(Config) -> Res = chk_max_proc_line(), Res = chk_max_proc_line(), done = chk_max_proc_line_until(NoMoreTests, Res), - {comment, - io_lib:format("max processes = ~p; " - "process line length = ~p", - [element(2, Res), element(1, Res)])}. - + Cmt = io_lib:format("max processes = ~p; " + "process line length = ~p", + [element(2, Res), element(1, Res)]), + {comment, lists:flatten(Cmt)}. max_proc_line(Root, Parent, N) -> Me = self(), diff --git a/erts/emulator/test/op_SUITE.erl b/erts/emulator/test/op_SUITE.erl index 562cf1c92d..cb683b9cbf 100644 --- a/erts/emulator/test/op_SUITE.erl +++ b/erts/emulator/test/op_SUITE.erl @@ -30,7 +30,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap, {minutes, 3}}]. + {timetrap, {minutes, 5}}]. all() -> [bsl_bsr, logical, t_not, relop_simple, relop, @@ -39,9 +39,16 @@ all() -> %% Test the bsl and bsr operators. bsl_bsr(Config) when is_list(Config) -> Vs = [unvalue(V) || V <- [-16#8000009-2,-1,0,1,2,73,16#8000000,bad,[]]], - Cases = [{Op,X,Y} || Op <- ['bsr','bsl'], X <- Vs, Y <- Vs], - run_test_module(Cases, false), - {comment,integer_to_list(length(Cases)) ++ " cases"}. + %% Try to use less memory by splitting the cases + + Cases1 = [{Op,X,Y} || Op <- ['bsl'], X <- Vs, Y <- Vs], + N1 = length(Cases1), + run_test_module(Cases1, false), + + Cases2 = [{Op,X,Y} || Op <- ['bsr'], X <- Vs, Y <- Vs], + N2 = length(Cases2), + run_test_module(Cases2, false), + {comment,integer_to_list(N1 + N2) ++ " cases"}. %% Test the logical operators and internal BIFs. logical(Config) when is_list(Config) -> diff --git a/erts/emulator/test/port_SUITE.erl b/erts/emulator/test/port_SUITE.erl index 328641f5b9..cfbc664b56 100644 --- a/erts/emulator/test/port_SUITE.erl +++ b/erts/emulator/test/port_SUITE.erl @@ -908,7 +908,7 @@ try_bad_env(Env) -> %% Test that we can handle a very very large environment gracefully. huge_env(Config) when is_list(Config) -> - ct:timetrap({seconds, 30}), + ct:timetrap({minutes, 2}), Vars = case os:type() of {win32,_} -> 500; _ -> @@ -1757,7 +1757,7 @@ otp_6224_loop() -> exit_status_multi_scheduling_block(Config) when is_list(Config) -> Repeat = 3, - case test_server:os_type() of + case os:type() of {unix, _} -> ct:timetrap({minutes, 2*Repeat}), SleepSecs = 6, diff --git a/erts/emulator/test/process_SUITE.erl b/erts/emulator/test/process_SUITE.erl index 5bb216ff79..789fa7cf06 100644 --- a/erts/emulator/test/process_SUITE.erl +++ b/erts/emulator/test/process_SUITE.erl @@ -1003,7 +1003,7 @@ low_prio_test(Config) when is_list(Config) -> process_flag(trap_exit, true), S = spawn_link(?MODULE, prio_server, [0, 0]), PCs = spawn_prio_clients(S, erlang:system_info(schedulers_online)), - timer:sleep(2000), + ct:sleep({seconds,3}), lists:foreach(fun (P) -> exit(P, kill) end, PCs), S ! exit, receive {'EXIT', S, {A, B}} -> check_prio(A, B) end, diff --git a/erts/emulator/test/scheduler_SUITE.erl b/erts/emulator/test/scheduler_SUITE.erl index 64c280b198..0b4b302908 100644 --- a/erts/emulator/test/scheduler_SUITE.erl +++ b/erts/emulator/test/scheduler_SUITE.erl @@ -876,7 +876,7 @@ get_affinity_mask(_Port, _Status, Affinity) -> Affinity. get_affinity_mask() -> - case test_server:os_type() of + case os:type() of {unix, linux} -> case catch open_port({spawn, "taskset -p " ++ os:getpid()}, [exit_status]) of @@ -1733,7 +1733,7 @@ sched_state([], N, DC, DI) -> {N, DC, DI} catch _ : _ -> - ?t:fail({inconsisten_scheduler_state, {N, DC, DI}}) + ct:fail({inconsisten_scheduler_state, {N, DC, DI}}) end; sched_state([{normal, _, _, _} = S | Rest], _S, DC, DI) -> sched_state(Rest, S, DC, DI); diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index f805e7cc64..2e7073a8f0 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -113,7 +113,6 @@ my @if_line; # my $te_max_vars = 0; # Max number of variables ever needed. my %gen_transform; -my %min_window; my %match_engine_ops; # All opcodes for the match engine. my %gen_transform_offset; my @transformations; @@ -382,7 +381,6 @@ while (<>) { $gen_arity{$name} = $arity; $gen_to_spec{"$name/$arity"} = undef; $num_specific{"$name/$arity"} = 0; - $min_window{"$name/$arity"} = 255; $obsolete[$op_num] = defined $obsolete; } else { # Unnumbered generic operation. push(@unnumbered_generic, [$name, $arity]); @@ -440,7 +438,6 @@ $num_file_opcodes = @gen_opname; $gen_arity{$name} = $arity; $gen_to_spec{"$name/$arity"} = undef; $num_specific{"$name/$arity"} = 0; - $min_window{"$name/$arity"} = 255; } } @@ -607,7 +604,7 @@ sub emulator_output { $is_transformed{$name,$arity} or error("instruction $key has no specific instruction"); $spec_op = -1 unless defined $spec_op; - &init_item($name, $arity, $spec_op, $num_specific, $tr, $min_window{$key}); + &init_item($name, $arity, $spec_op, $num_specific, $tr); } } print "};\n"; @@ -1405,8 +1402,7 @@ sub tr_gen { foreach $ref (@g) { my($line, $orig_transform, $from_ref, $to_ref) = @$ref; - my $used_ref = used_vars($from_ref, $to_ref); - my $so_far = tr_gen_from($line, $used_ref, @$from_ref); + my $so_far = tr_gen_from($line, @$from_ref); tr_gen_to($line, $orig_transform, $so_far, @$to_ref); } @@ -1457,58 +1453,14 @@ sub tr_gen { print "};\n\n"; } -sub used_vars { - my($from_ref,$to_ref) = @_; - my %used; - my %seen; - - foreach my $ref (@$from_ref) { - my($name,$arity,@ops) = @$ref; - if ($name =~ /^[.]/) { - foreach my $var (@ops) { - $used{$var} = 1; - } - } else { - # Any variable that is used at least twice on the - # left-hand side is used. (E.g. "move R R".) - foreach my $op (@ops) { - my($var, $type, $type_val) = @$op; - next if $var eq ''; - $used{$var} = 1 if $seen{$var}; - $seen{$var} = 1; - } - } - } - - foreach my $ref (@$to_ref) { - my($name, $arity, @ops) = @$ref; - if ($name =~ /^[.]/) { - foreach my $var (@ops) { - $used{$var} = 1; - } - } else { - foreach my $op (@ops) { - my($var, $type, $type_val) = @$op; - next if $var eq ''; - $used{$var} = 1; - } - } - } - \%used; -} - sub tr_gen_from { - my($line,$used_ref,@tr) = @_; + my($line,@tr) = @_; my(%var) = (); my(%var_type); my($var_num) = 0; my(@code); - my($min_window) = 0; - my(@fix_rest_args); - my(@fix_pred_funcs); my($op, $ref); # Loop variables. my $where = "left side of transformation in line $line: "; - my %var_used = %$used_ref; my $may_fail = 0; my $is_first = 1; @@ -1530,8 +1482,20 @@ sub tr_gen_from { my $var; my(@args); - push(@fix_pred_funcs, scalar(@code)); - push(@code, [$name, @ops]); + foreach $var (@ops) { + error($where, "variable '$var' unbound") + unless defined $var{$var}; + if ($var_type{$var} eq 'scalar') { + push(@args, "var[$var{$var}]"); + } else { + push(@args, "rest_args"); + } + } + my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args); + my $op = make_op("$name()", 'pred', $pi); + my @slots = grep(/^\d+/, map { $var{$_} } @ops); + op_slot_usage($op, @slots); + push(@code, $op); next; } @@ -1544,7 +1508,6 @@ sub tr_gen_from { $opnum = $gen_opnum{$name,$arity}; push(@code, make_op("$name/$arity", 'next_instr', $opnum)); - $min_window++; foreach $op (@ops) { my($var, $type, $type_val, $cond, $val) = @$op; my $ignored_var = "$var (ignored)"; @@ -1593,15 +1556,21 @@ sub tr_gen_from { if (defined $var{$var}) { $ignored_var = ''; $may_fail = 1; - push(@code, &make_op($var, 'is_same_var', $var{$var})); + my $op = make_op($var, 'is_same_var', $var{$var}); + op_slot_usage($op, $var{$var}); + push(@code, $op); } elsif ($type eq '*') { - # - # Reserve a hole for a 'rest_args' instruction. - # + foreach my $type (values %var_type) { + error("only one use of a '*' variable is " . + "allowed on the left hand side of " . + "a transformation") + if $type eq 'array'; + } $ignored_var = ''; - push(@fix_rest_args, scalar(@code)); - push(@code, $var); - } elsif ($var_used{$var}) { + $var{$var} = 'unnumbered'; + $var_type{$var} = 'array'; + push(@code, make_op($var, 'rest_args')); + } else { $ignored_var = ''; $var_type{$var} = 'scalar'; $var{$var} = $var_num; @@ -1629,46 +1598,14 @@ sub tr_gen_from { # push(@code, make_op($may_fail ? '' : 'always reached', 'commit')); - # - # If there is an rest_args instruction, we must insert its correct - # variable number (higher than any other). - # - my $index; - &error("only one use of a '*' variable is allowed on the left hand side of a transformation") - if @fix_rest_args > 1; - foreach $index (@fix_rest_args) { - my $var = $code[$index]; - $var{$var} = $var_num++; - $var_type{$var} = 'array'; - splice(@code, $index, 1, &make_op($var, 'rest_args', $var{$var})); - } - - foreach $index (@fix_pred_funcs) { - my($name, @ops) = @{$code[$index]}; - my(@args); - my $var; - - foreach $var (@ops) { - &error($where, "variable '$var' unbound") - unless defined $var{$var}; - if ($var_type{$var} eq 'scalar') { - push(@args, "var[$var{$var}]"); - } else { - push(@args, "var+$var{$var}"); - } - } - my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args); - splice(@code, $index, 1, make_op("$name()", 'pred', $pi)); - } - $te_max_vars = $var_num if $te_max_vars < $var_num; - [$min_window, \%var, \%var_type, \@code]; + [\%var, \%var_type, \@code]; } sub tr_gen_to { my($line, $orig_transform, $so_far, @tr) = @_; - my($min_window, $var_ref, $var_type_ref, $code_ref) = @$so_far; + my($var_ref, $var_type_ref, $code_ref) = @$so_far; my(%var) = %$var_ref; my(%var_type) = %$var_type_ref; my(@code) = @$code_ref; @@ -1697,13 +1634,16 @@ sub tr_gen_to { if ($var_type{$var} eq 'scalar') { push(@args, "var[$var{$var}]"); } else { - push(@args, "var+$var{$var}"); + push(@args, "rest_args"); } } pop(@code); # Get rid of 'commit' instruction my $index = tr_next_index(\@call_table, \%call_table, $name, @args); - push(@code, make_op("$name()", 'call_end', $index)); + my $op = make_op("$name()", 'call_end', $index); + my @slots = grep(/^\d+/, map { $var{$_} } @ops); + op_slot_usage($op, @slots); + push(@code, $op); last; } @@ -1725,11 +1665,13 @@ sub tr_gen_to { my($var, $type, $type_val) = @$op; if ($type eq '*') { - push(@code, make_op($var, 'store_rest_args', $var{$var})); + push(@code, make_op($var, 'store_rest_args')); } elsif ($var ne '') { &error($where, "variable '$var' unbound") unless defined $var{$var}; - push(@code, &make_op($var, 'store_var_next_arg', $var{$var})); + my $op = make_op($var, 'store_var_next_arg', $var{$var}); + op_slot_usage($op, $var{$var}); + push(@code, $op); } elsif ($type ne '') { push(@code, &make_op('', 'store_type', "TAG_$type")); if ($type_val) { @@ -1744,6 +1686,10 @@ sub tr_gen_to { push(@code, make_op('', 'end')) unless is_instr($code[$#code], 'call_end'); + tr_maybe_keep(\@code); + tr_maybe_rename(\@code); + tr_remove_unused(\@code); + # # Chain together all codes segments having the same first operation. # @@ -1752,8 +1698,6 @@ sub tr_gen_to { my($dummy, $arity); ($dummy, $op, $arity) = @$first; my($comment) = "\n/*\n * Line $line:\n * $orig_transform\n */\n\n"; - $min_window{$key} = $min_window - if $min_window{$key} > $min_window; my $prev_last; $prev_last = pop(@{$gen_transform{$key}}) @@ -1771,6 +1715,148 @@ sub tr_gen_to { push(@{$gen_transform{$key}}, @code), } +sub tr_maybe_keep { + my($ref) = @_; + my @last_instr; + my $pos; + my $reused_instr; + + for (my $i = 0; $i < @$ref; $i++) { + my $instr = $$ref[$i]; + my($size, $instr_ref, $comment) = @$instr; + my($op, @args) = @$instr_ref; + if ($op eq 'next_instr') { + @last_instr = ($args[0]); + } elsif ($op eq 'set_var_next_arg') { + push @last_instr, $args[0]; + } elsif ($op eq 'next_arg') { + push @last_instr, 'ignored'; + } elsif ($op eq 'new_instr') { + unless (defined $pos) { + # 'new_instr' immediately after 'commit'. + $reused_instr = $args[0]; + return unless shift(@last_instr) == $reused_instr; + $pos = $i - 1; + } else { + # Second 'new_instr' after 'commit'. The instructions + # from $pos up to and including $i - 1 rebuilds the + # existing instruction exactly. + my $name = $gen_opname[$reused_instr]; + my $arity = $gen_arity[$reused_instr]; + my $reuse = make_op("$name/$arity", 'keep'); + splice @$ref, $pos, $i-$pos, ($reuse); + return; + } + } elsif ($op eq 'store_var_next_arg') { + return unless shift(@last_instr) eq $args[0]; + } elsif (defined $pos) { + return; + } + } +} + +sub tr_maybe_rename { + my($ref) = @_; + my $s = 'left'; + my $a = 0; + my $num_args = 0; + my $new_instr; + my $first; + my $i; + + for ($i = 1; $i < @$ref; $i++) { + my $instr = $$ref[$i]; + my($size, $instr_ref, $comment) = @$instr; + my($op, @args) = @$instr_ref; + + if ($s eq 'left') { + if ($op eq 'set_var_next_arg') { + if ($num_args == $a and $args[0] == $a) { + $num_args++; + } + $a++; + } elsif ($op eq 'next_arg') { + $a++; + } elsif ($op eq 'commit') { + $a = 0; + $first = $i; + $s = 'committed'; + } elsif ($op eq 'next_instr') { + return; + } + } elsif ($s eq 'committed') { + if ($op eq 'new_instr') { + $new_instr = $args[0]; + $a = 0; + $s = 'right'; + } else { + return; + } + } elsif ($s eq 'right') { + if ($op eq 'store_var_next_arg' && $args[0] == $a) { + $a++; + } elsif ($op eq 'end' && $a <= $num_args) { + my $name = $gen_opname[$new_instr]; + my $arity = $gen_arity[$new_instr]; + my $new_op = make_op("$name/$arity", 'rename', $new_instr); + splice @$ref, $first, $i-$first+1, ($new_op); + return; + } else { + return; + } + } + } +} + +sub tr_remove_unused { + my($ref) = @_; + my %used; + + # Collect all used variables. + for my $instr (@$ref) { + my $uref = $$instr[3]; + for my $slot (@$uref) { + $used{$slot} = 1; + } + } + + # Replace 'set_var_next_arg' with 'next_arg' if the variable + # is never used. + for my $instr (@$ref) { + my($size, $instr_ref, $comment) = @$instr; + my($op, @args) = @$instr_ref; + if ($op eq 'set_var_next_arg') { + my $var = $args[0]; + next if $used{$var}; + $instr = make_op("$comment (ignored)", 'next_arg'); + } + } + + # Delete a sequence of 'next_arg' instructions when they are + # redundant before instructions such as 'commit'. + my @opcode; + my %ending = (call_end => 1, + commit => 1, + next_instr => 1, + pred => 1, + rename => 1, + keep => 1); + for (my $i = 0; $i < @$ref; $i++) { + my $instr = $$ref[$i]; + my($size, $instr_ref, $comment) = @$instr; + my($opcode) = @$instr_ref; + + if ($ending{$opcode}) { + my $first = $i; + $first-- while $first > 0 and $opcode[$first-1] eq 'next_arg'; + my $n = $i - $first; + splice @$ref, $first, $n; + $i -= $n; + } + $opcode[$i] = $opcode; + } +} + sub tr_code_len { my($sum) = 0; my($ref); @@ -1783,7 +1869,12 @@ sub tr_code_len { sub make_op { my($comment, @op) = @_; - [scalar(@op), [@op], $comment]; + [scalar(@op), [@op], $comment, []]; +} + +sub op_slot_usage { + my($op_ref, @slots) = @_; + $$op_ref[3] = \@slots; } sub is_instr { diff --git a/erts/preloaded/ebin/erlang.beam b/erts/preloaded/ebin/erlang.beam Binary files differindex 2ea2de4c70..7ceb6daaa3 100644 --- a/erts/preloaded/ebin/erlang.beam +++ b/erts/preloaded/ebin/erlang.beam diff --git a/erts/preloaded/src/erlang.erl b/erts/preloaded/src/erlang.erl index dfbd116d6e..50b01703ac 100644 --- a/erts/preloaded/src/erlang.erl +++ b/erts/preloaded/src/erlang.erl @@ -2130,7 +2130,7 @@ process_flag(_Flag, _Value) -> {message_queue_data, MQD :: message_queue_data()} | {priority, Level :: priority_level()} | {reductions, Number :: non_neg_integer()} | - {registered_name, Atom :: atom()} | + {registered_name, [] | (Atom :: atom())} | {sequential_trace_token, [] | (SequentialTraceToken :: term())} | {stack_size, Size :: non_neg_integer()} | {status, Status :: exiting | garbage_collecting | waiting | running | runnable | suspended} | diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl index d1052303e0..429b1aa010 100644 --- a/lib/compiler/src/beam_block.erl +++ b/lib/compiler/src/beam_block.erl @@ -88,7 +88,9 @@ collect_block([I|Is]=Is0, Acc) -> case collect(I) of error -> {reverse(Acc),Is0}; Instr -> collect_block(Is, [Instr|Acc]) - end. + end; +collect_block([], Acc) -> + {reverse(Acc),[]}. collect({allocate,N,R}) -> {set,[],[],{alloc,R,{nozero,N,0,[]}}}; collect({allocate_zero,N,R}) -> {set,[],[],{alloc,R,{zero,N,0,[]}}}; diff --git a/lib/compiler/src/beam_split.erl b/lib/compiler/src/beam_split.erl index bb1c0e23a9..7b7f0a0f80 100644 --- a/lib/compiler/src/beam_split.erl +++ b/lib/compiler/src/beam_split.erl @@ -47,6 +47,8 @@ split_block([{set,[R],[_,_,_]=As,{bif,is_record,{f,Lbl}}}|Is], Bl, Acc) -> split_block(Is, [], [{bif,is_record,{f,Lbl},As,R}|make_block(Bl, Acc)]); split_block([{set,[R],As,{bif,N,{f,Lbl}=Fail}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{bif,N,Fail,As,R}|make_block(Bl, Acc)]); +split_block([{set,[R],As,{bif,raise,{f,_}=Fail}}|Is], Bl, Acc) -> + split_block(Is, [], [{bif,raise,Fail,As,R}|make_block(Bl, Acc)]); split_block([{set,[R],As,{alloc,Live,{gc_bif,N,{f,Lbl}=Fail}}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{gc_bif,N,Fail,Live,As,R}|make_block(Bl, Acc)]); diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index fd38fc0095..1c052789fd 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -509,6 +509,9 @@ valfun_4({bif,element,{f,Fail},[Pos,Tuple],Dst}, Vst0) -> TupleType = upgrade_tuple_type({tuple,[get_tuple_size(PosType)]}, TupleType0), Vst = set_type(TupleType, Tuple, Vst1), set_type_reg(term, Dst, Vst); +valfun_4({bif,raise,{f,0},Src,_Dst}, Vst) -> + validate_src(Src, Vst), + kill_state(Vst); valfun_4({bif,Op,{f,Fail},Src,Dst}, Vst0) -> validate_src(Src, Vst0), Vst = branch_state(Fail, Vst0), diff --git a/lib/compiler/src/beam_z.erl b/lib/compiler/src/beam_z.erl index 8381578b68..e44423d257 100644 --- a/lib/compiler/src/beam_z.erl +++ b/lib/compiler/src/beam_z.erl @@ -24,6 +24,8 @@ -export([module/2]). +-import(lists, [dropwhile/2]). + module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> Fs = [function(F) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. @@ -51,6 +53,16 @@ undo_renames([{call,A,F},return|Is]) -> [{call_only,A,F}|undo_renames(Is)]; undo_renames([{call_ext,A,F},return|Is]) -> [{call_ext_only,A,F}|undo_renames(Is)]; +undo_renames([{bif,raise,_,_,_}=I|Is0]) -> + %% A minor optimization. Done here because: + %% (1) beam_jump may move or share 'raise' instructions, and that + %% may confuse beam_validator. + %% (2) beam_trim cannot do its optimization if the 'deallocate' + %% instruction after 'raise' has been removed. + Is = dropwhile(fun({label,_}) -> false; + (_) -> true + end, Is0), + [I|undo_renames(Is)]; undo_renames([I|Is]) -> [undo_rename(I)|undo_renames(Is)]; undo_renames([]) -> []. diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl index d27512b6eb..b3fb091f46 100644 --- a/lib/compiler/test/beam_validator_SUITE.erl +++ b/lib/compiler/test/beam_validator_SUITE.erl @@ -312,7 +312,7 @@ state_after_fault_in_catch(Config) when is_list(Config) -> no_exception_in_catch(Config) when is_list(Config) -> Errors = do_val(no_exception_in_catch, Config), [{{no_exception_in_catch,nested_of_1,4}, - {{move,{x,3},{x,0}},88,{uninitialized_reg,{x,3}}}}] = Errors, + {{move,{x,3},{x,0}},87,{uninitialized_reg,{x,3}}}}] = Errors, ok. undef_label(Config) when is_list(Config) -> diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index d1f620d892..74cdecdec6 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -378,86 +378,96 @@ struct hmac_context static void hmac_context_dtor(ErlNifEnv* env, struct hmac_context*); struct digest_type_t { - const char* type_str; - const EVP_MD* (*md_func)(void); /* NULL if notsup */ - ERL_NIF_TERM type_atom; + union { + const char* str; /* before init, NULL for end-of-table */ + ERL_NIF_TERM atom; /* after init, 'false' for end-of-table */ + }type; + union { + const EVP_MD* (*funcp)(void); /* before init, NULL if notsup */ + const EVP_MD* p; /* after init, NULL if notsup */ + }md; }; struct digest_type_t digest_types[] = { - {"md4", &EVP_md4}, - {"md5", &EVP_md5}, - {"ripemd160", &EVP_ripemd160}, - {"sha", &EVP_sha1}, - {"sha224", + {{"md4"}, {&EVP_md4}}, + {{"md5"}, {&EVP_md5}}, + {{"ripemd160"}, {&EVP_ripemd160}}, + {{"sha"}, {&EVP_sha1}}, + {{"sha224"}, #ifdef HAVE_SHA224 - &EVP_sha224 + {&EVP_sha224} #else - NULL + {NULL} #endif }, - {"sha256", + {{"sha256"}, #ifdef HAVE_SHA256 - &EVP_sha256 + {&EVP_sha256} #else - NULL + {NULL} #endif }, - {"sha384", + {{"sha384"}, #ifdef HAVE_SHA384 - &EVP_sha384 + {&EVP_sha384} #else - NULL + {NULL} #endif }, - {"sha512", + {{"sha512"}, #ifdef HAVE_SHA512 - &EVP_sha512 + {&EVP_sha512} #else - NULL + {NULL} #endif }, - {NULL} + {{NULL}} }; static struct digest_type_t* get_digest_type(ERL_NIF_TERM type); struct cipher_type_t { - const char* type_str; - const EVP_CIPHER* (*cipher_func)(void); /* NULL if notsup */ + union { + const char* str; /* before init */ + ERL_NIF_TERM atom; /* after init */ + }type; + union { + const EVP_CIPHER* (*funcp)(void); /* before init, NULL if notsup */ + const EVP_CIPHER* p; /* after init, NULL if notsup */ + }cipher; const size_t key_len; /* != 0 to also match on key_len */ - ERL_NIF_TERM type_atom; }; struct cipher_type_t cipher_types[] = { - {"rc2_cbc", &EVP_rc2_cbc}, - {"des_cbc", &EVP_des_cbc}, - {"des_cfb", &EVP_des_cfb8}, - {"des_ecb", &EVP_des_ecb}, - {"des_ede3_cbc", &EVP_des_ede3_cbc}, - {"des_ede3_cbf", + {{"rc2_cbc"}, {&EVP_rc2_cbc}}, + {{"des_cbc"}, {&EVP_des_cbc}}, + {{"des_cfb"}, {&EVP_des_cfb8}}, + {{"des_ecb"}, {&EVP_des_ecb}}, + {{"des_ede3_cbc"}, {&EVP_des_ede3_cbc}}, + {{"des_ede3_cbf"}, #ifdef HAVE_DES_ede3_cfb_encrypt - &EVP_des_ede3_cfb8 + {&EVP_des_ede3_cfb8} #else - NULL + {NULL} #endif }, - {"blowfish_cbc", &EVP_bf_cbc}, - {"blowfish_cfb64", &EVP_bf_cfb64}, - {"blowfish_ofb64", &EVP_bf_ofb}, - {"blowfish_ecb", &EVP_bf_ecb}, - {"aes_cbc", &EVP_aes_128_cbc, 16}, - {"aes_cbc", &EVP_aes_192_cbc, 24}, - {"aes_cbc", &EVP_aes_256_cbc, 32}, - {"aes_cbc128", &EVP_aes_128_cbc}, - {"aes_cbc256", &EVP_aes_256_cbc}, - {"aes_cfb8", &EVP_aes_128_cfb8}, - {"aes_cfb128", &EVP_aes_128_cfb128}, - {"aes_ecb", &EVP_aes_128_ecb, 16}, - {"aes_ecb", &EVP_aes_192_ecb, 24}, - {"aes_ecb", &EVP_aes_256_ecb, 32}, - {NULL} + {{"blowfish_cbc"}, {&EVP_bf_cbc}}, + {{"blowfish_cfb64"}, {&EVP_bf_cfb64}}, + {{"blowfish_ofb64"}, {&EVP_bf_ofb}}, + {{"blowfish_ecb"}, {&EVP_bf_ecb}}, + {{"aes_cbc"}, {&EVP_aes_128_cbc}, 16}, + {{"aes_cbc"}, {&EVP_aes_192_cbc}, 24}, + {{"aes_cbc"}, {&EVP_aes_256_cbc}, 32}, + {{"aes_cbc128"}, {&EVP_aes_128_cbc}}, + {{"aes_cbc256"}, {&EVP_aes_256_cbc}}, + {{"aes_cfb8"}, {&EVP_aes_128_cfb8}}, + {{"aes_cfb128"}, {&EVP_aes_128_cfb128}}, + {{"aes_ecb"}, {&EVP_aes_128_ecb}, 16}, + {{"aes_ecb"}, {&EVP_aes_192_ecb}, 24}, + {{"aes_ecb"}, {&EVP_aes_256_ecb}, 32}, + {{NULL}} }; static struct cipher_type_t* get_cipher_type(ERL_NIF_TERM type, size_t key_len); @@ -829,6 +839,15 @@ static ERL_NIF_TERM info_lib(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] ver_term)); } +static ERL_NIF_TERM make_badarg_maybe(ErlNifEnv* env) +{ + ERL_NIF_TERM reason; + if (enif_has_pending_exception(env, &reason)) + return reason; /* dummy return value ignored */ + else + return enif_make_badarg(env); +} + static ERL_NIF_TERM hash_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (Type, Data) */ struct digest_type_t *digp = NULL; @@ -842,11 +861,11 @@ static ERL_NIF_TERM hash_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] !enif_inspect_iolist_as_binary(env, argv[1], &data)) { return enif_make_badarg(env); } - if (!digp->md_func) { + md = digp->md.p; + if (!md) { return atom_notsup; } - md = digp->md_func(); ret_size = (unsigned)EVP_MD_size(md); ASSERT(0 < ret_size && ret_size <= EVP_MAX_MD_SIZE); if (!EVP_Digest(data.data, data.size, @@ -872,12 +891,12 @@ static ERL_NIF_TERM hash_init_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM a if (!digp) { return enif_make_badarg(env); } - if (!digp->md_func) { + if (!digp->md.p) { return atom_notsup; } ctx = enif_alloc_resource(evp_md_ctx_rtype, sizeof(EVP_MD_CTX)); - if (!EVP_DigestInit(ctx, digp->md_func())) { + if (!EVP_DigestInit(ctx, digp->md.p)) { enif_release_resource(ctx); return atom_notsup; } @@ -946,11 +965,11 @@ static ERL_NIF_TERM hash_init_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM a if (!digp) { return enif_make_badarg(env); } - if (!digp->md_func) { + if (!digp->md.p) { return atom_notsup; } - switch (EVP_MD_type(digp->md_func())) + switch (EVP_MD_type(digp->md.p)) { case NID_md4: ctx_size = MD4_CTX_LEN; @@ -1020,11 +1039,11 @@ static ERL_NIF_TERM hash_update_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM !enif_inspect_iolist_as_binary(env, argv[1], &data)) { return enif_make_badarg(env); } - if (!digp->md_func) { + if (!digp->md.p) { return atom_notsup; } - switch (EVP_MD_type(digp->md_func())) + switch (EVP_MD_type(digp->md.p)) { case NID_md4: ctx_size = MD4_CTX_LEN; @@ -1102,11 +1121,11 @@ static ERL_NIF_TERM hash_final_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM !enif_inspect_binary(env, tuple[1], &ctx)) { return enif_make_badarg(env); } - if (!digp->md_func) { + md = digp->md.p; + if (!md) { return atom_notsup; } - md = digp->md_func(); switch (EVP_MD_type(md)) { @@ -1186,8 +1205,8 @@ static ERL_NIF_TERM hmac_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] return enif_make_badarg(env); } - if (!digp->md_func || - !HMAC(digp->md_func(), + if (!digp->md.p || + !HMAC(digp->md.p, key.data, key.size, data.data, data.size, buff, &size)) { @@ -1229,7 +1248,7 @@ static ERL_NIF_TERM hmac_init_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM a !enif_inspect_iolist_as_binary(env, argv[1], &key)) { return enif_make_badarg(env); } - if (!digp->md_func) { + if (!digp->md.p) { return atom_notsup; } @@ -1239,12 +1258,12 @@ static ERL_NIF_TERM hmac_init_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM a #if OPENSSL_VERSION_NUMBER >= 0x1000000fL // Check the return value of HMAC_Init: it may fail in FIPS mode // for disabled algorithms - if (!HMAC_Init(&obj->ctx, key.data, key.size, digp->md_func())) { + if (!HMAC_Init(&obj->ctx, key.data, key.size, digp->md.p)) { enif_release_resource(obj); return atom_notsup; } #else - HMAC_Init(&obj->ctx, key.data, key.size, digp->md_func()); + HMAC_Init(&obj->ctx, key.data, key.size, digp->md.p); #endif ret = enif_make_resource(env, obj); @@ -1323,7 +1342,8 @@ static ERL_NIF_TERM block_crypt_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM || !enif_inspect_iolist_as_binary(env, argv[argc - 2], &text)) { return enif_make_badarg(env); } - if (!cipherp->cipher_func) { + cipher = cipherp->cipher.p; + if (!cipher) { return enif_raise_exception(env, atom_notsup); } @@ -1335,7 +1355,6 @@ static ERL_NIF_TERM block_crypt_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM return aes_cfb_8_crypt(env, argc-1, argv+1); } - cipher = cipherp->cipher_func(); ivec_size = EVP_CIPHER_iv_length(cipher); #ifdef HAVE_ECB_IVEC_BUG @@ -2110,27 +2129,31 @@ static void init_digest_types(ErlNifEnv* env) { struct digest_type_t* p = digest_types; - for (p = digest_types; p->type_str; p++) { - p->type_atom = enif_make_atom(env, p->type_str); + for (p = digest_types; p->type.str; p++) { + p->type.atom = enif_make_atom(env, p->type.str); + if (p->md.funcp) + p->md.p = p->md.funcp(); } - + p->type.atom = atom_false; /* end marker */ } static void init_cipher_types(ErlNifEnv* env) { struct cipher_type_t* p = cipher_types; - for (p = cipher_types; p->type_str; p++) { - p->type_atom = enif_make_atom(env, p->type_str); + for (p = cipher_types; p->type.str; p++) { + p->type.atom = enif_make_atom(env, p->type.str); + if (p->cipher.funcp) + p->cipher.p = p->cipher.funcp(); } - + p->type.atom = atom_false; /* end marker */ } static struct digest_type_t* get_digest_type(ERL_NIF_TERM type) { struct digest_type_t* p = NULL; - for (p = digest_types; p->type_str; p++) { - if (type == p->type_atom) { + for (p = digest_types; p->type.atom != atom_false; p++) { + if (type == p->type.atom) { return p; } } @@ -2140,8 +2163,8 @@ static struct digest_type_t* get_digest_type(ERL_NIF_TERM type) static struct cipher_type_t* get_cipher_type(ERL_NIF_TERM type, size_t key_len) { struct cipher_type_t* p = NULL; - for (p = cipher_types; p->type_str; p++) { - if (type == p->type_atom && (!p->key_len || key_len == p->key_len)) { + for (p = cipher_types; p->type.atom != atom_false; p++) { + if (type == p->type.atom && (!p->key_len || key_len == p->key_len)) { return p; } } @@ -2166,12 +2189,12 @@ static ERL_NIF_TERM rsa_verify_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM if (!digp) { return enif_make_badarg(env); } - if (!digp->md_func) { + md = digp->md.p; + if (!md) { return atom_notsup; } rsa = RSA_new(); - md = digp->md_func(); if (!enif_inspect_binary(env, argv[1], &digest_bin) || digest_bin.size != EVP_MD_size(md) @@ -2329,10 +2352,10 @@ static ERL_NIF_TERM rsa_sign_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM ar if (!digp) { return enif_make_badarg(env); } - if (!digp->md_func) { + md = digp->md.p; + if (!md) { return atom_notsup; } - md = digp->md_func(); if (!enif_inspect_binary(env,argv[1],&digest_bin) || digest_bin.size != EVP_MD_size(md)) { @@ -2904,8 +2927,7 @@ static EC_KEY* ec_key_new(ErlNifEnv* env, ERL_NIF_TERM curve_arg) EC_POINT *point = NULL; /* {Field, Prime, Point, Order, CoFactor} = Curve */ - if (enif_is_tuple(env, curve_arg) - && enif_get_tuple(env,curve_arg,&c_arity,&curve) + if (enif_get_tuple(env,curve_arg,&c_arity,&curve) && c_arity == 5 && get_bn_from_bin(env, curve[3], &bn_order) && (curve[4] != atom_none && get_bn_from_bin(env, curve[4], &cofactor))) { @@ -2942,9 +2964,11 @@ static EC_KEY* ec_key_new(ErlNifEnv* env, ERL_NIF_TERM curve_arg) /* create the EC_GROUP structure */ group = EC_GROUP_new_curve_GFp(p, a, b, NULL); -#if !defined(OPENSSL_NO_EC2M) - } else if (f_arity == 3 && field[0] == atom_characteristic_two_field) { +#if defined(OPENSSL_NO_EC2M) + enif_raise_exception(env, atom_notsup); + goto out_err; +#else /* {characteristic_two_field, M, Basis} */ int b_arity = -1; @@ -3221,7 +3245,7 @@ static ERL_NIF_TERM ec_key_generate(ErlNifEnv* env, int argc, const ERL_NIF_TERM badarg: if (key) EC_KEY_free(key); - return enif_make_badarg(env); + return make_badarg_maybe(env); #else return atom_notsup; #endif @@ -3241,10 +3265,10 @@ static ERL_NIF_TERM ecdsa_sign_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM if (!digp) { return enif_make_badarg(env); } - if (!digp->md_func) { + md = digp->md.p; + if (!md) { return atom_notsup; } - md = digp->md_func(); len = EVP_MD_size(md); if (!enif_inspect_binary(env,argv[1],&digest_bin) @@ -3272,7 +3296,7 @@ static ERL_NIF_TERM ecdsa_sign_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM badarg: if (key) EC_KEY_free(key); - return enif_make_badarg(env); + return make_badarg_maybe(env); #else return atom_notsup; #endif @@ -3292,10 +3316,10 @@ static ERL_NIF_TERM ecdsa_verify_nif(ErlNifEnv* env, int argc, const ERL_NIF_TER if (!digp) { return enif_make_badarg(env); } - if (!digp->md_func) { + md = digp->md.p; + if (!md) { return atom_notsup; } - md = digp->md_func(); len = EVP_MD_size(md); if (!enif_inspect_binary(env, argv[1], &digest_bin) @@ -3314,7 +3338,7 @@ static ERL_NIF_TERM ecdsa_verify_nif(ErlNifEnv* env, int argc, const ERL_NIF_TER badarg: if (key) EC_KEY_free(key); - return enif_make_badarg(env); + return make_badarg_maybe(env); #else return atom_notsup; #endif @@ -3339,7 +3363,7 @@ static ERL_NIF_TERM ecdh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF EC_KEY *other_ecdh = NULL; if (!get_ec_key(env, argv[1], argv[2], atom_undefined, &key)) - return enif_make_badarg(env); + return make_badarg_maybe(env); group = EC_GROUP_dup(EC_KEY_get0_group(key)); priv_key = EC_KEY_get0_private_key(key); diff --git a/lib/erl_interface/test/erl_eterm_SUITE.erl b/lib/erl_interface/test/erl_eterm_SUITE.erl index b342a2f1ef..2e580f379e 100644 --- a/lib/erl_interface/test/erl_eterm_SUITE.erl +++ b/lib/erl_interface/test/erl_eterm_SUITE.erl @@ -936,7 +936,6 @@ collect_line(Port, Result) -> collect_line(Port, Chars++Result) end after 5000 -> - test_server:fail("No response from C program") ct:fail("No response from C program") end. diff --git a/lib/inets/examples/server_root/conf/8080.conf b/lib/inets/examples/server_root/conf/8080.conf index 48e66f0114..7b1b4a15b2 100644 --- a/lib/inets/examples/server_root/conf/8080.conf +++ b/lib/inets/examples/server_root/conf/8080.conf @@ -1,7 +1,7 @@ Port 8080 #ServerName your.server.net SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8080 diff --git a/lib/inets/examples/server_root/conf/8888.conf b/lib/inets/examples/server_root/conf/8888.conf index 79bb7fcca4..042779fcd0 100644 --- a/lib/inets/examples/server_root/conf/8888.conf +++ b/lib/inets/examples/server_root/conf/8888.conf @@ -1,7 +1,7 @@ Port 8888 #ServerName your.server.net SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8888 diff --git a/lib/inets/examples/server_root/conf/httpd.conf b/lib/inets/examples/server_root/conf/httpd.conf index f99563d14b..98920ebaa5 100644 --- a/lib/inets/examples/server_root/conf/httpd.conf +++ b/lib/inets/examples/server_root/conf/httpd.conf @@ -64,7 +64,7 @@ SocketType ip_comm # WARNING! Do not tamper with this directive unless you are familiar with # EWSAPI. -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_include mod_dir mod_get mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_dir mod_get mod_log mod_disk_log # ServerAdmin: Your address, where problems with the server should be # e-mailed. diff --git a/lib/inets/examples/server_root/conf/ssl.conf b/lib/inets/examples/server_root/conf/ssl.conf index 8b8c57a98b..de49ceafd0 100644 --- a/lib/inets/examples/server_root/conf/ssl.conf +++ b/lib/inets/examples/server_root/conf/ssl.conf @@ -1,7 +1,7 @@ Port 8088 #ServerName your.server.net SocketType ssl -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8088 diff --git a/lib/inets/src/http_client/httpc_request.erl b/lib/inets/src/http_client/httpc_request.erl index af4c3f75f2..8fcfbc30c0 100644 --- a/lib/inets/src/http_client/httpc_request.erl +++ b/lib/inets/src/http_client/httpc_request.erl @@ -186,16 +186,19 @@ is_client_closing(Headers) -> %%%======================================================================== %%% Internal functions %%%======================================================================== -post_data(Method, Headers, {ContentType, Body}, HeadersAsIs) - when (Method =:= post) orelse (Method =:= put) - orelse (Method =:= patch) -> +post_data(Method, Headers, {ContentType, Body}, HeadersAsIs) + when (Method =:= post) + orelse (Method =:= put) + orelse (Method =:= patch) + orelse (Method =:= delete) -> + NewBody = case Headers#http_request_h.expect of - "100-continue" -> - ""; - _ -> - Body - end, - + "100-continue" -> + ""; + _ -> + Body + end, + NewHeaders = case HeadersAsIs of [] -> Headers#http_request_h{ @@ -213,7 +216,7 @@ post_data(Method, Headers, {ContentType, Body}, HeadersAsIs) _ -> HeadersAsIs end, - + {NewHeaders, NewBody}; post_data(_, Headers, _, []) -> diff --git a/lib/inets/test/httpc_SUITE.erl b/lib/inets/test/httpc_SUITE.erl index 93b96e101f..f9b3aa5b59 100644 --- a/lib/inets/test/httpc_SUITE.erl +++ b/lib/inets/test/httpc_SUITE.erl @@ -67,6 +67,7 @@ real_requests()-> head, get, post, + delete, post_stream, patch, async, @@ -256,6 +257,29 @@ post(Config) when is_list(Config) -> {ok, {{_,504,_}, [_ | _], []}} = httpc:request(post, {URL, [{"expect","100-continue"}], "text/plain", "foobar"}, [], []). +%%-------------------------------------------------------------------- +delete() -> + [{"Test http delete request against local server. We do in this case " + "only care about the client side of the the delete. The server " + "script will not actually use the delete data."}]. +delete(Config) when is_list(Config) -> + CGI = case test_server:os_type() of + {win32, _} -> + "/cgi-bin/cgi_echo.exe"; + _ -> + "/cgi-bin/cgi_echo" + end, + + URL = url(group_name(Config), CGI, Config), + Body = lists:duplicate(100, "1"), + + {ok, {{_,200,_}, [_ | _], [_ | _]}} = + httpc:request(delete, {URL, [{"expect","100-continue"}], + "text/plain", Body}, [], []), + + {ok, {{_,504,_}, [_ | _], []}} = + httpc:request(delete, {URL, [{"expect","100-continue"}], + "text/plain", "foobar"}, [], []). %%-------------------------------------------------------------------- patch() -> diff --git a/lib/inets/test/httpd_1_1.erl b/lib/inets/test/httpd_1_1.erl index d3a1e3672a..88d91b552c 100644 --- a/lib/inets/test/httpd_1_1.erl +++ b/lib/inets/test/httpd_1_1.erl @@ -233,14 +233,6 @@ trace(Type, Port, Host, Node)-> "Max-Forwards:2\r\n\r\n", [{statuscode, 200}]). head(Type, Port, Host, Node)-> - %% mod_include - ok = httpd_test_lib:verify_request(Type, Host, Port, Node, - "HEAD /fsize.shtml HTTP/1.0\r\n\r\n", - [{statuscode, 200}, - {version, "HTTP/1.0"}]), - ok = httpd_test_lib:verify_request(Type, Host, Port, Node, - "HEAD /fsize.shtml HTTP/1.1\r\nhost:" ++ - Host ++ "\r\n\r\n", [{statuscode, 200}]), %% mod_esi ok = httpd_test_lib:verify_request(Type, Host, Port, Node, "HEAD /cgi-bin/erl/httpd_example/newformat" diff --git a/lib/inets/test/httpd_test_data/server_root/conf/8080.conf b/lib/inets/test/httpd_test_data/server_root/conf/8080.conf index 48e66f0114..7b1b4a15b2 100644 --- a/lib/inets/test/httpd_test_data/server_root/conf/8080.conf +++ b/lib/inets/test/httpd_test_data/server_root/conf/8080.conf @@ -1,7 +1,7 @@ Port 8080 #ServerName your.server.net SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8080 diff --git a/lib/inets/test/httpd_test_data/server_root/conf/8888.conf b/lib/inets/test/httpd_test_data/server_root/conf/8888.conf index 79bb7fcca4..042779fcd0 100644 --- a/lib/inets/test/httpd_test_data/server_root/conf/8888.conf +++ b/lib/inets/test/httpd_test_data/server_root/conf/8888.conf @@ -1,7 +1,7 @@ Port 8888 #ServerName your.server.net SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8888 diff --git a/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf b/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf index 87c2973e5a..d94b245c25 100644 --- a/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf +++ b/lib/inets/test/httpd_test_data/server_root/conf/httpd.conf @@ -64,7 +64,7 @@ SocketType ip_comm # WARNING! Do not tamper with this directive unless you are familiar with # EWSAPI. -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_include mod_dir mod_get mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_dir mod_get mod_log mod_disk_log # ServerAdmin: Your address, where problems with the server should be # e-mailed. diff --git a/lib/inets/test/httpd_test_data/server_root/conf/ssl.conf b/lib/inets/test/httpd_test_data/server_root/conf/ssl.conf index 8b8c57a98b..de49ceafd0 100644 --- a/lib/inets/test/httpd_test_data/server_root/conf/ssl.conf +++ b/lib/inets/test/httpd_test_data/server_root/conf/ssl.conf @@ -1,7 +1,7 @@ Port 8088 #ServerName your.server.net SocketType ssl -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8088 diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf index 48e66f0114..7b1b4a15b2 100644 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf +++ b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf @@ -1,7 +1,7 @@ Port 8080 #ServerName your.server.net SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8080 diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf index 79bb7fcca4..042779fcd0 100644 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf +++ b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf @@ -1,7 +1,7 @@ Port 8888 #ServerName your.server.net SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8888 diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf index 87c2973e5a..d94b245c25 100644 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf +++ b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf @@ -64,7 +64,7 @@ SocketType ip_comm # WARNING! Do not tamper with this directive unless you are familiar with # EWSAPI. -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_include mod_dir mod_get mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_dir mod_get mod_log mod_disk_log # ServerAdmin: Your address, where problems with the server should be # e-mailed. diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf index 8b8c57a98b..de49ceafd0 100644 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf +++ b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf @@ -1,7 +1,7 @@ Port 8088 #ServerName your.server.net SocketType ssl -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_include mod_dir mod_get mod_head mod_log mod_disk_log +Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log ServerAdmin [email protected] ServerRoot /var/tmp/server_root ErrorLog logs/error_log_8088 diff --git a/lib/kernel/doc/src/rpc.xml b/lib/kernel/doc/src/rpc.xml index be1641ffd9..f8d81d749d 100644 --- a/lib/kernel/doc/src/rpc.xml +++ b/lib/kernel/doc/src/rpc.xml @@ -325,7 +325,8 @@ </func> <func> - <name name="pinfo" arity="2"/> + <name name="pinfo" arity="2" clause_i="1"/> + <name name="pinfo" arity="2" clause_i="2"/> <fsummary>Information about a process.</fsummary> <desc> <p>Location transparent version of the BIF diff --git a/lib/kernel/src/rpc.erl b/lib/kernel/src/rpc.erl index 0e1e3f070c..5f83713cf7 100644 --- a/lib/kernel/src/rpc.erl +++ b/lib/kernel/src/rpc.erl @@ -727,6 +727,11 @@ pinfo(Pid) -> -spec pinfo(Pid, Item) -> {Item, Info} | undefined | [] when Pid :: pid(), Item :: atom(), + Info :: term(); + (Pid, ItemList) -> [{Item, Info}] | undefined | [] when + Pid :: pid(), + Item :: atom(), + ItemList :: [Item], Info :: term(). pinfo(Pid, Item) when node(Pid) =:= node() -> diff --git a/lib/kernel/test/prim_file_SUITE.erl b/lib/kernel/test/prim_file_SUITE.erl index 149cc6c816..a3036f011c 100644 --- a/lib/kernel/test/prim_file_SUITE.erl +++ b/lib/kernel/test/prim_file_SUITE.erl @@ -1025,17 +1025,15 @@ file_write_file_info_opts(Config) when is_list(Config) -> %% REM: determine date range dependent on time_t = Uint32 | Sint32 | Sint64 %% Determine time_t on os:type()? - lists:foreach(fun - ({FI, Opts}) -> + lists:foreach(fun ({FI, Opts}) -> ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI, Opts]) - end, [ - {#file_info{ mode=8#400, atime = Time, mtime = Time, ctime = Time}, Opts} || + end, [ {#file_info{ mode=8#400, atime = Time, mtime = Time, ctime = Time}, Opts} || Opts <- [[{time, universal}],[{time, local}]], Time <- [ {{1970,1,1},{0,0,0}}, {{1970,1,1},{0,0,1}}, - {{1969,12,31},{23,59,59}}, - {{1908,2,3},{23,59,59}}, + % {{1969,12,31},{23,59,59}}, + % {{1908,2,3},{23,59,59}}, {{2012,2,3},{23,59,59}}, {{2037,2,3},{23,59,59}}, erlang:localtime() @@ -1070,8 +1068,9 @@ file_write_read_file_info_opts(Config) when is_list(Config) -> ok = file_write_read_file_info_opts(Handle, Name, {{1989, 04, 28}, {19,30,22}}, [{time, local}]), ok = file_write_read_file_info_opts(Handle, Name, {{1989, 04, 28}, {19,30,22}}, [{time, universal}]), - ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, local}]), - ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, universal}]), + %% will not work on platforms with unsigned time_t + %ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, local}]), + %ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, universal}]), ok = file_write_read_file_info_opts(Handle, Name, 1, [{time, posix}]), ok = file_write_read_file_info_opts(Handle, Name, -1, [{time, posix}]), ok = file_write_read_file_info_opts(Handle, Name, 300000, [{time, posix}]), @@ -1085,7 +1084,9 @@ file_write_read_file_info_opts(Handle, Name, Mtime, Opts) -> {ok, FI} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), FI2 = FI#file_info{ mtime = Mtime }, ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI2, Opts]), - {ok, FI2} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), + {ok, FI3} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), + io:format("Expecting mtime = ~p, got ~p~n", [FI2#file_info.mtime, FI3#file_info.mtime]), + FI2 = FI3, ok. diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index 82bede69d0..53d534ef19 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -421,7 +421,6 @@ fun(srp, Username :: string(), UserState :: term()) -> <warning><p>Using <c>{padding_check, boolean()}</c> makes TLS vulnerable to the Poodle attack.</p></warning> - </section> <section> @@ -522,9 +521,43 @@ fun(srp, Username :: string(), UserState :: term()) -> be supported by the server for the prevention to work. </p></warning> </item> - </taglist> + <tag><marker id="client_signature_algs"/><c>{signature_algs, [{hash(), ecdsa | rsa | dsa}]}</c></tag> + <item> + <p>In addition to the algorithms negotiated by the cipher + suite used for key exchange, payload encryption, message + authentication and pseudo random calculation, the TLS signature + algorithm extension <url + href="http://www.ietf.org/rfc/rfc5246.txt">Section 7.4.1.4.1 in RFC 5246</url> may be + used, from TLS 1.2, to negotiate which signature algorithm to use during the + TLS handshake. If no lower TLS versions than 1.2 are supported, + the client will send a TLS signature algorithm extension + with the algorithms specified by this option. + Defaults to + + <code>[ +%% SHA2 +{sha512, ecdsa}, +{sha512, rsa}, +{sha384, ecdsa}, +{sha384, rsa}, +{sha256, ecdsa}, +{sha256, rsa}, +{sha224, ecdsa}, +{sha224, rsa}, +%% SHA +{sha, ecdsa}, +{sha, rsa}, +{sha, dsa}, +]</code> + + The algorithms should be in the preferred order. + Selected signature algorithm can restrict which hash functions + that may be selected. Default support for {md5, rsa} removed in ssl-8.0 + </p> + </item> + </taglist> </section> - + <section> <title>SSL OPTION DESCRIPTIONS - SERVER SIDE</title> @@ -651,6 +684,14 @@ fun(srp, Username :: string(), UserState :: term()) -> <item>If true, use the server's preference for cipher selection. If false (the default), use the client's preference. </item> + + <tag><c>{signature_algs, [{hash(), ecdsa | rsa | dsa}]}</c></tag> + <item><p> The algorithms specified by + this option will be the ones accepted by the server in a signature algorithm + negotiation, introduced in TLS-1.2. The algorithms will also be offered to the client if a + client certificate is requested. For more details see the <seealso marker="#client_signature_algs">corresponding client option</seealso>. + </p> </item> + </taglist> </section> diff --git a/lib/ssl/src/dtls_connection.erl b/lib/ssl/src/dtls_connection.erl index 153d3fef48..e490de7eeb 100644 --- a/lib/ssl/src/dtls_connection.erl +++ b/lib/ssl/src/dtls_connection.erl @@ -196,8 +196,7 @@ hello(start, #state{host = Host, port = Port, role = client, {Record, State} = next_record(State1), next_state(hello, hello, Record, State); -hello(Hello = #client_hello{client_version = ClientVersion, - extensions = #hello_extensions{hash_signs = HashSigns}}, +hello(Hello = #client_hello{client_version = ClientVersion}, State = #state{connection_states = ConnectionStates0, port = Port, session = #session{own_certificate = Cert} = Session0, renegotiation = {Renegotiation, _}, @@ -209,9 +208,7 @@ hello(Hello = #client_hello{client_version = ClientVersion, {Version, {Type, Session}, ConnectionStates, #hello_extensions{ec_point_formats = EcPointFormats, - elliptic_curves = EllipticCurves} = ServerHelloExt} -> - HashSign = ssl_handshake:select_hashsign(HashSigns, Cert, - dtls_v1:corresponding_tls_version(Version)), + elliptic_curves = EllipticCurves} = ServerHelloExt, HashSign} -> ssl_connection:hello({common_client_hello, Type, ServerHelloExt, HashSign}, State#state{connection_states = ConnectionStates, negotiated_version = Version, diff --git a/lib/ssl/src/dtls_handshake.erl b/lib/ssl/src/dtls_handshake.erl index 22c0ce7a13..50c84b712f 100644 --- a/lib/ssl/src/dtls_handshake.erl +++ b/lib/ssl/src/dtls_handshake.erl @@ -94,7 +94,10 @@ hello(#server_hello{server_version = Version, random = Random, hello(#client_hello{client_version = ClientVersion}, _Options, {_,_,_,_,ConnectionStates,_}, _Renegotiation) -> %% Return correct typ to make dialyzer happy until we have time to make the real imp. - {ClientVersion, {new, #session{}}, ConnectionStates, #hello_extensions{}}. + HashSigns = tls_v1:default_signature_algs(dtls_v1:corresponding_tls_version(ClientVersion)), + {ClientVersion, {new, #session{}}, ConnectionStates, #hello_extensions{}, + %% Placeholder for real hasign handling + hd(HashSigns)}. %% hello(Address, Port, %% #ssl_tls{epoch = _Epoch, sequence_number = _Seq, diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index 780bef5877..9045f8fef9 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -700,6 +700,10 @@ handle_options(Opts0, Role) -> srp_identity = handle_option(srp_identity, Opts, undefined), ciphers = handle_cipher_option(proplists:get_value(ciphers, Opts, []), RecordCb:highest_protocol_version(Versions)), + signature_algs = handle_hashsigns_option(proplists:get_value(signature_algs, Opts, + default_option_role(server, + tls_v1:default_signature_algs(Versions), Role)), + RecordCb:highest_protocol_version(Versions)), %% Server side option reuse_session = handle_option(reuse_session, Opts, ReuseSessionFun), reuse_sessions = handle_option(reuse_sessions, Opts, true), @@ -749,7 +753,7 @@ handle_options(Opts0, Role) -> alpn_preferred_protocols, next_protocols_advertised, client_preferred_next_protocols, log_alert, server_name_indication, honor_cipher_order, padding_check, crl_check, crl_cache, - fallback], + fallback, signature_algs], SockOpts = lists:foldl(fun(Key, PropList) -> proplists:delete(Key, PropList) @@ -989,6 +993,18 @@ validate_option(crl_cache, {Cb, {_Handle, Options}} = Value) when is_atom(Cb) an validate_option(Opt, Value) -> throw({error, {options, {Opt, Value}}}). +handle_hashsigns_option(Value, {Major, Minor} = Version) when is_list(Value) + andalso Major >= 3 andalso Minor >= 3-> + case tls_v1:signature_algs(Version, Value) of + [] -> + throw({error, {options, no_supported_algorithms, {signature_algs, Value}}}); + _ -> + Value + end; +handle_hashsigns_option(_, {Major, Minor} = Version) when Major >= 3 andalso Minor >= 3-> + handle_hashsigns_option(tls_v1:default_signature_algs(Version), Version); +handle_hashsigns_option(_, _Version) -> + undefined. validate_options([]) -> []; @@ -1285,6 +1301,13 @@ new_ssl_options([{server_name_indication, Value} | Rest], #ssl_options{} = Opts, new_ssl_options(Rest, Opts#ssl_options{server_name_indication = validate_option(server_name_indication, Value)}, RecordCB); new_ssl_options([{honor_cipher_order, Value} | Rest], #ssl_options{} = Opts, RecordCB) -> new_ssl_options(Rest, Opts#ssl_options{honor_cipher_order = validate_option(honor_cipher_order, Value)}, RecordCB); +new_ssl_options([{signature_algs, Value} | Rest], #ssl_options{} = Opts, RecordCB) -> + new_ssl_options(Rest, + Opts#ssl_options{signature_algs = + handle_hashsigns_option(Value, + RecordCB:highest_protocol_version())}, + RecordCB); + new_ssl_options([{Key, Value} | _Rest], #ssl_options{}, _) -> throw({error, {options, {Key, Value}}}). diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index d737f74aa3..cbe3a2a056 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -43,11 +43,12 @@ -export_type([cipher_suite/0, erl_cipher_suite/0, openssl_cipher_suite/0, - key_algo/0]). + hash/0, key_algo/0, sign_algo/0]). -type cipher() :: null |rc4_128 | idea_cbc | des40_cbc | des_cbc | '3des_ede_cbc' | aes_128_cbc | aes_256_cbc | aes_128_gcm | aes_256_gcm | chacha20_poly1305. -type hash() :: null | sha | md5 | sha224 | sha256 | sha384 | sha512. +-type sign_algo() :: rsa | dsa | ecdsa. -type key_algo() :: null | rsa | dhe_rsa | dhe_dss | ecdhe_ecdsa| ecdh_ecdsa | ecdh_rsa| srp_rsa| srp_dss | psk | dhe_psk | rsa_psk | dh_anon | ecdh_anon | srp_anon. -type erl_cipher_suite() :: {key_algo(), cipher(), hash()} % Pre TLS 1.2 %% TLS 1.2, internally PRE TLS 1.2 will use default_prf diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index ec7d086934..f774873269 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -304,13 +304,9 @@ hello(#hello_request{}, #state{role = client} = State0, Connection) -> {Record, State} = Connection:next_record(State0), Connection:next_state(hello, hello, Record, State); -hello({common_client_hello, Type, ServerHelloExt, NegotiatedHashSign}, +hello({common_client_hello, Type, ServerHelloExt}, State, Connection) -> - do_server_hello(Type, ServerHelloExt, - %% Note NegotiatedHashSign is only negotiated for real if - %% if TLS version is at least TLS-1.2 - State#state{hashsign_algorithm = NegotiatedHashSign}, Connection); - + do_server_hello(Type, ServerHelloExt, State, Connection); hello(timeout, State, _) -> {next_state, hello, State, hibernate}; @@ -442,7 +438,8 @@ certify(#server_key_exchange{exchange_keys = Keys}, Alg == srp_dss; Alg == srp_rsa; Alg == srp_anon -> Params = ssl_handshake:decode_server_key(Keys, Alg, Version), - HashSign = negotiated_hashsign(Params#server_key_params.hashsign, Alg, Version), + %% Use negotiated value if TLS-1.2 otherwhise return default + HashSign = negotiated_hashsign(Params#server_key_params.hashsign, Alg, PubKeyInfo, Version), case is_anonymous(Alg) of true -> calculate_secret(Params#server_key_params.params, @@ -464,11 +461,18 @@ certify(#server_key_exchange{} = Msg, certify(#certificate_request{hashsign_algorithms = HashSigns}, #state{session = #session{own_certificate = Cert}, - negotiated_version = Version} = State0, Connection) -> - HashSign = ssl_handshake:select_hashsign(HashSigns, Cert, Version), - {Record, State} = Connection:next_record(State0#state{client_certificate_requested = true}), - Connection:next_state(certify, certify, Record, - State#state{cert_hashsign_algorithm = HashSign}); + key_algorithm = KeyExAlg, + ssl_options = #ssl_options{signature_algs = SupportedHashSigns}, + negotiated_version = Version} = State0, Connection) -> + + case ssl_handshake:select_hashsign(HashSigns, Cert, KeyExAlg, SupportedHashSigns, Version) of + #alert {} = Alert -> + Connection:handle_own_alert(Alert, Version, certify, State0); + NegotiatedHashSign -> + {Record, State} = Connection:next_record(State0#state{client_certificate_requested = true}), + Connection:next_state(certify, certify, Record, + State#state{cert_hashsign_algorithm = NegotiatedHashSign}) + end; %% PSK and RSA_PSK might bypass the Server-Key-Exchange certify(#server_hello_done{}, @@ -576,13 +580,15 @@ cipher(#hello_request{}, State0, Connection) -> cipher(#certificate_verify{signature = Signature, hashsign_algorithm = CertHashSign}, #state{role = server, - public_key_info = {Algo, _, _} =PublicKeyInfo, + key_algorithm = KexAlg, + public_key_info = PublicKeyInfo, negotiated_version = Version, session = #session{master_secret = MasterSecret}, tls_handshake_history = Handshake } = State0, Connection) -> - - HashSign = ssl_handshake:select_hashsign_algs(CertHashSign, Algo, Version), + + %% Use negotiated value if TLS-1.2 otherwhise return default + HashSign = negotiated_hashsign(CertHashSign, KexAlg, PublicKeyInfo, Version), case ssl_handshake:certificate_verify(Signature, PublicKeyInfo, Version, HashSign, MasterSecret, Handshake) of valid -> @@ -1448,7 +1454,8 @@ rsa_psk_key_exchange(Version, PskIdentity, PremasterSecret, PublicKeyInfo = {Alg rsa_psk_key_exchange(_, _, _, _) -> throw (?ALERT_REC(?FATAL,?HANDSHAKE_FAILURE)). -request_client_cert(#state{ssl_options = #ssl_options{verify = verify_peer}, +request_client_cert(#state{ssl_options = #ssl_options{verify = verify_peer, + signature_algs = SupportedHashSigns}, connection_states = ConnectionStates0, cert_db = CertDbHandle, cert_db_ref = CertDbRef, @@ -1456,7 +1463,9 @@ request_client_cert(#state{ssl_options = #ssl_options{verify = verify_peer}, #connection_state{security_parameters = #security_parameters{cipher_suite = CipherSuite}} = ssl_record:pending_connection_state(ConnectionStates0, read), - Msg = ssl_handshake:certificate_request(CipherSuite, CertDbHandle, CertDbRef, Version), + HashSigns = ssl_handshake:available_signature_algs(SupportedHashSigns, Version, [Version]), + Msg = ssl_handshake:certificate_request(CipherSuite, CertDbHandle, CertDbRef, + HashSigns, Version), State = Connection:send_handshake(Msg, State0), State#state{client_certificate_requested = true}; @@ -1881,15 +1890,16 @@ make_premaster_secret({MajVer, MinVer}, rsa) -> make_premaster_secret(_, _) -> undefined. -negotiated_hashsign(undefined, Alg, Version) -> +negotiated_hashsign(undefined, KexAlg, PubKeyInfo, Version) -> %% Not negotiated choose default - case is_anonymous(Alg) of + case is_anonymous(KexAlg) of true -> {null, anon}; false -> - ssl_handshake:select_hashsign_algs(Alg, Version) + {PubAlg, _, _} = PubKeyInfo, + ssl_handshake:select_hashsign_algs(undefined, PubAlg, Version) end; -negotiated_hashsign(HashSign = {_, _}, _, _) -> +negotiated_hashsign(HashSign = {_, _}, _, _, _) -> HashSign. ssl_options_list(SslOptions) -> diff --git a/lib/ssl/src/ssl_handshake.erl b/lib/ssl/src/ssl_handshake.erl index e98073080a..644903cf4b 100644 --- a/lib/ssl/src/ssl_handshake.erl +++ b/lib/ssl/src/ssl_handshake.erl @@ -46,7 +46,7 @@ %% Handshake messages -export([hello_request/0, server_hello/4, server_hello_done/0, - certificate/4, certificate_request/4, key_exchange/3, + certificate/4, certificate_request/5, key_exchange/3, finished/5, next_protocol/1]). %% Handle handshake messages @@ -64,8 +64,8 @@ ]). %% Cipher suites handling --export([available_suites/2, cipher_suites/2, - select_session/10, supported_ecc/1]). +-export([available_suites/2, available_signature_algs/3, cipher_suites/2, + select_session/11, supported_ecc/1]). %% Extensions handling -export([client_hello_extensions/6, @@ -74,8 +74,8 @@ ]). %% MISC --export([select_version/3, prf/5, select_hashsign/3, - select_hashsign_algs/2, select_hashsign_algs/3, +-export([select_version/3, prf/5, select_hashsign/5, + select_hashsign_algs/3, premaster_secret/2, premaster_secret/3, premaster_secret/4]). %%==================================================================== @@ -120,7 +120,8 @@ server_hello(SessionId, Version, ConnectionStates, Extensions) -> server_hello_done() -> #server_hello_done{}. -client_hello_extensions(Host, Version, CipherSuites, SslOpts, ConnectionStates, Renegotiation) -> +client_hello_extensions(Host, Version, CipherSuites, + #ssl_options{signature_algs = SupportedHashSigns, versions = AllVersions} = SslOpts, ConnectionStates, Renegotiation) -> {EcPointFormats, EllipticCurves} = case advertises_ec_ciphers(lists:map(fun ssl_cipher:suite_definition/1, CipherSuites)) of true -> @@ -134,7 +135,7 @@ client_hello_extensions(Host, Version, CipherSuites, SslOpts, ConnectionStates, renegotiation_info = renegotiation_info(tls_record, client, ConnectionStates, Renegotiation), srp = SRP, - hash_signs = advertised_hash_signs(Version), + signature_algs = available_signature_algs(SupportedHashSigns, Version, AllVersions), ec_point_formats = EcPointFormats, elliptic_curves = EllipticCurves, alpn = encode_alpn(SslOpts#ssl_options.alpn_advertised_protocols, Renegotiation), @@ -203,14 +204,14 @@ client_certificate_verify(OwnCert, MasterSecret, Version, end. %%-------------------------------------------------------------------- --spec certificate_request(ssl_cipher:cipher_suite(), db_handle(), certdb_ref(), ssl_record:ssl_version()) -> - #certificate_request{}. +-spec certificate_request(ssl_cipher:cipher_suite(), db_handle(), + certdb_ref(), #hash_sign_algos{}, ssl_record:ssl_version()) -> + #certificate_request{}. %% %% Description: Creates a certificate_request message, called by the server. %%-------------------------------------------------------------------- -certificate_request(CipherSuite, CertDbHandle, CertDbRef, Version) -> +certificate_request(CipherSuite, CertDbHandle, CertDbRef, HashSigns, Version) -> Types = certificate_types(ssl_cipher:suite_definition(CipherSuite), Version), - HashSigns = advertised_hash_signs(Version), Authorities = certificate_authorities(CertDbHandle, CertDbRef), #certificate_request{ certificate_types = Types, @@ -351,6 +352,9 @@ verify_server_key(#server_key_params{params_bin = EncParams, %% %% Description: Checks that the certificate_verify message is valid. %%-------------------------------------------------------------------- +certificate_verify(_, _, _, undefined, _, _) -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE); + certificate_verify(Signature, PublicKeyInfo, Version, HashSign = {HashAlgo, _}, MasterSecret, {_, Handshake}) -> Hash = calc_certificate_verify(Version, HashAlgo, MasterSecret, Handshake), @@ -379,10 +383,11 @@ verify_signature(_Version, Hash, _HashAlgo, Signature, {?rsaEncryption, PubKey, end; verify_signature(_Version, Hash, {HashAlgo, dsa}, Signature, {?'id-dsa', PublicKey, PublicKeyParams}) -> public_key:verify({digest, Hash}, HashAlgo, Signature, {PublicKey, PublicKeyParams}); -verify_signature(_Version, Hash, {HashAlgo, ecdsa}, Signature, +verify_signature(_, Hash, {HashAlgo, _SignAlg}, Signature, {?'id-ecPublicKey', PublicKey, PublicKeyParams}) -> public_key:verify({digest, Hash}, HashAlgo, Signature, {PublicKey, PublicKeyParams}). + %%-------------------------------------------------------------------- -spec certify(#certificate{}, db_handle(), certdb_ref(), integer() | nolimit, verify_peer | verify_none, {fun(), term}, fun(), term(), term(), @@ -573,43 +578,46 @@ prf({3,_N}, Secret, Label, Seed, WantedLength) -> %%-------------------------------------------------------------------- --spec select_hashsign(#hash_sign_algos{}| undefined, undefined | binary(), ssl_record:ssl_version()) -> - {atom(), atom()} | undefined. +-spec select_hashsign(#hash_sign_algos{} | undefined, undefined | binary(), + atom(), [atom()], ssl_record:ssl_version()) -> + {atom(), atom()} | undefined | #alert{}. %% -%% Description: +%% Description: Handles signature_algorithms extension %%-------------------------------------------------------------------- -select_hashsign(_, undefined, _Version) -> +select_hashsign(_, undefined, _, _, _Version) -> {null, anon}; %% The signature_algorithms extension was introduced with TLS 1.2. Ignore it if we have %% negotiated a lower version. -select_hashsign(#hash_sign_algos{hash_sign_algos = HashSigns}, Cert, {Major, Minor} = Version) - when Major >= 3 andalso Minor >= 3 -> - #'OTPCertificate'{tbsCertificate = TBSCert} =public_key:pkix_decode_cert(Cert, otp), +select_hashsign(HashSigns, Cert, KeyExAlgo, + undefined, {Major, Minor} = Version) when Major >= 3 andalso Minor >= 3-> + select_hashsign(HashSigns, Cert, KeyExAlgo, tls_v1:default_signature_algs(Version), Version); +select_hashsign(#hash_sign_algos{hash_sign_algos = HashSigns}, Cert, KeyExAlgo, SupportedHashSigns, + {Major, Minor}) when Major >= 3 andalso Minor >= 3 -> + #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), #'OTPSubjectPublicKeyInfo'{algorithm = {_,Algo, _}} = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, - DefaultHashSign = {_, Sign} = select_hashsign_algs(undefined, Algo, Version), - case lists:filter(fun({sha, dsa}) -> + Sign = cert_sign(Algo), + case lists:filter(fun({sha, dsa = S}) when S == Sign -> true; ({_, dsa}) -> false; - ({Hash, S}) when S == Sign -> - ssl_cipher:is_acceptable_hash(Hash, - proplists:get_value(hashs, crypto:supports())); + ({_, _} = Algos) -> + is_acceptable_hash_sign(Algos, Sign, KeyExAlgo, SupportedHashSigns); (_) -> false end, HashSigns) of [] -> - DefaultHashSign; - [HashSign| _] -> + ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY); + [HashSign | _] -> HashSign end; -select_hashsign(_, Cert, Version) -> +select_hashsign(_, Cert, _, _, Version) -> #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), #'OTPSubjectPublicKeyInfo'{algorithm = {_,Algo, _}} = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, select_hashsign_algs(undefined, Algo, Version). %%-------------------------------------------------------------------- --spec select_hashsign_algs(#hash_sign_algos{}| undefined, oid(), ssl_record:ssl_version()) -> +-spec select_hashsign_algs({atom(), atom()}| undefined, oid(), ssl_record:ssl_version()) -> {atom(), atom()}. %% Description: For TLS 1.2 hash function and signature algorithm pairs can be @@ -642,24 +650,6 @@ select_hashsign_algs(undefined, ?rsaEncryption, _) -> select_hashsign_algs(undefined, ?'id-dsa', _) -> {sha, dsa}. --spec select_hashsign_algs(atom(), ssl_record:ssl_version()) -> {atom(), atom()}. -%% Wrap function to keep the knowledge of the default values in -%% one place only -select_hashsign_algs(Alg, Version) when (Alg == rsa orelse - Alg == dhe_rsa orelse - Alg == dh_rsa orelse - Alg == ecdhe_rsa orelse - Alg == ecdh_rsa orelse - Alg == srp_rsa) -> - select_hashsign_algs(undefined, ?rsaEncryption, Version); -select_hashsign_algs(Alg, Version) when (Alg == dhe_dss orelse - Alg == dh_dss orelse - Alg == srp_dss) -> - select_hashsign_algs(undefined, ?'id-dsa', Version); -select_hashsign_algs(Alg, Version) when (Alg == ecdhe_ecdsa orelse - Alg == ecdh_ecdsa) -> - select_hashsign_algs(undefined, ?'id-ecPublicKey', Version). - %%-------------------------------------------------------------------- -spec master_secret(atom(), ssl_record:ssl_version(), #session{} | binary(), #connection_states{}, client | server) -> {binary(), #connection_states{}} | #alert{}. @@ -1063,9 +1053,56 @@ available_suites(UserSuites, Version) -> lists:member(Suite, ssl_cipher:all_suites(Version)) end, UserSuites). -available_suites(ServerCert, UserSuites, Version, Curve) -> +available_suites(ServerCert, UserSuites, Version, undefined, Curve) -> ssl_cipher:filter(ServerCert, available_suites(UserSuites, Version)) - -- unavailable_ecc_suites(Curve). + -- unavailable_ecc_suites(Curve); +available_suites(ServerCert, UserSuites, Version, HashSigns, Curve) -> + Suites = available_suites(ServerCert, UserSuites, Version, undefined, Curve), + filter_hashsigns(Suites, [ssl_cipher:suite_definition(Suite) || Suite <- Suites], HashSigns, []). +filter_hashsigns([], [], _, Acc) -> + lists:reverse(Acc); +filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, + Acc) when KeyExchange == dhe_ecdsa; + KeyExchange == ecdhe_ecdsa -> + do_filter_hashsigns(ecdsa, Suite, Suites, Algos, HashSigns, Acc); + +filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, + Acc) when KeyExchange == rsa; + KeyExchange == dhe_rsa; + KeyExchange == ecdhe_rsa; + KeyExchange == srp_rsa; + KeyExchange == rsa_psk -> + do_filter_hashsigns(rsa, Suite, Suites, Algos, HashSigns, Acc); +filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, Acc) when + KeyExchange == dhe_dss; + KeyExchange == srp_dss -> + do_filter_hashsigns(dsa, Suite, Suites, Algos, HashSigns, Acc); +filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, Acc) when + KeyExchange == dh_dss; + KeyExchange == dh_rsa; + KeyExchange == dh_ecdsa; + KeyExchange == ecdh_rsa; + KeyExchange == ecdh_ecdsa -> + %% Fixed DH certificates MAY be signed with any hash/signature + %% algorithm pair appearing in the hash_sign extension. The names + %% DH_DSS, DH_RSA, ECDH_ECDSA, and ECDH_RSA are historical. + filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]); +filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, Acc) when + KeyExchange == dh_anon; + KeyExchange == ecdh_anon; + KeyExchange == srp_anon; + KeyExchange == psk; + KeyExchange == dhe_psk -> + %% In this case hashsigns is not used as the kexchange is anonaymous + filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]). + +do_filter_hashsigns(SignAlgo, Suite, Suites, Algos, HashSigns, Acc) -> + case lists:keymember(SignAlgo, 2, HashSigns) of + true -> + filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]); + false -> + filter_hashsigns(Suites, Algos, HashSigns, Acc) + end. unavailable_ecc_suites(no_curve) -> ssl_cipher:ec_keyed_suites(); @@ -1077,17 +1114,17 @@ cipher_suites(Suites, false) -> cipher_suites(Suites, true) -> Suites. -select_session(SuggestedSessionId, CipherSuites, Compressions, Port, #session{ecc = ECCCurve} = +select_session(SuggestedSessionId, CipherSuites, HashSigns, Compressions, Port, #session{ecc = ECCCurve} = Session, Version, - #ssl_options{ciphers = UserSuites, honor_cipher_order = HCO} = SslOpts, + #ssl_options{ciphers = UserSuites, honor_cipher_order = HonorCipherOrder} = SslOpts, Cache, CacheCb, Cert) -> {SessionId, Resumed} = ssl_session:server_id(Port, SuggestedSessionId, SslOpts, Cert, Cache, CacheCb), case Resumed of undefined -> - Suites = available_suites(Cert, UserSuites, Version, ECCCurve), - CipherSuite = select_cipher_suite(CipherSuites, Suites, HCO), + Suites = available_suites(Cert, UserSuites, Version, HashSigns, ECCCurve), + CipherSuite = select_cipher_suite(CipherSuites, Suites, HonorCipherOrder), Compression = select_compression(Compressions), {new, Session#session{session_id = SessionId, cipher_suite = CipherSuite, @@ -1155,7 +1192,7 @@ handle_client_hello_extensions(RecordCB, Random, ClientCipherSuites, #hello_extensions{renegotiation_info = Info, srp = SRP, ec_point_formats = ECCFormat, - alpn = ALPN, + alpn = ALPN, next_protocol_negotiation = NextProtocolNegotiation}, Version, #ssl_options{secure_renegotiate = SecureRenegotation, alpn_preferred_protocols = ALPNPreferredProtocols} = Opts, @@ -1324,7 +1361,7 @@ handle_renegotiation_info(_RecordCB, ConnectionStates, SecureRenegotation) -> hello_extensions_list(#hello_extensions{renegotiation_info = RenegotiationInfo, srp = SRP, - hash_signs = HashSigns, + signature_algs = HashSigns, ec_point_formats = EcPointFormats, elliptic_curves = EllipticCurves, alpn = ALPN, @@ -1799,7 +1836,7 @@ dec_hello_extensions(<<?UINT16(?SIGNATURE_ALGORITHMS_EXT), ?UINT16(Len), <<?UINT16(SignAlgoListLen), SignAlgoList/binary>> = ExtData, HashSignAlgos = [{ssl_cipher:hash_algorithm(Hash), ssl_cipher:sign_algorithm(Sign)} || <<?BYTE(Hash), ?BYTE(Sign)>> <= SignAlgoList], - dec_hello_extensions(Rest, Acc#hello_extensions{hash_signs = + dec_hello_extensions(Rest, Acc#hello_extensions{signature_algs = #hash_sign_algos{hash_sign_algos = HashSignAlgos}}); dec_hello_extensions(<<?UINT16(?ELLIPTIC_CURVES_EXT), ?UINT16(Len), @@ -1899,7 +1936,7 @@ from_2bytes(<<?UINT16(N), Rest/binary>>, Acc) -> key_exchange_alg(rsa) -> ?KEY_EXCHANGE_RSA; key_exchange_alg(Alg) when Alg == dhe_rsa; Alg == dhe_dss; - Alg == dh_dss; Alg == dh_rsa; Alg == dh_anon -> + Alg == dh_dss; Alg == dh_rsa; Alg == dh_anon -> ?KEY_EXCHANGE_DIFFIE_HELLMAN; key_exchange_alg(Alg) when Alg == ecdhe_rsa; Alg == ecdh_rsa; Alg == ecdhe_ecdsa; Alg == ecdh_ecdsa; @@ -2008,27 +2045,16 @@ is_member(Suite, SupportedSuites) -> select_compression(_CompressionMetodes) -> ?NULL. --define(TLSEXT_SIGALG_RSA(MD), {MD, rsa}). --define(TLSEXT_SIGALG_DSA(MD), {MD, dsa}). --define(TLSEXT_SIGALG_ECDSA(MD), {MD, ecdsa}). - --define(TLSEXT_SIGALG(MD), ?TLSEXT_SIGALG_ECDSA(MD), ?TLSEXT_SIGALG_RSA(MD)). - -advertised_hash_signs({Major, Minor}) when Major >= 3 andalso Minor >= 3 -> - HashSigns = [?TLSEXT_SIGALG(sha512), - ?TLSEXT_SIGALG(sha384), - ?TLSEXT_SIGALG(sha256), - ?TLSEXT_SIGALG(sha224), - ?TLSEXT_SIGALG(sha), - ?TLSEXT_SIGALG_DSA(sha), - ?TLSEXT_SIGALG_RSA(md5)], - CryptoSupport = crypto:supports(), - HasECC = proplists:get_bool(ecdsa, proplists:get_value(public_keys, CryptoSupport)), - Hashs = proplists:get_value(hashs, CryptoSupport), - #hash_sign_algos{hash_sign_algos = - lists:filter(fun({Hash, ecdsa}) -> HasECC andalso proplists:get_bool(Hash, Hashs); - ({Hash, _}) -> proplists:get_bool(Hash, Hashs) end, HashSigns)}; -advertised_hash_signs(_) -> +available_signature_algs(undefined, _, _) -> + undefined; +available_signature_algs(SupportedHashSigns, {Major, Minor}, AllVersions) when Major >= 3 andalso Minor >= 3 -> + case tls_record:lowest_protocol_version(AllVersions) of + {3, 3} -> + #hash_sign_algos{hash_sign_algos = SupportedHashSigns}; + _ -> + undefined + end; +available_signature_algs(_, _, _) -> undefined. psk_secret(PSKIdentity, PSKLookup) -> @@ -2123,3 +2149,25 @@ distpoints_lookup([DistPoint | Rest], Callback, CRLDbHandle) -> CRLs -> [{DistPoint, {CRL, public_key:der_decode('CertificateList', CRL)}} || CRL <- CRLs] end. + +cert_sign(?rsaEncryption) -> + rsa; +cert_sign(?'id-ecPublicKey') -> + ecdsa; +cert_sign(?'id-dsa') -> + dsa; +cert_sign(Alg) -> + {_, Sign} =public_key:pkix_sign_types(Alg), + Sign. + +is_acceptable_hash_sign({_, Sign} = Algos, Sign, _, SupportedHashSigns) -> + is_acceptable_hash_sign(Algos, SupportedHashSigns); +is_acceptable_hash_sign(Algos,_, KeyExAlgo, SupportedHashSigns) when KeyExAlgo == dh_ecdsa; + KeyExAlgo == ecdh_rsa; + KeyExAlgo == ecdh_ecdsa -> + is_acceptable_hash_sign(Algos, SupportedHashSigns); +is_acceptable_hash_sign(_,_,_,_) -> + false. +is_acceptable_hash_sign(Algos, SupportedHashSigns) -> + lists:member(Algos, SupportedHashSigns). + diff --git a/lib/ssl/src/ssl_handshake.hrl b/lib/ssl/src/ssl_handshake.hrl index 58b4d5a23d..b74a65939b 100644 --- a/lib/ssl/src/ssl_handshake.hrl +++ b/lib/ssl/src/ssl_handshake.hrl @@ -95,7 +95,7 @@ -record(hello_extensions, { renegotiation_info, - hash_signs, % supported combinations of hashes/signature algos + signature_algs, % supported combinations of hashes/signature algos alpn, next_protocol_negotiation = undefined, % [binary()] srp, diff --git a/lib/ssl/src/ssl_internal.hrl b/lib/ssl/src/ssl_internal.hrl index 913746598f..9c52f5a315 100644 --- a/lib/ssl/src/ssl_internal.hrl +++ b/lib/ssl/src/ssl_internal.hrl @@ -135,7 +135,8 @@ padding_check = true :: boolean(), fallback = false :: boolean(), crl_check :: boolean() | peer | best_effort, - crl_cache + crl_cache, + signature_algs }). -record(socket_options, diff --git a/lib/ssl/src/ssl_tls_dist_proxy.erl b/lib/ssl/src/ssl_tls_dist_proxy.erl index 4c789793ec..8a39bde255 100644 --- a/lib/ssl/src/ssl_tls_dist_proxy.erl +++ b/lib/ssl/src/ssl_tls_dist_proxy.erl @@ -195,6 +195,11 @@ accept_loop(Proxy, erts = Type, Listen, Extra) -> {_Kernel, unsupported_protocol} -> exit(unsupported_protocol) end; + {error, closed} -> + %% The listening socket is closed: the proxy process is + %% shutting down. Exit normally, to avoid generating a + %% spurious error report. + exit(normal); Error -> exit(Error) end, diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index c3f0206d25..93716d31b8 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -182,8 +182,7 @@ hello(start, #state{host = Host, port = Port, role = client, next_state(hello, hello, Record, State); hello(Hello = #client_hello{client_version = ClientVersion, - extensions = #hello_extensions{hash_signs = HashSigns, - ec_point_formats = EcPointFormats, + extensions = #hello_extensions{ec_point_formats = EcPointFormats, elliptic_curves = EllipticCurves}}, State = #state{connection_states = ConnectionStates0, port = Port, session = #session{own_certificate = Cert} = Session0, @@ -191,27 +190,28 @@ hello(Hello = #client_hello{client_version = ClientVersion, session_cache = Cache, session_cache_cb = CacheCb, negotiated_protocol = CurrentProtocol, + key_algorithm = KeyExAlg, ssl_options = SslOpts}) -> + case tls_handshake:hello(Hello, SslOpts, {Port, Session0, Cache, CacheCb, - ConnectionStates0, Cert}, Renegotiation) of + ConnectionStates0, Cert, KeyExAlg}, Renegotiation) of #alert{} = Alert -> handle_own_alert(Alert, ClientVersion, hello, State); {Version, {Type, Session}, - ConnectionStates, Protocol0, ServerHelloExt} -> - + ConnectionStates, Protocol0, ServerHelloExt, HashSign} -> Protocol = case Protocol0 of - undefined -> CurrentProtocol; - _ -> Protocol0 - end, - - HashSign = ssl_handshake:select_hashsign(HashSigns, Cert, Version), - ssl_connection:hello({common_client_hello, Type, ServerHelloExt, HashSign}, + undefined -> CurrentProtocol; + _ -> Protocol0 + end, + ssl_connection:hello({common_client_hello, Type, ServerHelloExt}, State#state{connection_states = ConnectionStates, negotiated_version = Version, + hashsign_algorithm = HashSign, session = Session, client_ecc = {EllipticCurves, EcPointFormats}, negotiated_protocol = Protocol}, ?MODULE) end; + hello(Hello = #server_hello{}, #state{connection_states = ConnectionStates0, negotiated_version = ReqVersion, @@ -1069,3 +1069,4 @@ handle_sni_extension(#client_hello{extensions = HelloExtensions}, State0) -> end; handle_sni_extension(_, State0) -> State0. + diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index 0a6cb9f92d..ef718c13df 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -56,7 +56,7 @@ client_hello(Host, Port, ConnectionStates, Version = tls_record:highest_protocol_version(Versions), Pending = ssl_record:pending_connection_state(ConnectionStates, read), SecParams = Pending#connection_state.security_parameters, - AvailableCipherSuites = ssl_handshake:available_suites(UserSuites, Version), + AvailableCipherSuites = ssl_handshake:available_suites(UserSuites, Version), Extensions = ssl_handshake:client_hello_extensions(Host, Version, AvailableCipherSuites, SslOpts, ConnectionStates, Renegotiation), @@ -80,13 +80,13 @@ client_hello(Host, Port, ConnectionStates, -spec hello(#server_hello{} | #client_hello{}, #ssl_options{}, #connection_states{} | {inet:port_number(), #session{}, db_handle(), atom(), #connection_states{}, - binary() | undefined}, + binary() | undefined, ssl_cipher:key_algo()}, boolean()) -> {tls_record:tls_version(), session_id(), #connection_states{}, alpn | npn, binary() | undefined}| {tls_record:tls_version(), {resumed | new, #session{}}, #connection_states{}, binary() | undefined, - #hello_extensions{}} | + #hello_extensions{}, {ssl_cipher:hash(), ssl_cipher:sign_algo()} | undefined} | #alert{}. %% %% Description: Handles a recieved hello message @@ -149,26 +149,35 @@ get_tls_handshake(Version, Data, Buffer) -> %%% Internal functions %%-------------------------------------------------------------------- handle_client_hello(Version, #client_hello{session_id = SugesstedId, - cipher_suites = CipherSuites, - compression_methods = Compressions, - random = Random, - extensions = #hello_extensions{elliptic_curves = Curves} = HelloExt}, - #ssl_options{versions = Versions} = SslOpts, - {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert}, Renegotiation) -> + cipher_suites = CipherSuites, + compression_methods = Compressions, + random = Random, + extensions = #hello_extensions{elliptic_curves = Curves, + signature_algs = ClientHashSigns} = HelloExt}, + #ssl_options{versions = Versions, + signature_algs = SupportedHashSigns} = SslOpts, + {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, _}, Renegotiation) -> case tls_record:is_acceptable_version(Version, Versions) of true -> + AvailableHashSigns = available_signature_algs(ClientHashSigns, SupportedHashSigns, Cert, Version), ECCCurve = ssl_handshake:select_curve(Curves, ssl_handshake:supported_ecc(Version)), {Type, #session{cipher_suite = CipherSuite} = Session1} - = ssl_handshake:select_session(SugesstedId, CipherSuites, Compressions, + = ssl_handshake:select_session(SugesstedId, CipherSuites, AvailableHashSigns, Compressions, Port, Session0#session{ecc = ECCCurve}, Version, SslOpts, Cache, CacheCb, Cert), case CipherSuite of no_suite -> ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY); _ -> - handle_client_hello_extensions(Version, Type, Random, CipherSuites, HelloExt, - SslOpts, Session1, ConnectionStates0, - Renegotiation) + {KeyExAlg,_,_,_} = ssl_cipher:suite_definition(CipherSuite), + case ssl_handshake:select_hashsign(ClientHashSigns, Cert, KeyExAlg, SupportedHashSigns, Version) of + #alert{} = Alert -> + Alert; + HashSign -> + handle_client_hello_extensions(Version, Type, Random, CipherSuites, HelloExt, + SslOpts, Session1, ConnectionStates0, + Renegotiation, HashSign) + end end; false -> ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION) @@ -245,14 +254,14 @@ enc_handshake(HandshakeMsg, Version) -> handle_client_hello_extensions(Version, Type, Random, CipherSuites, - HelloExt, SslOpts, Session0, ConnectionStates0, Renegotiation) -> + HelloExt, SslOpts, Session0, ConnectionStates0, Renegotiation, HashSign) -> try ssl_handshake:handle_client_hello_extensions(tls_record, Random, CipherSuites, HelloExt, Version, SslOpts, Session0, ConnectionStates0, Renegotiation) of #alert{} = Alert -> Alert; {Session, ConnectionStates, Protocol, ServerHelloExt} -> - {Version, {Type, Session}, ConnectionStates, Protocol, ServerHelloExt} + {Version, {Type, Session}, ConnectionStates, Protocol, ServerHelloExt, HashSign} catch throw:Alert -> Alert end. @@ -269,3 +278,12 @@ handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, {Version, SessionId, ConnectionStates, ProtoExt, Protocol} end. +available_signature_algs(undefined, SupportedHashSigns, _, {Major, Minor}) when (Major < 3) andalso (Minor < 3) -> + SupportedHashSigns; +available_signature_algs(#hash_sign_algos{hash_sign_algos = ClientHashSigns}, SupportedHashSigns, + _, {Major, Minor}) when (Major < 3) andalso (Minor < 3) -> + ordsets:intersection(ClientHashSigns, SupportedHashSigns); +available_signature_algs(_, _, _, _) -> + undefined. + + diff --git a/lib/ssl/src/tls_v1.erl b/lib/ssl/src/tls_v1.erl index 09e378cfeb..03cef633d5 100644 --- a/lib/ssl/src/tls_v1.erl +++ b/lib/ssl/src/tls_v1.erl @@ -31,7 +31,8 @@ -export([master_secret/4, finished/5, certificate_verify/3, mac_hash/7, setup_keys/8, suites/1, prf/5, - ecc_curves/1, oid_to_enum/1, enum_to_oid/1]). + ecc_curves/1, oid_to_enum/1, enum_to_oid/1, + default_signature_algs/1, signature_algs/2]). %%==================================================================== %% Internal application API @@ -256,6 +257,52 @@ suites(3) -> ] ++ suites(2). + +signature_algs({3, 3}, HashSigns) -> + CryptoSupports = crypto:supports(), + Hashes = proplists:get_value(hashs, CryptoSupports), + PubKeys = proplists:get_value(public_keys, CryptoSupports), + Supported = lists:foldl(fun({Hash, dsa = Sign} = Alg, Acc) -> + case proplists:get_bool(dss, PubKeys) + andalso proplists:get_bool(Hash, Hashes) + andalso is_pair(Hash, Sign, Hashes) + of + true -> + [Alg | Acc]; + false -> + Acc + end; + ({Hash, Sign} = Alg, Acc) -> + case proplists:get_bool(Sign, PubKeys) + andalso proplists:get_bool(Hash, Hashes) + andalso is_pair(Hash, Sign, Hashes) + of + true -> + [Alg | Acc]; + false -> + Acc + end + end, [], HashSigns), + lists:reverse(Supported). + +default_signature_algs({3, 3} = Version) -> + Default = [%% SHA2 + {sha512, ecdsa}, + {sha512, rsa}, + {sha384, ecdsa}, + {sha384, rsa}, + {sha256, ecdsa}, + {sha256, rsa}, + {sha224, ecdsa}, + {sha224, rsa}, + %% SHA + {sha, ecdsa}, + {sha, rsa}, + {sha, dsa}], + signature_algs(Version, Default); +default_signature_algs(_) -> + undefined. + %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- @@ -340,6 +387,17 @@ finished_label(client) -> finished_label(server) -> <<"server finished">>. +is_pair(sha, dsa, _) -> + true; +is_pair(_, dsa, _) -> + false; +is_pair(Hash, ecdsa, Hashs) -> + AtLeastSha = Hashs -- [md2,md4,md5], + lists:member(Hash, AtLeastSha); +is_pair(Hash, rsa, Hashs) -> + AtLeastMd5 = Hashs -- [md2,md4], + lists:member(Hash, AtLeastMd5). + %% list ECC curves in prefered order ecc_curves(_Minor) -> TLSCurves = [sect571r1,sect571k1,secp521r1,brainpoolP512r1, diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index f2cf99e8a8..f045d50cce 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -58,7 +58,7 @@ all() -> groups() -> [{basic, [], basic_tests()}, {options, [], options_tests()}, - {'tlsv1.2', [], all_versions_groups()}, + {'tlsv1.2', [], all_versions_groups() ++ [conf_signature_algs, no_common_signature_algs]}, {'tlsv1.1', [], all_versions_groups()}, {'tlsv1', [], all_versions_groups() ++ rizzo_tests()}, {'sslv3', [], all_versions_groups() ++ rizzo_tests() ++ [ciphersuite_vs_version]}, @@ -2900,7 +2900,61 @@ ciphersuite_vs_version(Config) when is_list(Config) -> _ -> ct:fail({unexpected_server_hello, ServerHello}) end. - + +%%-------------------------------------------------------------------- +conf_signature_algs() -> + [{doc,"Test to set the signature_algs option on both client and server"}]. +conf_signature_algs(Config) when is_list(Config) -> + ClientOpts = ?config(client_opts, Config), + ServerOpts = ?config(server_opts, Config), + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + Server = + ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {ssl_test_lib, send_recv_result, []}}, + {options, [{active, false}, {signature_algs, [{sha256, rsa}]} | ServerOpts]}]), + Port = ssl_test_lib:inet_port(Server), + Client = + ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, send_recv_result, []}}, + {options, [{active, false}, {signature_algs, [{sha256, rsa}]} | ClientOpts]}]), + + ct:log("Testcase ~p, Client ~p Server ~p ~n", + [self(), Client, Server]), + + ssl_test_lib:check_result(Server, ok, Client, ok), + + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). + + +%%-------------------------------------------------------------------- +no_common_signature_algs() -> + [{doc,"Set the signature_algs option so that there client and server does not share any hash sign algorithms"}]. +no_common_signature_algs(Config) when is_list(Config) -> + + ClientOpts = ?config(client_opts, Config), + ServerOpts = ?config(server_opts, Config), + + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + + + Server = ssl_test_lib:start_server_error([{node, ServerNode}, {port, 0}, + {from, self()}, + {options, [{signature_algs, [{sha256, rsa}]} + | ServerOpts]}]), + Port = ssl_test_lib:inet_port(Server), + Client = ssl_test_lib:start_client_error([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {options, [{signature_algs, [{sha384, rsa}]} + | ClientOpts]}]), + + ssl_test_lib:check_result(Server, {error, {tls_alert, "insufficient security"}}, + Client, {error, {tls_alert, "insufficient security"}}). + %%-------------------------------------------------------------------- dont_crash_on_handshake_garbage() -> diff --git a/lib/ssl/test/ssl_handshake_SUITE.erl b/lib/ssl/test/ssl_handshake_SUITE.erl index b0bb77c598..d050812208 100644 --- a/lib/ssl/test/ssl_handshake_SUITE.erl +++ b/lib/ssl/test/ssl_handshake_SUITE.erl @@ -166,10 +166,10 @@ ignore_hassign_extension_pre_tls_1_2(Config) -> CertFile = proplists:get_value(certfile, Opts), [{_, Cert, _}] = ssl_test_lib:pem_to_der(CertFile), HashSigns = #hash_sign_algos{hash_sign_algos = [{sha512, rsa}, {sha, dsa}]}, - {sha512, rsa} = ssl_handshake:select_hashsign(HashSigns, Cert, {3,3}), + {sha512, rsa} = ssl_handshake:select_hashsign(HashSigns, Cert, ecdhe_rsa, tls_v1:default_signature_algs({3,3}), {3,3}), %%% Ignore - {md5sha, rsa} = ssl_handshake:select_hashsign(HashSigns, Cert, {3,2}), - {md5sha, rsa} = ssl_handshake:select_hashsign(HashSigns, Cert, {3,0}). + {md5sha, rsa} = ssl_handshake:select_hashsign(HashSigns, Cert, ecdhe_rsa, tls_v1:default_signature_algs({3,2}), {3,2}), + {md5sha, rsa} = ssl_handshake:select_hashsign(HashSigns, Cert, ecdhe_rsa, tls_v1:default_signature_algs({3,0}), {3,0}). is_supported(Hash) -> Algos = crypto:supports(), diff --git a/lib/stdlib/test/error_logger_h_SUITE.erl b/lib/stdlib/test/error_logger_h_SUITE.erl index 30811f3fb4..9828a075cc 100644 --- a/lib/stdlib/test/error_logger_h_SUITE.erl +++ b/lib/stdlib/test/error_logger_h_SUITE.erl @@ -65,11 +65,18 @@ logfile(Config) -> error_logger:logfile(close), analyse_events(Log, Ev, [AtNode], unlimited), - [] = [{X, file:pid2name(X)} || X <- processes(), Data <- [process_info(X, [current_function])], - Data =/= undefined, - element(1, element(2, lists:keyfind(current_function, 1, Data))) - =:= file_io_server, - file:pid2name(X) =:= {ok, Log}], + %% Make sure that the file_io_server process has been stopped + [] = lists:filtermap( + fun(X) -> + case {process_info(X, [current_function]), + file:pid2name(X)} of + {[{current_function, {file_io_server, _, _}}], + {ok,P2N = Log}} -> + {true, {X, P2N}}; + _ -> + false + end + end, processes()), test_server:stop_node(Node), @@ -112,7 +119,7 @@ tty(Config) -> do_one_tty(Log, Ev, unlimited), Pa = "-pa " ++ filename:dirname(code:which(?MODULE)), - {ok,Node} = start_node(logfile, Pa), + {ok,Node} = start_node(tty, Pa), tty_log_open(Log), ok = rpc:call(Node, erlang, apply, [fun gen_events/1,[Ev]]), tty_log_close(), diff --git a/system/doc/design_principles/sup_princ.xml b/system/doc/design_principles/sup_princ.xml index 5e2f6ba9cb..08c4b7c59e 100644 --- a/system/doc/design_principles/sup_princ.xml +++ b/system/doc/design_principles/sup_princ.xml @@ -229,7 +229,7 @@ child_spec() = #{id => child_id(), % mandatory is <c>rest_for_one</c> or <c>one_for_all</c> and a sibling death causes the temporary process to be terminated).</item> <item>A <c>transient</c> child process is restarted only if it - terminates abnormally, that is, with another exit reason than + terminates abnormally, that is, with an exit reason other than <c>normal</c>, <c>shutdown</c>, or <c>{shutdown,Term}</c>.</item> </list> <p>The <c>restart</c> key is optional. If it is not given, the diff --git a/system/doc/programming_examples/funs.xmlsrc b/system/doc/programming_examples/funs.xmlsrc index 8469f0871c..1e1002ccf9 100644 --- a/system/doc/programming_examples/funs.xmlsrc +++ b/system/doc/programming_examples/funs.xmlsrc @@ -212,7 +212,7 @@ f(...) -> ... end, ...) ...</code> - <p>instead of writng the following code:</p> + <p>instead of writing the following code:</p> <code type="none"> f(...) -> Y = ... diff --git a/system/doc/top/templates/index.html.src b/system/doc/top/templates/index.html.src index bdac3895b0..ef2e2916a4 100644 --- a/system/doc/top/templates/index.html.src +++ b/system/doc/top/templates/index.html.src @@ -145,10 +145,10 @@ verification, comment support including paragraph filling, skeletons, tags support and more. See the <a href="#tools#/index.html"> Tools</a> application for details. <p> -There is also an -<a href="http://erlide.org/index.html"> -Erlang plugin (ErlIDE) for Eclipse</a> if you prefer a more graphical -environment. ErlIDE is under active development with new features in almost every release. +There are also Erlang plugins for +<a href="http://erlide.org/index.html">Eclipse (ErlIDE)</a> and +<a href="http://ignatov.github.io/intellij-erlang/">IntelliJ IDEA</a> +if you prefer a more graphical environment, which are both under active development. <li>When developing with Erlang/OTP you usually test your programs from the interactive shell (see <a href="getting_started/users_guide.html"> Getting Started With Erlang</a>) where you can call individual |