diff options
| author | Micael Karlberg <[email protected]> | 2013-11-13 17:20:31 +0100 |
|---|---|---|
| committer | Micael Karlberg <[email protected]> | 2013-11-13 17:20:31 +0100 |
| commit | 8bcd32dfceec3b4381747046b82eec42487c7518 (patch) | |
| tree | cca7f396b6b3bd98950e5fc7713dfc9988633b10 | |
| parent | dc6f086a0751677da8724df397a062ab154f34cb (diff) | |
| parent | b166476d2674c056ed5f737170074e71fbdc4bfd (diff) | |
| download | otp-8bcd32dfceec3b4381747046b82eec42487c7518.tar.gz otp-8bcd32dfceec3b4381747046b82eec42487c7518.tar.bz2 otp-8bcd32dfceec3b4381747046b82eec42487c7518.zip | |
Merge branch 'bmk/snmp/handling_corrupt_atl_when_converting/r16/OTP-11453' into bmk/snmp/snmp425_integration
Conflicts:
lib/snmp/src/misc/snmp_log.erl
187 files changed, 5834 insertions, 1922 deletions
diff --git a/HOWTO/INSTALL-CROSS.md b/HOWTO/INSTALL-CROSS.md index a5cf775583..03ea4c6e76 100644 --- a/HOWTO/INSTALL-CROSS.md +++ b/HOWTO/INSTALL-CROSS.md @@ -515,6 +515,11 @@ When a variable has been set, no warning will be issued. * `erl_xcomp_reliable_fpe` - `yes|no`. Defaults to `no`. If `yes`, the target system must have reliable floating point exceptions. +* `erl_xcomp_posix_memalign` - `yes|no`. Defaults to `yes` if `posix_memalign` + system call exists; otherwise `no`. If `yes`, the target system must have a + `posix_memalign` implementation that accepts larger than page size + alignment. + Copyright and License --------------------- diff --git a/HOWTO/INSTALL.md b/HOWTO/INSTALL.md index 5bde47e1f6..07a8db1a53 100644 --- a/HOWTO/INSTALL.md +++ b/HOWTO/INSTALL.md @@ -217,6 +217,7 @@ Step 4: Run the following commands to configure the build: $ ./configure [ options ] +If you are building it from git you will need to run `autoconf` to generate configure file. By default, Erlang/OTP will be installed in `/usr/local/{bin,lib/erlang}`. To instead install in `<BaseDir>/{bin,lib/erlang}`, use the `--prefix=<BaseDir>` option. diff --git a/bootstrap/lib/compiler/ebin/beam_validator.beam b/bootstrap/lib/compiler/ebin/beam_validator.beam Binary files differindex 6b8673cb82..b8a3491caa 100644 --- a/bootstrap/lib/compiler/ebin/beam_validator.beam +++ b/bootstrap/lib/compiler/ebin/beam_validator.beam diff --git a/bootstrap/lib/kernel/ebin/gen_sctp.beam b/bootstrap/lib/kernel/ebin/gen_sctp.beam Binary files differindex 1f33d85cb2..e1384d1b5e 100644 --- a/bootstrap/lib/kernel/ebin/gen_sctp.beam +++ b/bootstrap/lib/kernel/ebin/gen_sctp.beam diff --git a/erts/configure.in b/erts/configure.in index f17f4cb5c8..8288a1aab1 100644 --- a/erts/configure.in +++ b/erts/configure.in @@ -1974,11 +1974,39 @@ AC_CHECK_FUNCS([getipnodebyname getipnodebyaddr gethostbyname2]) AC_CHECK_FUNCS([ieee_handler fpsetmask finite isnan isinf res_gethostbyname dlopen \ pread pwrite memmove strerror strerror_r strncasecmp \ - gethrtime localtime_r gmtime_r inet_pton posix_memalign \ + gethrtime localtime_r gmtime_r inet_pton \ mmap mremap memcpy mallopt sbrk _sbrk __sbrk brk _brk __brk \ flockfile fstat strlcpy strlcat setsid posix2time time2posix \ setlocale nl_langinfo poll]) + +case X$erl_xcomp_posix_memalign in + Xno) ;; + Xyes) AC_DEFINE(HAVE_POSIX_MEMALIGN,[1], + [Define to 1 if you have the `posix_memalign' function.]) ;; + *) + AC_CHECK_FUNC( + [posix_memalign], + [if test "$cross_compiling" != yes; then +AC_TRY_RUN([ +#include <stdlib.h> +int main(void) { + void *ptr = NULL; + int error; + size_t alignment = 0x40000, size = 0x20028; + if ((error = posix_memalign(&ptr, alignment, size)) != 0 || ptr == NULL) + return error; + return 0; +} +],AC_DEFINE(HAVE_POSIX_MEMALIGN,[1], + [Define to 1 if you have the `posix_memalign' function.]) +) + else + AC_DEFINE(HAVE_POSIX_MEMALIGN,[1], + [Define to 1 if you have the `posix_memalign' function.]) + fi]);; +esac + dnl writev on OS X snow leopard is broken for files > 4GB case $host_os in darwin10.8.0) diff --git a/erts/doc/src/erlang.xml b/erts/doc/src/erlang.xml index d3b21de8cf..bc38055b62 100644 --- a/erts/doc/src/erlang.xml +++ b/erts/doc/src/erlang.xml @@ -2467,7 +2467,7 @@ os_prompt% </pre> fails, a <c>nodedown</c> message is delivered.</p> <p>Nodes connected through hidden connections can be monitored as any other node.</p> - <p>Failure: <c>badarg</c>if the local node is not alive.</p> + <p>Failure: <c>badarg</c> if the local node is not alive.</p> </desc> </func> <func> diff --git a/erts/doc/src/erts_alloc.xml b/erts/doc/src/erts_alloc.xml index 6ce2261430..9dab5b3876 100644 --- a/erts/doc/src/erts_alloc.xml +++ b/erts/doc/src/erts_alloc.xml @@ -271,6 +271,65 @@ memory segment cache is not reused if its size exceeds the requested size with more than relative max cache bad fit percent of the requested size. Default value is 20.</item> + <tag><marker id="MMscmgc"><c><![CDATA[+MMscmgc <amount>]]></c></marker></tag> + <item> + Set <seealso marker="#MMscs">super carrier</seealso> max guaranteed + no of carriers. This parameter defaults to <c>65536</c>. This + parameter determines an amount of pre-allocated structures that is + needed in order to keep track of different areas in the super carrier. + When the system runs out of such structures it may crash due to an + out of memory condition. + </item> + <tag><marker id="MMsco"><c><![CDATA[+MMsco true|false]]></c></marker></tag> + <item> + Set <seealso marker="#MMscs">super carrier</seealso> only flag. This + flag defaults to <c>true</c>. When a super carrier is used and this + flag is <c>true</c>, the system will crash when a carrier request + cannot be satisfied by the super carrier. When the flag is <c>false</c> + the system will try to create requested carrier by other means. + <br/><br/> + <em>NOTE</em>: Setting this flag to <c>false</c> may not be supported + on all systems. This flag will in that case be ignored. + <br/><br/> + <em>NOTE</em>: The super carrier cannot be enabled nor + disabled on halfword heap systems. This flag will be + ignored on halfword heap systems. + </item> + <tag><marker id="MMscrpm"><c><![CDATA[+MMscrpm true|false]]></c></marker></tag> + <item> + Set <seealso marker="#MMscs">super carrier</seealso> reserve physical + memory flag. This flag defaults to <c>true</c>. When this flag is + <c>true</c>, physical memory will be reserved for the whole super + carrier at once when it is created. The reservation will after that + be left unchanged. When this flag is set to <c>false</c> only virtual + address space will be reserved for the super carrier upon creation. + The system will attempt to reserve physical memory upon carrier + creations in the super carrier, and attempt to unreserve physical + memory upon carrier destructions in the super carrier. + <br/><br/> + <em>NOTE</em>: What reservation of physical memory actually means + highly depends on the operating system, and how it is configured. For + example, different memory overcommit settings on Linux drastically + change the behaviour. Also note, setting this flag to <c>false</c> + may not be supported on all systems. This flag will in that case + be ignored. + <br/><br/> + <em>NOTE</em>: The super carrier cannot be enabled nor + disabled on halfword heap systems. This flag will be + ignored on halfword heap systems. + </item> + <tag><marker id="MMscs"><c><![CDATA[+MMscs <size in MB>]]></c></marker></tag> + <item> + Set super carrier size (in MB). The super carrier size defaults to + zero; i.e, the super carrier is by default disabled. The super + carrier is a large continuous area in the virtual address space. + The system will always try to create new carriers in the super + carrier. + <br/><br/> + <em>NOTE</em>: The super carrier cannot be enabled nor + disabled on halfword heap systems. This flag will be + ignored on halfword heap systems. + </item> <tag><marker id="MMmcs"><c><![CDATA[+MMmcs <amount>]]></c></marker></tag> <item> Max cached segments. The maximum number of memory segments diff --git a/erts/emulator/Makefile.in b/erts/emulator/Makefile.in index 9751982103..f442540f49 100644 --- a/erts/emulator/Makefile.in +++ b/erts/emulator/Makefile.in @@ -808,6 +808,7 @@ OS_OBJS += $(OBJDIR)/erl_poll.o \ endif OS_OBJS += $(OBJDIR)/erl_mseg.o \ + $(OBJDIR)/erl_mmap.o \ $(OBJDIR)/erl_$(ERLANG_OSTYPE)_sys_ddll.o \ $(OBJDIR)/erl_mtrace_sys_wrap.o \ $(OBJDIR)/erl_sys_common_misc.o diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c index da36c4437e..78ab6fa30f 100644 --- a/erts/emulator/beam/beam_emu.c +++ b/erts/emulator/beam/beam_emu.c @@ -5654,7 +5654,6 @@ build_stacktrace(Process* c_p, Eterm exc) { return res; } - static BeamInstr* call_error_handler(Process* p, BeamInstr* fi, Eterm* reg, Eterm func) { @@ -5702,7 +5701,6 @@ call_error_handler(Process* p, BeamInstr* fi, Eterm* reg, Eterm func) return ep->addressv[erts_active_code_ix()]; } - static Export* apply_setup_error_handler(Process* p, Eterm module, Eterm function, Uint arity, Eterm* reg) { @@ -6208,7 +6206,6 @@ new_fun(Process* p, Eterm* reg, ErlFunEntry* fe, int num_free) return make_fun(funp); } - int catchlevel(Process *p) { diff --git a/erts/emulator/beam/beam_load.c b/erts/emulator/beam/beam_load.c index 4193eb4f3f..938fd8f2c9 100644 --- a/erts/emulator/beam/beam_load.c +++ b/erts/emulator/beam/beam_load.c @@ -535,7 +535,6 @@ static int must_swap_floats; Uint erts_total_code_size; /**********************************************************************/ - void init_load(void) { FloatDef f; @@ -1209,7 +1208,6 @@ verify_chunks(LoaderState* stp) return 0; } - static int load_atom_table(LoaderState* stp) { @@ -1255,7 +1253,6 @@ load_atom_table(LoaderState* stp) return 0; } - static int load_import_table(LoaderState* stp) { @@ -1308,7 +1305,6 @@ load_import_table(LoaderState* stp) return 0; } - static int read_export_table(LoaderState* stp) { @@ -1641,7 +1637,6 @@ read_line_table(LoaderState* stp) return 0; } - static int read_code_header(LoaderState* stp) { @@ -1711,7 +1706,6 @@ read_code_header(LoaderState* stp) return 0; } - #define VerifyTag(Stp, Actual, Expected) \ if (Actual != Expected) { \ LoadError2(Stp, "bad tag %d; expected %d", Actual, Expected); \ @@ -1730,7 +1724,6 @@ read_code_header(LoaderState* stp) #define TermWords(t) (((t) / (sizeof(BeamInstr)/sizeof(Eterm))) + !!((t) % (sizeof(BeamInstr)/sizeof(Eterm)))) - static int load_code(LoaderState* stp) { @@ -2512,7 +2505,6 @@ load_code(LoaderState* stp) return retval; } - #define succ(St, X, Y) ((X).type == (Y).type && (X).val + 1 == (Y).val) #define succ2(St, X, Y) ((X).type == (Y).type && (X).val + 2 == (Y).val) #define succ3(St, X, Y) ((X).type == (Y).type && (X).val + 3 == (Y).val) @@ -3958,7 +3950,6 @@ tuple_append_put(LoaderState* stp, GenOpArg Arity, GenOpArg Dst, } - /* * Freeze the code in memory, move the string table into place, * resolve all labels. @@ -4276,7 +4267,6 @@ freeze_code(LoaderState* stp) return 0; } - static void final_touch(LoaderState* stp) { @@ -4378,7 +4368,6 @@ final_touch(LoaderState* stp) } } - static int transform_engine(LoaderState* st) { @@ -4716,7 +4705,6 @@ transform_engine(LoaderState* st) return rval; } - static void short_file(int line, LoaderState* stp, unsigned needed) { @@ -4724,7 +4712,6 @@ short_file(int line, LoaderState* stp, unsigned needed) stp->file_name, needed); } - static void load_printf(int line, LoaderState* context, char *fmt,...) { @@ -5190,7 +5177,6 @@ native_addresses(Process* p, Eterm mod) return result; } - /* * Builds a list of all exported functions in the given module: * [{Name, Arity},...] @@ -5240,7 +5226,6 @@ exported_from_module(Process* p, /* Process whose heap to use. */ return result; } - /* * Returns a list of all attributes for the module. * @@ -5281,7 +5266,6 @@ attributes_for_module(Process* p, /* Process whose heap to use. */ return result; } - /* * Returns a list containing compilation information. * diff --git a/erts/emulator/beam/big.c b/erts/emulator/beam/big.c index 6b43c53985..2b27b111d8 100644 --- a/erts/emulator/beam/big.c +++ b/erts/emulator/beam/big.c @@ -1325,9 +1325,9 @@ static dsize_t I_lshift(ErtsDigit* x, dsize_t xl, Sint y, return 1; } else { - SWord ay = (y < 0) ? -y : y; - int bw = ay / D_EXP; - int sw = ay % D_EXP; + Uint ay = (y < 0) ? -y : y; + Uint bw = ay / D_EXP; + Uint sw = ay % D_EXP; dsize_t rl; ErtsDigit a1=0; ErtsDigit a0=0; @@ -1368,7 +1368,7 @@ static dsize_t I_lshift(ErtsDigit* x, dsize_t xl, Sint y, } if (sign) { - int zl = bw; + Uint zl = bw; ErtsDigit* z = x; while(zl--) { diff --git a/erts/emulator/beam/break.c b/erts/emulator/beam/break.c index ad9a89b642..99604fa3bc 100644 --- a/erts/emulator/beam/break.c +++ b/erts/emulator/beam/break.c @@ -76,7 +76,10 @@ process_info(int to, void *to_arg) for (i = 0; i < max; i++) { Process *p = erts_pix2proc(i); if (p && p->i != ENULL) { - if (!ERTS_PROC_IS_EXITING(p)) + /* Do not include processes with no heap, + * they are most likely just created and has invalid data + */ + if (!ERTS_PROC_IS_EXITING(p) && p->heap != NULL) print_process_info(to, to_arg, p); } } diff --git a/erts/emulator/beam/dist.c b/erts/emulator/beam/dist.c index 44f4eb9d43..6ecf3f0722 100644 --- a/erts/emulator/beam/dist.c +++ b/erts/emulator/beam/dist.c @@ -353,7 +353,7 @@ static void doit_link_net_exits_sub(ErtsLink *sublnk, void *vlnecp) static void doit_link_net_exits(ErtsLink *lnk, void *vnecp) { LinkNetExitsContext lnec = {(NetExitsContext *) vnecp, lnk}; - ASSERT(lnk->type == LINK_PID) + ASSERT(lnk->type == LINK_PID); erts_sweep_links(ERTS_LINK_ROOT(lnk), &doit_link_net_exits_sub, (void *) &lnec); #ifdef DEBUG ERTS_LINK_ROOT(lnk) = NULL; @@ -369,7 +369,7 @@ static void doit_node_link_net_exits(ErtsLink *lnk, void *vnecp) Process *rp; ErtsLink *rlnk; Uint i,n; - ASSERT(lnk->type == LINK_NODE) + ASSERT(lnk->type == LINK_NODE); if (is_internal_pid(lnk->pid)) { ErtsProcLocks rp_locks = ERTS_PROC_LOCK_LINK; rp = erts_pid2proc(NULL, 0, lnk->pid, rp_locks); @@ -1509,12 +1509,12 @@ int erts_net_message(Port *prt, break; } rp = erts_pid2proc(NULL, 0, mon->pid, rp_locks); + + erts_destroy_monitor(mon); if (rp == NULL) { break; } - erts_destroy_monitor(mon); - mon = erts_remove_monitor(&ERTS_P_MONITORS(rp), ref); if (mon == NULL) { diff --git a/erts/emulator/beam/erl_alloc.c b/erts/emulator/beam/erl_alloc.c index 6dec383cee..d8da616d05 100644 --- a/erts/emulator/beam/erl_alloc.c +++ b/erts/emulator/beam/erl_alloc.c @@ -718,6 +718,7 @@ erts_alloc_init(int *argc, char **argv, ErtsAllocInitOpts *eaiop) init.mseg.nos = erts_no_schedulers; erts_mseg_init(&init.mseg); #endif + erts_alcu_init(&init.alloc_util); erts_afalc_init(); erts_bfalc_init(); @@ -1174,6 +1175,25 @@ get_kb_value(char *param_end, char** argv, int* ip) return ((Uint) tmp)*1024; } +static UWord +get_mb_value(char *param_end, char** argv, int* ip) +{ + SWord tmp; + UWord max = ((~((UWord) 0))/(1024*1024)) + 1; + char *rest; + char *param = argv[*ip]+1; + char *value = get_value(param_end, argv, ip); + errno = 0; + tmp = (SWord) ErtsStrToSint(value, &rest, 10); + if (errno != 0 || rest == value || tmp < 0 || max < ((UWord) tmp)) + bad_value(param, param_end, value); + if (max == (UWord) tmp) + return ~((UWord) 0); + else + return ((UWord) tmp)*1024*1024; +} + + #if 0 static Uint get_byte_value(char *param_end, char** argv, int* ip) @@ -1448,6 +1468,30 @@ handle_args(int *argc, char **argv, erts_alc_hndl_args_init_t *init) #endif get_amount_value(argv[i]+6, argv, &i); } + else if (has_prefix("scs", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.mmap.scs = +#endif + get_mb_value(argv[i]+6, argv, &i); + } + else if (has_prefix("sco", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.mmap.sco = +#endif + get_bool_value(argv[i]+6, argv, &i); + } + else if (has_prefix("scrpm", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.mmap.scrpm = +#endif + get_bool_value(argv[i]+8, argv, &i); + } + else if (has_prefix("scmgc", argv[i]+3)) { +#if HAVE_ERTS_MSEG + init->mseg.mmap.scmgc = +#endif + get_amount_value(argv[i]+8, argv, &i); + } else { bad_param(param, param+2); } @@ -2668,6 +2712,7 @@ erts_allocator_info(int to, void *arg) #if HAVE_ERTS_MSEG { + struct erts_mmap_info_struct emis; #ifdef ERTS_SMP int max = (int) erts_no_schedulers; #else @@ -2678,6 +2723,8 @@ erts_allocator_info(int to, void *arg) erts_print(to, arg, "=allocator:mseg_alloc[%d]\n", i); erts_mseg_info(i, &to, arg, 0, NULL, NULL); } + erts_print(to, arg, "=allocator:mseg_alloc.erts_mmap\n"); + erts_mmap_info(&to, arg, NULL, NULL, &emis); } #endif @@ -2904,6 +2951,7 @@ reply_alloc_info(void *vair) Uint sz, *szp; ErlOffHeap *ohp = NULL; ErlHeapFragment *bp = NULL; + struct erts_mmap_info_struct emis; int i; Eterm (*info_func)(Allctr_t *, int, @@ -3016,15 +3064,23 @@ reply_alloc_info(void *vair) ? NIL : erts_mseg_info(0, NULL, NULL, hpp != NULL, hpp, szp)); - ainfo = erts_bld_tuple(hpp, szp, 3, - alloc_atom, - make_small(0), - ainfo); + ainfo = erts_bld_tuple3(hpp, szp, + alloc_atom, + make_small(0), + ainfo); + + ai_list = erts_bld_cons(hpp, szp, + ainfo, ai_list); + ainfo = (air->only_sz ? NIL : erts_mmap_info(NULL, NULL, hpp, szp, &emis)); + ainfo = erts_bld_tuple3(hpp, szp, + alloc_atom, + erts_bld_atom(hpp,szp,"erts_mmap"), + ainfo); #else - ainfo = erts_bld_tuple(hpp, szp, 2, alloc_atom, - am_false); + ainfo = erts_bld_tuple2(hpp, szp, alloc_atom, + am_false); #endif - break; + break; default: alloc_atom = erts_bld_atom(hpp, szp, (char *) ERTS_ALC_A2AD(ai)); diff --git a/erts/emulator/beam/erl_alloc_util.c b/erts/emulator/beam/erl_alloc_util.c index 825b68bb85..1fdee4db2c 100644 --- a/erts/emulator/beam/erl_alloc_util.c +++ b/erts/emulator/beam/erl_alloc_util.c @@ -87,9 +87,6 @@ static int initialized = 0; #define SYS_ALLOC_CARRIER_CEILING(X) \ SYS_ALLOC_CARRIER_FLOOR((X) + INV_SYS_ALLOC_CARRIER_MASK) -#undef ASSERT -#define ASSERT ASSERT_EXPR - #if 0 /* Can be useful for debugging */ #define MBC_REALLOC_ALWAYS_MOVES @@ -759,8 +756,9 @@ static ERTS_INLINE void * alcu_mseg_alloc(Allctr_t *allctr, Uint *size_p, Uint flags) { void *res; - - res = erts_mseg_alloc_opt(allctr->alloc_no, size_p, flags, &allctr->mseg_opt); + UWord size = (UWord) *size_p; + res = erts_mseg_alloc_opt(allctr->alloc_no, &size, flags, &allctr->mseg_opt); + *size_p = (Uint) size; INC_CC(allctr->calls.mseg_alloc); return res; } @@ -769,9 +767,10 @@ static ERTS_INLINE void * alcu_mseg_realloc(Allctr_t *allctr, void *seg, Uint old_size, Uint *new_size_p) { void *res; - - res = erts_mseg_realloc_opt(allctr->alloc_no, seg, old_size, new_size_p, + UWord new_size = (UWord) *new_size_p; + res = erts_mseg_realloc_opt(allctr->alloc_no, seg, (UWord) old_size, &new_size, ERTS_MSEG_FLG_NONE, &allctr->mseg_opt); + *new_size_p = (Uint) new_size; INC_CC(allctr->calls.mseg_realloc); return res; } @@ -779,7 +778,7 @@ alcu_mseg_realloc(Allctr_t *allctr, void *seg, Uint old_size, Uint *new_size_p) static ERTS_INLINE void alcu_mseg_dealloc(Allctr_t *allctr, void *seg, Uint size, Uint flags) { - erts_mseg_dealloc_opt(allctr->alloc_no, seg, size, flags, &allctr->mseg_opt); + erts_mseg_dealloc_opt(allctr->alloc_no, seg, (UWord) size, flags, &allctr->mseg_opt); INC_CC(allctr->calls.mseg_dealloc); } @@ -3226,10 +3225,12 @@ static void CHECK_1BLK_CARRIER(Allctr_t* A, int SBC, int MSEGED, Carrier_t* C, ASSERT(IS_MBC_BLK((B))); ASSERT(IS_MB_CARRIER((C))); ASSERT(FBLK_TO_MBC(B) == (C)); + if ((MSEGED)) { + ASSERT_ERTS_SACRR_UNIT_SIZE_MULTIPLE((CSZ)); + } } if ((MSEGED)) { ASSERT(IS_MSEG_CARRIER((C))); - ASSERT_ERTS_SACRR_UNIT_SIZE_MULTIPLE((CSZ)); } else { ASSERT(IS_SYS_ALLOC_CARRIER((C))); @@ -3601,7 +3602,6 @@ destroy_carrier(Allctr_t *allctr, Block_t *blk, Carrier_t **busy_pcrr_pp) #if HAVE_ERTS_MSEG if (IS_MSEG_CARRIER(crr)) { - ASSERT(crr_sz % ERTS_SACRR_UNIT_SZ == 0); STAT_MSEG_SBC_FREE(allctr, crr_sz, blk_sz); } else diff --git a/erts/emulator/beam/erl_alloc_util.h b/erts/emulator/beam/erl_alloc_util.h index 70ecf28172..222f137024 100644 --- a/erts/emulator/beam/erl_alloc_util.h +++ b/erts/emulator/beam/erl_alloc_util.h @@ -254,9 +254,9 @@ erts_aint32_t erts_alcu_fix_alloc_shrink(Allctr_t *, erts_aint32_t); # define MBC_ABLK_SZ_MASK (~FLG_MASK) #endif -#define MBC_ABLK_SZ(B) (ASSERT_EXPR(!is_sbc_blk(B)), (B)->bhdr & MBC_ABLK_SZ_MASK) -#define MBC_FBLK_SZ(B) (ASSERT_EXPR(!is_sbc_blk(B)), (B)->bhdr & MBC_FBLK_SZ_MASK) -#define SBC_BLK_SZ(B) (ASSERT_EXPR(is_sbc_blk(B)), (B)->bhdr & SBC_BLK_SZ_MASK) +#define MBC_ABLK_SZ(B) (ASSERT(!is_sbc_blk(B)), (B)->bhdr & MBC_ABLK_SZ_MASK) +#define MBC_FBLK_SZ(B) (ASSERT(!is_sbc_blk(B)), (B)->bhdr & MBC_FBLK_SZ_MASK) +#define SBC_BLK_SZ(B) (ASSERT(is_sbc_blk(B)), (B)->bhdr & SBC_BLK_SZ_MASK) #define CARRIER_SZ(C) \ ((C)->chdr & CARRIER_SZ_MASK) diff --git a/erts/emulator/beam/erl_ao_firstfit_alloc.c b/erts/emulator/beam/erl_ao_firstfit_alloc.c index 4e6c8b317e..396aa88e0b 100644 --- a/erts/emulator/beam/erl_ao_firstfit_alloc.c +++ b/erts/emulator/beam/erl_ao_firstfit_alloc.c @@ -85,9 +85,6 @@ #define SET_RED(N) (((AOFF_RBTree_t *) (N))->flags |= RED_FLG) #define SET_BLACK(N) (((AOFF_RBTree_t *) (N))->flags &= ~RED_FLG) -#undef ASSERT -#define ASSERT ASSERT_EXPR - #if 1 #define RBT_ASSERT ASSERT #else diff --git a/erts/emulator/beam/erl_bestfit_alloc.c b/erts/emulator/beam/erl_bestfit_alloc.c index 41f449bb28..59c14899a2 100644 --- a/erts/emulator/beam/erl_bestfit_alloc.c +++ b/erts/emulator/beam/erl_bestfit_alloc.c @@ -75,9 +75,6 @@ #define BF_BLK_SZ(B) MBC_FBLK_SZ(&(B)->hdr) -#undef ASSERT -#define ASSERT ASSERT_EXPR - #if 1 #define RBT_ASSERT ASSERT #else diff --git a/erts/emulator/beam/erl_bif_info.c b/erts/emulator/beam/erl_bif_info.c index 3b25efd9af..5fbcbbe250 100755 --- a/erts/emulator/beam/erl_bif_info.c +++ b/erts/emulator/beam/erl_bif_info.c @@ -2091,7 +2091,7 @@ BIF_RETTYPE system_info_1(BIF_ALIST_1) BIF_RET(res); } else if (BIF_ARG_1 == am_sequential_tracer) { val = erts_get_system_seq_tracer(); - ASSERT(is_internal_pid(val) || is_internal_port(val) || val==am_false) + ASSERT(is_internal_pid(val) || is_internal_port(val) || val==am_false); hp = HAlloc(BIF_P, 3); res = TUPLE2(hp, am_sequential_tracer, val); BIF_RET(res); @@ -3289,6 +3289,9 @@ BIF_RETTYPE erts_debug_get_internal_state_1(BIF_ALIST_1) erts_smp_thr_progress_unblock(); BIF_RET(res); } + else if (ERTS_IS_ATOM_STR("mmap", BIF_ARG_1)) { + BIF_RET(erts_mmap_debug_info(BIF_P)); + } } else if (is_tuple(BIF_ARG_1)) { Eterm* tp = tuple_val(BIF_ARG_1); diff --git a/erts/emulator/beam/erl_binary.h b/erts/emulator/beam/erl_binary.h index 506c4813fa..f7dc20f5e6 100644 --- a/erts/emulator/beam/erl_binary.h +++ b/erts/emulator/beam/erl_binary.h @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 2000-2011. All Rights Reserved. + * Copyright Ericsson AB 2000-2013. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -153,7 +153,7 @@ do { \ #define binary_bytes(Bin) \ (*binary_val(Bin) == HEADER_PROC_BIN ? \ ((ProcBin *) binary_val(Bin))->bytes : \ - (ASSERT_EXPR(thing_subtag(*binary_val(Bin)) == HEAP_BINARY_SUBTAG), \ + (ASSERT(thing_subtag(*binary_val(Bin)) == HEAP_BINARY_SUBTAG), \ (byte *)(&(((ErlHeapBin *) binary_val(Bin))->data)))) void erts_init_binary(void); @@ -183,7 +183,7 @@ BIF_RETTYPE erts_binary_part(Process *p, Eterm binary, Eterm epos, Eterm elen); #endif #define ERTS_CHK_BIN_ALIGNMENT(B) \ - do { ASSERT(!(B) || (((UWord) &((Binary *)(B))->orig_bytes[0]) & ERTS_BIN_ALIGNMENT_MASK) == ((UWord) 0)) } while(0) + do { ASSERT(!(B) || (((UWord) &((Binary *)(B))->orig_bytes[0]) & ERTS_BIN_ALIGNMENT_MASK) == ((UWord) 0)); } while(0) ERTS_GLB_INLINE byte* erts_get_aligned_binary_bytes(Eterm bin, byte** base_ptr); ERTS_GLB_INLINE void erts_free_aligned_binary_bytes(byte* buf); diff --git a/erts/emulator/beam/erl_db.c b/erts/emulator/beam/erl_db.c index 40b8eaf8fb..41e64fcd4f 100644 --- a/erts/emulator/beam/erl_db.c +++ b/erts/emulator/beam/erl_db.c @@ -2236,7 +2236,7 @@ static BIF_RETTYPE ets_select_trap_1(BIF_ALIST_1) CHECK_TABLES(); tptr = tuple_val(a1); - ASSERT(arityval(*tptr) >= 1) + ASSERT(arityval(*tptr) >= 1); if ((tb = db_get_table(p, tptr[1], DB_READ, kind)) == NULL) { BIF_ERROR(p, BADARG); @@ -2403,7 +2403,7 @@ static BIF_RETTYPE ets_select_count_1(BIF_ALIST_1) CHECK_TABLES(); tptr = tuple_val(a1); - ASSERT(arityval(*tptr) >= 1) + ASSERT(arityval(*tptr) >= 1); if ((tb = db_get_table(p, tptr[1], DB_READ, kind)) == NULL) { BIF_ERROR(p, BADARG); } diff --git a/erts/emulator/beam/erl_db_util.h b/erts/emulator/beam/erl_db_util.h index 90b79e6044..328b19dfc9 100644 --- a/erts/emulator/beam/erl_db_util.h +++ b/erts/emulator/beam/erl_db_util.h @@ -457,7 +457,7 @@ int erts_db_is_compiled_ms(Eterm term); && ERTS_MAGIC_BIN_DESTRUCTOR((BP)) == erts_db_match_prog_destructor) #define Binary2MatchProg(BP) \ - (ASSERT_EXPR(IsMatchProgBinary((BP))), \ + (ASSERT(IsMatchProgBinary((BP))), \ ((MatchProg *) ERTS_MAGIC_BIN_DATA((BP)))) /* ** Debugging diff --git a/erts/emulator/beam/erl_lock_check.c b/erts/emulator/beam/erl_lock_check.c index 2114d0c001..0dd83fa6ed 100644 --- a/erts/emulator/beam/erl_lock_check.c +++ b/erts/emulator/beam/erl_lock_check.c @@ -132,6 +132,7 @@ static erts_lc_lock_order_t erts_lock_order[] = { #endif /* __WIN32__ */ { "alcu_init_atoms", NULL }, { "mseg_init_atoms", NULL }, + { "mmap_init_atoms", NULL }, { "drv_tsd", NULL }, { "async_enq_mtx", NULL }, #ifdef ERTS_SMP @@ -185,7 +186,9 @@ static erts_lc_lock_order_t erts_lock_order[] = { { "sys_gethrtime", NULL }, #endif #endif - { "erts_alloc_hard_debug", NULL } + { "erts_alloc_hard_debug", NULL }, + { "hard_dbg_mseg", NULL }, + { "erts_mmap", NULL } }; #define ERTS_LOCK_ORDER_SIZE \ diff --git a/erts/emulator/beam/erl_node_container_utils.h b/erts/emulator/beam/erl_node_container_utils.h index 0f93a3a9f0..17f6b32bb1 100644 --- a/erts/emulator/beam/erl_node_container_utils.h +++ b/erts/emulator/beam/erl_node_container_utils.h @@ -106,7 +106,7 @@ #define dist_entry_channel_no(x) \ ((x) == erts_this_dist_entry \ ? ((Uint) 0) \ - : (ASSERT_EXPR(is_atom((x)->sysname)), \ + : (ASSERT(is_atom((x)->sysname)), \ (Uint) atom_val((x)->sysname))) #define internal_channel_no(x) ((Uint) ERST_INTERNAL_CHANNEL_NO) #define external_channel_no(x) \ @@ -122,10 +122,10 @@ extern ErtsPTab erts_proc; (D), \ _TAG_IMMED1_PID) -#define internal_pid_index(PID) (ASSERT_EXPR(is_internal_pid((PID))), \ +#define internal_pid_index(PID) (ASSERT(is_internal_pid((PID))), \ erts_ptab_id2pix(&erts_proc, (PID))) -#define internal_pid_data(PID) (ASSERT_EXPR(is_internal_pid((PID))), \ +#define internal_pid_data(PID) (ASSERT(is_internal_pid((PID))), \ erts_ptab_id2data(&erts_proc, (PID))) #define internal_pid_number(x) _GET_PID_NUM(internal_pid_data((x))) @@ -193,10 +193,10 @@ extern ErtsPTab erts_port; (D), \ _TAG_IMMED1_PORT) -#define internal_port_index(PRT) (ASSERT_EXPR(is_internal_port((PRT))), \ +#define internal_port_index(PRT) (ASSERT(is_internal_port((PRT))), \ erts_ptab_id2pix(&erts_port, (PRT))) -#define internal_port_data(PRT) (ASSERT_EXPR(is_internal_port((PRT))), \ +#define internal_port_data(PRT) (ASSERT(is_internal_port((PRT))), \ erts_ptab_id2data(&erts_port, (PRT))) #define internal_port_number(x) _GET_PORT_NUM(internal_port_data((x))) diff --git a/erts/emulator/beam/erl_process.c b/erts/emulator/beam/erl_process.c index 434d5ca147..1efd070afd 100644 --- a/erts/emulator/beam/erl_process.c +++ b/erts/emulator/beam/erl_process.c @@ -294,7 +294,7 @@ ERTS_SCHED_PREF_QUICK_ALLOC_IMPL(proclist, ERTS_ALC_T_PROC_LIST) #define ERTS_SCHED_SLEEP_INFO_IX(IX) \ - (ASSERT_EXPR(-1 <= ((int) (IX)) \ + (ASSERT(-1 <= ((int) (IX)) \ && ((int) (IX)) < ((int) erts_no_schedulers)), \ &aligned_sched_sleep_info[(IX)].ssi) @@ -7471,6 +7471,7 @@ alloc_process(ErtsRunQueue *rq, erts_aint32_t state) p->approx_started = erts_get_approx_time(); p->rcount = 0; + p->heap = NULL; ASSERT(p == (Process *) (erts_ptab_pix2intptr_nob( @@ -7583,7 +7584,6 @@ erl_create_process(Process* parent, /* Parent of process (default group leader). hipe_init_process_smp(&p->hipe_smp); #endif #endif - p->heap = (Eterm *) ERTS_HEAP_ALLOC(ERTS_ALC_T_HEAP, sizeof(Eterm)*sz); p->old_hend = p->old_htop = p->old_heap = NULL; p->high_water = p->heap; diff --git a/erts/emulator/beam/erl_process.h b/erts/emulator/beam/erl_process.h index 8e5467f196..8d136f6e8b 100644 --- a/erts/emulator/beam/erl_process.h +++ b/erts/emulator/beam/erl_process.h @@ -1135,10 +1135,10 @@ extern struct erts_system_profile_flags_t erts_system_profile_flags; } while (0) #define ERTS_RUNQ_IX(IX) \ - (ASSERT_EXPR(0 <= (IX) && (IX) < erts_no_run_queues), \ + (ASSERT(0 <= (IX) && (IX) < erts_no_run_queues), \ &erts_aligned_run_queues[(IX)].runq) #define ERTS_SCHEDULER_IX(IX) \ - (ASSERT_EXPR(0 <= (IX) && (IX) < erts_no_schedulers), \ + (ASSERT(0 <= (IX) && (IX) < erts_no_schedulers), \ &erts_aligned_scheduler_data[(IX)].esd) void erts_pre_init_process(void); diff --git a/erts/emulator/beam/erl_trace.c b/erts/emulator/beam/erl_trace.c index fa015ee4b9..ff7fdfcfca 100644 --- a/erts/emulator/beam/erl_trace.c +++ b/erts/emulator/beam/erl_trace.c @@ -2184,7 +2184,7 @@ trace_gc(Process *p, Eterm what) AM_bin_old_vheap_block_size }; - Uint values[] = { + UWord values[] = { OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0, HEAP_SIZE(p), MBUF_SIZE(p), @@ -2198,7 +2198,7 @@ trace_gc(Process *p, Eterm what) BIN_OLD_VHEAP_SZ(p) }; #define LOCAL_HEAP_SIZE \ - (sizeof(values)/sizeof(Eterm)) * \ + (sizeof(values)/sizeof(*values)) * \ (2/*cons*/ + 3/*2-tuple*/ + BIG_UINT_HEAP_SIZE) + \ 5/*4-tuple */ + TS_HEAP_WORDS DeclareTmpHeap(local_heap,LOCAL_HEAP_SIZE,p); @@ -2206,7 +2206,7 @@ trace_gc(Process *p, Eterm what) Eterm* limit; #endif - ASSERT(sizeof(values)/sizeof(Uint) == sizeof(tags)/sizeof(Eterm)); + ASSERT(sizeof(values)/sizeof(*values) == sizeof(tags)/sizeof(Eterm)); UseTmpHeap(LOCAL_HEAP_SIZE,p); @@ -2214,9 +2214,9 @@ trace_gc(Process *p, Eterm what) hp = local_heap; #ifdef DEBUG size = 0; - (void) erts_bld_atom_uint_2tup_list(NULL, + (void) erts_bld_atom_uword_2tup_list(NULL, &size, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); size += 5/*4-tuple*/ + TS_SIZE(p); @@ -2229,9 +2229,9 @@ trace_gc(Process *p, Eterm what) ERTS_TRACE_FLAGS(p)); size = 0; - (void) erts_bld_atom_uint_2tup_list(NULL, + (void) erts_bld_atom_uword_2tup_list(NULL, &size, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); size += 5/*4-tuple*/ + TS_SIZE(p); @@ -2244,9 +2244,9 @@ trace_gc(Process *p, Eterm what) ASSERT(size <= LOCAL_HEAP_SIZE); #endif - msg = erts_bld_atom_uint_2tup_list(&hp, + msg = erts_bld_atom_uword_2tup_list(&hp, NULL, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); @@ -2415,7 +2415,7 @@ monitor_long_gc(Process *p, Uint time) { am_old_heap_size, am_heap_size }; - Eterm values[] = { + UWord values[] = { time, OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0, HEAP_SIZE(p), @@ -2436,9 +2436,9 @@ monitor_long_gc(Process *p, Uint time) { #endif hsz = 0; - (void) erts_bld_atom_uint_2tup_list(NULL, + (void) erts_bld_atom_uword_2tup_list(NULL, &hsz, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); hsz += 5 /* 4-tuple */; @@ -2449,9 +2449,9 @@ monitor_long_gc(Process *p, Uint time) { hp_end = hp + hsz; #endif - list = erts_bld_atom_uint_2tup_list(&hp, + list = erts_bld_atom_uword_2tup_list(&hp, NULL, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); msg = TUPLE4(hp, am_monitor, p->common.id, am_long_gc, list); @@ -2489,7 +2489,7 @@ monitor_large_heap(Process *p) { am_old_heap_size, am_heap_size }; - Uint values[] = { + UWord values[] = { OLD_HEAP(p) ? OLD_HEND(p) - OLD_HEAP(p) : 0, HEAP_SIZE(p), MBUF_SIZE(p), @@ -2511,9 +2511,9 @@ monitor_large_heap(Process *p) { #endif hsz = 0; - (void) erts_bld_atom_uint_2tup_list(NULL, + (void) erts_bld_atom_uword_2tup_list(NULL, &hsz, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); hsz += 5 /* 4-tuple */; @@ -2524,9 +2524,9 @@ monitor_large_heap(Process *p) { hp_end = hp + hsz; #endif - list = erts_bld_atom_uint_2tup_list(&hp, + list = erts_bld_atom_uword_2tup_list(&hp, NULL, - sizeof(values)/sizeof(Uint), + sizeof(values)/sizeof(*values), tags, values); msg = TUPLE4(hp, am_monitor, p->common.id, am_large_heap, list); diff --git a/erts/emulator/beam/erl_unicode.c b/erts/emulator/beam/erl_unicode.c index e00440b905..569c0a7d31 100644 --- a/erts/emulator/beam/erl_unicode.c +++ b/erts/emulator/beam/erl_unicode.c @@ -1476,6 +1476,9 @@ static Eterm do_utf8_to_list_normalize(Process *p, Uint num, byte *bytes, Uint s Uint16 savepoints[4]; int numpoints = 0; + if (num == 0) + return NIL; + ASSERT(num > 0); hp = HAlloc(p,num * 2); /* May be to much */ diff --git a/erts/emulator/beam/erl_utils.h b/erts/emulator/beam/erl_utils.h index 80d29d554a..292d135946 100644 --- a/erts/emulator/beam/erl_utils.h +++ b/erts/emulator/beam/erl_utils.h @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 2012. All Rights Reserved. + * Copyright Ericsson AB 2012-2013. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -168,6 +168,10 @@ Eterm erts_bld_uint64(Uint **hpp, Uint *szp, Uint64 ui64); Eterm erts_bld_sint64(Uint **hpp, Uint *szp, Sint64 si64); Eterm erts_bld_cons(Uint **hpp, Uint *szp, Eterm car, Eterm cdr); Eterm erts_bld_tuple(Uint **hpp, Uint *szp, Uint arity, ...); +#define erts_bld_tuple2(H,S,E1,E2) erts_bld_tuple(H,S,2,E1,E2) +#define erts_bld_tuple3(H,S,E1,E2,E3) erts_bld_tuple(H,S,3,E1,E2,E3) +#define erts_bld_tuple4(H,S,E1,E2,E3,E4) erts_bld_tuple(H,S,4,E1,E2,E3,E4) +#define erts_bld_tuple5(H,S,E1,E2,E3,E4,E5) erts_bld_tuple(H,S,5,E1,E2,E3,E4,E5) Eterm erts_bld_tuplev(Uint **hpp, Uint *szp, Uint arity, Eterm terms[]); Eterm erts_bld_string_n(Uint **hpp, Uint *szp, const char *str, Sint len); #define erts_bld_string(hpp,szp,str) erts_bld_string_n(hpp,szp,str,strlen(str)) @@ -175,8 +179,8 @@ Eterm erts_bld_list(Uint **hpp, Uint *szp, Sint length, Eterm terms[]); Eterm erts_bld_2tup_list(Uint **hpp, Uint *szp, Sint length, Eterm terms1[], Uint terms2[]); Eterm -erts_bld_atom_uint_2tup_list(Uint **hpp, Uint *szp, - Sint length, Eterm atoms[], Uint uints[]); +erts_bld_atom_uword_2tup_list(Uint **hpp, Uint *szp, + Sint length, Eterm atoms[], UWord uints[]); Eterm erts_bld_atom_2uint_3tup_list(Uint **hpp, Uint *szp, Sint length, Eterm atoms[], Uint uints1[], Uint uints2[]); diff --git a/erts/emulator/beam/erl_vm.h b/erts/emulator/beam/erl_vm.h index c962955de9..337422eead 100644 --- a/erts/emulator/beam/erl_vm.h +++ b/erts/emulator/beam/erl_vm.h @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 1996-2012. All Rights Reserved. + * Copyright Ericsson AB 1996-2013. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -80,7 +80,7 @@ # ifdef CHECK_FOR_HOLES # define INIT_HEAP_MEM(p,sz) erts_set_hole_marker(HEAP_TOP(p), (sz)) # else -# define INIT_HEAP_MEM(p,sz) memset(HEAP_TOP(p),DEBUG_BAD_BYTE,(sz)*sizeof(Eterm*)) +# define INIT_HEAP_MEM(p,sz) memset(HEAP_TOP(p),0x01,(sz)*sizeof(Eterm*)) # endif #else # define INIT_HEAP_MEM(p,sz) ((void)0) @@ -98,7 +98,7 @@ * failing that, in a heap fragment. */ #define HAllocX(p, sz, xtra) \ - (ASSERT_EXPR((sz) >= 0), \ + (ASSERT((sz) >= 0), \ ErtsHAllocLockCheck(p), \ (IS_FORCE_HEAP_FRAGS || (((HEAP_LIMIT(p) - HEAP_TOP(p)) < (sz))) \ ? erts_heap_alloc((p),(sz),(xtra)) \ @@ -135,14 +135,14 @@ */ #ifdef CHECK_FOR_HOLES # define HeapOnlyAlloc(p, sz) \ - (ASSERT_EXPR((sz) >= 0), \ - (ASSERT_EXPR(((HEAP_LIMIT(p) - HEAP_TOP(p)) >= (sz))), \ + (ASSERT((sz) >= 0), \ + (ASSERT(((HEAP_LIMIT(p) - HEAP_TOP(p)) >= (sz))), \ (erts_set_hole_marker(HEAP_TOP(p), (sz)), \ (HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz))))) #else # define HeapOnlyAlloc(p, sz) \ - (ASSERT_EXPR((sz) >= 0), \ - (ASSERT_EXPR(((HEAP_LIMIT(p) - HEAP_TOP(p)) >= (sz))), \ + (ASSERT((sz) >= 0), \ + (ASSERT(((HEAP_LIMIT(p) - HEAP_TOP(p)) >= (sz))), \ (HEAP_TOP(p) = HEAP_TOP(p) + (sz), HEAP_TOP(p) - (sz)))) #endif diff --git a/erts/emulator/beam/external.h b/erts/emulator/beam/external.h index e37d47919e..ff29e84972 100644 --- a/erts/emulator/beam/external.h +++ b/erts/emulator/beam/external.h @@ -138,8 +138,8 @@ typedef struct { #define ERTS_DIST_EXT_SIZE(EDEP) \ (sizeof(ErtsDistExternal) \ - (((EDEP)->flags & ERTS_DIST_EXT_ATOM_TRANS_TAB) \ - ? (ASSERT_EXPR(0 <= (EDEP)->attab.size \ - && (EDEP)->attab.size <= ERTS_ATOM_CACHE_SIZE), \ + ? (ASSERT(0 <= (EDEP)->attab.size \ + && (EDEP)->attab.size <= ERTS_ATOM_CACHE_SIZE), \ sizeof(Eterm)*(ERTS_ATOM_CACHE_SIZE - (EDEP)->attab.size)) \ : sizeof(ErtsAtomTranslationTable))) diff --git a/erts/emulator/beam/global.h b/erts/emulator/beam/global.h index bacd5a5752..063d16c0c7 100755 --- a/erts/emulator/beam/global.h +++ b/erts/emulator/beam/global.h @@ -866,13 +866,13 @@ Eterm store_external_or_ref_in_proc_(Process *, Eterm); Eterm store_external_or_ref_(Uint **, ErlOffHeap*, Eterm); #define NC_HEAP_SIZE(NC) \ - (ASSERT_EXPR(is_node_container((NC))), \ + (ASSERT(is_node_container((NC))), \ IS_CONST((NC)) ? 0 : (thing_arityval(*boxed_val((NC))) + 1)) #define STORE_NC(Hpp, ETpp, NC) \ - (ASSERT_EXPR(is_node_container((NC))), \ + (ASSERT(is_node_container((NC))), \ IS_CONST((NC)) ? (NC) : store_external_or_ref_((Hpp), (ETpp), (NC))) #define STORE_NC_IN_PROC(Pp, NC) \ - (ASSERT_EXPR(is_node_container((NC))), \ + (ASSERT(is_node_container((NC))), \ IS_CONST((NC)) ? (NC) : store_external_or_ref_in_proc_((Pp), (NC))) /* duplicates from big.h */ diff --git a/erts/emulator/beam/io.c b/erts/emulator/beam/io.c index c1e66b59af..db19f6c142 100644 --- a/erts/emulator/beam/io.c +++ b/erts/emulator/beam/io.c @@ -1330,7 +1330,7 @@ force_imm_drv_call(ErtsTryImmDrvCallState *sp) erts_aint32_t invalid_state; Port *prt = sp->port; - ASSERT(ERTS_IS_CRASH_DUMPING) + ASSERT(ERTS_IS_CRASH_DUMPING); ASSERT(is_atom(sp->port_op)); invalid_state = sp->state; diff --git a/erts/emulator/beam/sys.h b/erts/emulator/beam/sys.h index 096394b878..9561c0be96 100644 --- a/erts/emulator/beam/sys.h +++ b/erts/emulator/beam/sys.h @@ -149,19 +149,14 @@ typedef ERTS_SYS_FD_TYPE ErtsSysFdType; # define ERTS_EXIT_AFTER_DUMP exit #endif +#define ERTS_ASSERT(e) \ + ((void) ((e) ? 1 : (erl_assert_error(#e, __func__, __FILE__, __LINE__), 0))) +void erl_assert_error(const char* expr, const char *func, const char* file, int line); + #ifdef DEBUG -# define ASSERT(e) \ - if (e) { \ - ; \ - } else { \ - erl_assert_error(#e, __FILE__, __LINE__); \ - } -# define ASSERT_EXPR(e) \ - ((void) ((e) ? 1 : (erl_assert_error(#e, __FILE__, __LINE__), 0))) -void erl_assert_error(char* expr, char* file, int line); +# define ASSERT(e) ERTS_ASSERT(e) #else -# define ASSERT(e) -# define ASSERT_EXPR(e) ((void) 1) +# define ASSERT(e) ((void) 1) #endif /* @@ -282,16 +277,19 @@ typedef unsigned long UWord; typedef long SWord; #define SWORD_CONSTANT(Const) Const##L #define UWORD_CONSTANT(Const) Const##UL +#define ERTS_SWORD_MAX LONG_MAX #elif SIZEOF_VOID_P == SIZEOF_INT typedef unsigned int UWord; typedef int SWord; #define SWORD_CONSTANT(Const) Const #define UWORD_CONSTANT(Const) Const##U +#define ERTS_SWORD_MAX INT_MAX #elif SIZEOF_VOID_P == SIZEOF_LONG_LONG typedef unsigned long long UWord; typedef long long SWord; #define SWORD_CONSTANT(Const) Const##LL #define UWORD_CONSTANT(Const) Const##ULL +#define ERTS_SWORD_MAX LLONG_MAX #else #error Found no appropriate type to use for 'Eterm', 'Uint' and 'Sint' #endif @@ -304,6 +302,7 @@ typedef unsigned long Uint; typedef long Sint; #define SWORD_CONSTANT(Const) Const##L #define UWORD_CONSTANT(Const) Const##UL +#define ERTS_SWORD_MAX LONG_MAX #define ERTS_SIZEOF_ETERM SIZEOF_LONG #define ErtsStrToSint strtol #elif SIZEOF_VOID_P == SIZEOF_INT @@ -312,6 +311,7 @@ typedef unsigned int Uint; typedef int Sint; #define SWORD_CONSTANT(Const) Const #define UWORD_CONSTANT(Const) Const##U +#define ERTS_SWORD_MAX INT_MAX #define ERTS_SIZEOF_ETERM SIZEOF_INT #define ErtsStrToSint strtol #elif SIZEOF_VOID_P == SIZEOF_LONG_LONG @@ -320,6 +320,7 @@ typedef unsigned long long Uint; typedef long long Sint; #define SWORD_CONSTANT(Const) Const##LL #define UWORD_CONSTANT(Const) Const##ULL +#define ERTS_SWORD_MAX LLONG_MAX #define ERTS_SIZEOF_ETERM SIZEOF_LONG_LONG #if defined(__WIN32__) #define ErtsStrToSint _strtoi64 diff --git a/erts/emulator/beam/utils.c b/erts/emulator/beam/utils.c index bd2be7afca..0d75bbcc77 100644 --- a/erts/emulator/beam/utils.c +++ b/erts/emulator/beam/utils.c @@ -576,8 +576,8 @@ erts_bld_2tup_list(Uint **hpp, Uint *szp, } Eterm -erts_bld_atom_uint_2tup_list(Uint **hpp, Uint *szp, - Sint length, Eterm atoms[], Uint uints[]) +erts_bld_atom_uword_2tup_list(Uint **hpp, Uint *szp, + Sint length, Eterm atoms[], UWord uints[]) { Sint i; Eterm res = THE_NON_VALUE; diff --git a/erts/emulator/drivers/common/inet_drv.c b/erts/emulator/drivers/common/inet_drv.c index 60db50e80a..12f45245b5 100644 --- a/erts/emulator/drivers/common/inet_drv.c +++ b/erts/emulator/drivers/common/inet_drv.c @@ -4433,7 +4433,7 @@ static ErlDrvSSizeT inet_ctl_getiflist(inet_descriptor* desc, case AF_INET6: #endif case AF_INET: - ASSERT(sp+IFNAMSIZ+1 < sbuf+ifc.ifc_len+1) + ASSERT(sp+IFNAMSIZ+1 < sbuf+ifc.ifc_len+1); strncpy(sp, ifrp->ifr_name, IFNAMSIZ); sp[IFNAMSIZ] = '\0'; sp += strlen(sp), ++sp; diff --git a/erts/emulator/drivers/unix/ttsl_drv.c b/erts/emulator/drivers/unix/ttsl_drv.c index 1e436830e7..491e0a090e 100644 --- a/erts/emulator/drivers/unix/ttsl_drv.c +++ b/erts/emulator/drivers/unix/ttsl_drv.c @@ -745,7 +745,7 @@ static Sint16 get_sint16(char *s) { return ((*s << 8) | ((byte*)s)[1]); } - + static int start_lbuf(void) { if (!lbuf && !(lbuf = ( Uint32*) driver_alloc(lbuf_size * sizeof(Uint32)))) @@ -1091,7 +1091,7 @@ static int move_cursor(int from, int to) move_left(-dc); return TRUE; } - + static int start_termcap(void) { int eres; @@ -1187,7 +1187,7 @@ static int move_down(int n) tputs(down, 1, outc); return TRUE; } - + /* * Updates cols if terminal has resized (SIGWINCH). Should be called @@ -1209,7 +1209,7 @@ static void update_cols(void) cols = width; } } - + /* * Put a terminal device into non-canonical mode with ECHO off. diff --git a/erts/emulator/drivers/win32/win_efile.c b/erts/emulator/drivers/win32/win_efile.c index b36a103f8e..319065f57b 100644 --- a/erts/emulator/drivers/win32/win_efile.c +++ b/erts/emulator/drivers/win32/win_efile.c @@ -1216,7 +1216,7 @@ int flags; return 1; } - + /* * is_root_unc_name - returns TRUE if the argument is a UNC name specifying * a root share. That is, if it is of the form \\server\share\. diff --git a/erts/emulator/sys/common/erl_mmap.c b/erts/emulator/sys/common/erl_mmap.c new file mode 100644 index 0000000000..a9da7430fb --- /dev/null +++ b/erts/emulator/sys/common/erl_mmap.c @@ -0,0 +1,2832 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2002-2013. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include "sys.h" +#include "erl_process.h" +#include "erl_smp.h" +#include "atom.h" +#include "erl_mmap.h" +#include <stddef.h> + +/* #define ERTS_MMAP_OP_RINGBUF_SZ 100 */ + +#if defined(DEBUG) || 0 +# undef ERTS_MMAP_DEBUG +# define ERTS_MMAP_DEBUG +# ifndef ERTS_MMAP_OP_RINGBUF_SZ +# define ERTS_MMAP_OP_RINGBUF_SZ 100 +# endif +#endif + +#ifndef ERTS_MMAP_OP_RINGBUF_SZ +# define ERTS_MMAP_OP_RINGBUF_SZ 0 +#endif + +/* #define ERTS_MMAP_DEBUG_FILL_AREAS */ + +#ifdef ERTS_MMAP_DEBUG +# define ERTS_MMAP_ASSERT ERTS_ASSERT +#else +# define ERTS_MMAP_ASSERT(A) ((void) 1) +#endif + +/* + * `mmap_state.sa.bot` and `mmap_state.sua.top` are read only after + * initialization, but the other pointers are not; i.e., only + * ERTS_MMAP_IN_SUPERCARRIER() is allowed without the mutex held. + */ +#define ERTS_MMAP_IN_SUPERCARRIER(PTR) \ + (((UWord) (PTR)) - ((UWord) mmap_state.sa.bot) \ + < ((UWord) mmap_state.sua.top) - ((UWord) mmap_state.sa.bot)) +#define ERTS_MMAP_IN_SUPERALIGNED_AREA(PTR) \ + (ERTS_SMP_LC_ASSERT(erts_lc_mtx_is_locked(&mmap_state.mtx)), \ + (((UWord) (PTR)) - ((UWord) mmap_state.sa.bot) \ + < ((UWord) mmap_state.sa.top) - ((UWord) mmap_state.sa.bot))) +#define ERTS_MMAP_IN_SUPERUNALIGNED_AREA(PTR) \ + (ERTS_SMP_LC_ASSERT(erts_lc_mtx_is_locked(&mmap_state.mtx)), \ + (((UWord) (PTR)) - ((UWord) mmap_state.sua.bot) \ + < ((UWord) mmap_state.sua.top) - ((UWord) mmap_state.sua.bot))) + +int erts_have_erts_mmap; +UWord erts_page_inv_mask; + +#if defined(DEBUG) || defined(ERTS_MMAP_DEBUG) +# undef RBT_DEBUG +# define RBT_DEBUG +#endif +#ifdef RBT_DEBUG +# define RBT_ASSERT ERTS_ASSERT +# define IF_RBT_DEBUG(C) C +#else +# define RBT_ASSERT(x) +# define IF_RBT_DEBUG(C) +#endif + +typedef struct RBTNode_ RBTNode; +struct RBTNode_ { + UWord parent_and_color; /* color in bit 0 of parent ptr */ + RBTNode *left; + RBTNode *right; +}; + +#define RED_FLG (1) +#define IS_RED(N) ((N) && ((N)->parent_and_color & RED_FLG)) +#define IS_BLACK(N) (!IS_RED(N)) +#define SET_RED(N) ((N)->parent_and_color |= RED_FLG) +#define SET_BLACK(N) ((N)->parent_and_color &= ~RED_FLG) + +static ERTS_INLINE RBTNode* parent(RBTNode* node) +{ + return (RBTNode*) (node->parent_and_color & ~RED_FLG); +} + +static ERTS_INLINE void set_parent(RBTNode* node, RBTNode* parent) +{ + RBT_ASSERT(!((UWord)parent & RED_FLG)); + node->parent_and_color = ((UWord)parent) | (node->parent_and_color & RED_FLG); +} + +static ERTS_INLINE UWord parent_and_color(RBTNode* parent, int color) +{ + RBT_ASSERT(!((UWord)parent & RED_FLG)); + RBT_ASSERT(!(color & ~RED_FLG)); + return ((UWord)parent) | color; +} + + +enum SortOrder { + ADDR_ORDER, /* only address order */ + SA_SZ_ADDR_ORDER, /* first super-aligned size then address order */ + SZ_REVERSE_ADDR_ORDER /* first size then reverse address order */ +}; +#ifdef HARD_DEBUG +static const char* sort_order_names[] = {"Address","SuperAlignedSize-Address","Size-RevAddress"}; +#endif + +typedef struct { + RBTNode* root; + enum SortOrder order; +}RBTree; + +#ifdef HARD_DEBUG +# define HARD_CHECK_IS_MEMBER(ROOT,NODE) rbt_assert_is_member(ROOT,NODE) +# define HARD_CHECK_TREE(TREE,SZ) check_tree(TREE, SZ) +static int rbt_assert_is_member(RBTNode* root, RBTNode* node); +static RBTNode* check_tree(RBTree* tree, Uint); +#else +# define HARD_CHECK_IS_MEMBER(ROOT,NODE) +# define HARD_CHECK_TREE(TREE,SZ) +#endif + +#if ERTS_MMAP_OP_RINGBUF_SZ + +static int mmap_op_ix; + +typedef enum { + ERTS_OP_TYPE_NONE, + ERTS_OP_TYPE_MMAP, + ERTS_OP_TYPE_MUNMAP, + ERTS_OP_TYPE_MREMAP +} ErtsMMapOpType; + +typedef struct { + ErtsMMapOpType type; + void *result; + UWord in_size; + UWord out_size; + void *old_ptr; + UWord old_size; +} ErtsMMapOp; + +static ErtsMMapOp mmap_ops[ERTS_MMAP_OP_RINGBUF_SZ]; + +#define ERTS_MMAP_OP_RINGBUF_INIT() \ + do { \ + int ix__; \ + for (ix__ = 0; ix__ < ERTS_MMAP_OP_RINGBUF_SZ; ix__++) {\ + mmap_ops[ix__].type = ERTS_OP_TYPE_NONE; \ + mmap_ops[ix__].result = NULL; \ + mmap_ops[ix__].in_size = 0; \ + mmap_ops[ix__].out_size = 0; \ + mmap_ops[ix__].old_ptr = NULL; \ + mmap_ops[ix__].old_size = 0; \ + } \ + mmap_op_ix = ERTS_MMAP_OP_RINGBUF_SZ-1; \ + } while (0) + +#define ERTS_MMAP_OP_START(SZ) \ + do { \ + int ix__; \ + if (++mmap_op_ix >= ERTS_MMAP_OP_RINGBUF_SZ) \ + mmap_op_ix = 0; \ + ix__ = mmap_op_ix; \ + mmap_ops[ix__].type = ERTS_OP_TYPE_MMAP; \ + mmap_ops[ix__].result = NULL; \ + mmap_ops[ix__].in_size = (SZ); \ + mmap_ops[ix__].out_size = 0; \ + mmap_ops[ix__].old_ptr = NULL; \ + mmap_ops[ix__].old_size = 0; \ + } while (0) + +#define ERTS_MMAP_OP_END(PTR, SZ) \ + do { \ + int ix__ = mmap_op_ix; \ + mmap_ops[ix__].result = (PTR); \ + mmap_ops[ix__].out_size = (SZ); \ + } while (0) + +#define ERTS_MMAP_OP_LCK(RES, IN_SZ, OUT_SZ) \ + do { \ + erts_smp_mtx_lock(&mmap_state.mtx); \ + ERTS_MMAP_OP_START((IN_SZ)); \ + ERTS_MMAP_OP_END((RES), (OUT_SZ)); \ + erts_smp_mtx_unlock(&mmap_state.mtx); \ + } while (0) + +#define ERTS_MUNMAP_OP(PTR, SZ) \ + do { \ + int ix__; \ + if (++mmap_op_ix >= ERTS_MMAP_OP_RINGBUF_SZ) \ + mmap_op_ix = 0; \ + ix__ = mmap_op_ix; \ + mmap_ops[ix__].type = ERTS_OP_TYPE_MUNMAP; \ + mmap_ops[ix__].result = NULL; \ + mmap_ops[ix__].in_size = 0; \ + mmap_ops[ix__].out_size = 0; \ + mmap_ops[ix__].old_ptr = (PTR); \ + mmap_ops[ix__].old_size = (SZ); \ + } while (0) + +#define ERTS_MUNMAP_OP_LCK(PTR, SZ) \ + do { \ + erts_smp_mtx_lock(&mmap_state.mtx); \ + ERTS_MUNMAP_OP((PTR), (SZ)); \ + erts_smp_mtx_unlock(&mmap_state.mtx); \ + } while (0) + +#define ERTS_MREMAP_OP_START(OLD_PTR, OLD_SZ, IN_SZ) \ + do { \ + int ix__; \ + if (++mmap_op_ix >= ERTS_MMAP_OP_RINGBUF_SZ) \ + mmap_op_ix = 0; \ + ix__ = mmap_op_ix; \ + mmap_ops[ix__].type = ERTS_OP_TYPE_MREMAP; \ + mmap_ops[ix__].result = NULL; \ + mmap_ops[ix__].in_size = (IN_SZ); \ + mmap_ops[ix__].out_size = (OLD_SZ); \ + mmap_ops[ix__].old_ptr = (OLD_PTR); \ + mmap_ops[ix__].old_size = (OLD_SZ); \ + } while (0) + +#define ERTS_MREMAP_OP_END(PTR, SZ) \ + do { \ + int ix__ = mmap_op_ix; \ + mmap_ops[ix__].result = (PTR); \ + mmap_ops[mmap_op_ix].out_size = (SZ); \ + } while (0) + +#define ERTS_MREMAP_OP_LCK(RES, OLD_PTR, OLD_SZ, IN_SZ, OUT_SZ) \ + do { \ + erts_smp_mtx_lock(&mmap_state.mtx); \ + ERTS_MREMAP_OP_START((OLD_PTR), (OLD_SZ), (IN_SZ)); \ + ERTS_MREMAP_OP_END((RES), (OUT_SZ)); \ + erts_smp_mtx_unlock(&mmap_state.mtx); \ + } while (0) + +#define ERTS_MMAP_OP_ABORT() \ + do { \ + int ix__ = mmap_op_ix; \ + mmap_ops[ix__].type = ERTS_OP_TYPE_NONE; \ + mmap_ops[ix__].result = NULL; \ + mmap_ops[ix__].in_size = 0; \ + mmap_ops[ix__].out_size = 0; \ + mmap_ops[ix__].old_ptr = NULL; \ + mmap_ops[ix__].old_size = 0; \ + if (--mmap_op_ix < 0) \ + mmap_op_ix = ERTS_MMAP_OP_RINGBUF_SZ-1; \ + } while (0) + +#else + +#define ERTS_MMAP_OP_RINGBUF_INIT() +#define ERTS_MMAP_OP_START(SZ) +#define ERTS_MMAP_OP_END(PTR, SZ) +#define ERTS_MMAP_OP_LCK(RES, IN_SZ, OUT_SZ) +#define ERTS_MUNMAP_OP(PTR, SZ) +#define ERTS_MUNMAP_OP_LCK(PTR, SZ) +#define ERTS_MREMAP_OP_START(OLD_PTR, OLD_SZ, IN_SZ) +#define ERTS_MREMAP_OP_END(PTR, SZ) +#define ERTS_MREMAP_OP_LCK(RES, OLD_PTR, OLD_SZ, IN_SZ, OUT_SZ) +#define ERTS_MMAP_OP_ABORT() + +#endif + +typedef struct { + RBTNode snode; /* node in 'stree' */ + RBTNode anode; /* node in 'atree' */ + char* start; + char* end; +}ErtsFreeSegDesc; + +typedef struct { + RBTree stree; /* size ordered tree */ + RBTree atree; /* address ordered tree */ + Uint nseg; +}ErtsFreeSegMap; + +static struct { + int (*reserve_physical)(char *, UWord); + void (*unreserve_physical)(char *, UWord); + int supercarrier; + int no_os_mmap; + /* + * Super unaligend area is located above super aligned + * area. That is, `sa.bot` is beginning of the super + * carrier, `sua.top` is the end of the super carrier, + * and sa.top and sua.bot moves towards eachother. + */ + struct { + char *top; + char *bot; + ErtsFreeSegMap map; + } sua; + struct { + char *top; + char *bot; + ErtsFreeSegMap map; + } sa; +#if HAVE_MMAP && (!defined(MAP_ANON) && !defined(MAP_ANONYMOUS)) + int mmap_fd; +#endif + erts_smp_mtx_t mtx; + struct { + char *free_list; + char *unused_start; + char *unused_end; + char *new_area_hint; + Uint reserved; + } desc; + struct { + UWord free_seg_descs; + struct { + UWord curr; + UWord max; + } free_segs; + } no; + struct { + struct { + UWord total; + struct { + UWord total; + UWord sa; + UWord sua; + } used; + } supercarrier; + struct { + UWord used; + } os; + } size; +} mmap_state; + +#define ERTS_MMAP_SIZE_SC_SA_INC(SZ) \ + do { \ + mmap_state.size.supercarrier.used.total += (SZ); \ + mmap_state.size.supercarrier.used.sa += (SZ); \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.total \ + <= mmap_state.size.supercarrier.total); \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.sa \ + <= mmap_state.size.supercarrier.used.total); \ + } while (0) +#define ERTS_MMAP_SIZE_SC_SA_DEC(SZ) \ + do { \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.total >= (SZ)); \ + mmap_state.size.supercarrier.used.total -= (SZ); \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.sa >= (SZ)); \ + mmap_state.size.supercarrier.used.sa -= (SZ); \ + } while (0) +#define ERTS_MMAP_SIZE_SC_SUA_INC(SZ) \ + do { \ + mmap_state.size.supercarrier.used.total += (SZ); \ + mmap_state.size.supercarrier.used.sua += (SZ); \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.total \ + <= mmap_state.size.supercarrier.total); \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.sua \ + <= mmap_state.size.supercarrier.used.total); \ + } while (0) +#define ERTS_MMAP_SIZE_SC_SUA_DEC(SZ) \ + do { \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.total >= (SZ)); \ + mmap_state.size.supercarrier.used.total -= (SZ); \ + ERTS_MMAP_ASSERT(mmap_state.size.supercarrier.used.sua >= (SZ)); \ + mmap_state.size.supercarrier.used.sua -= (SZ); \ + } while (0) +#define ERTS_MMAP_SIZE_OS_INC(SZ) \ + do { \ + ERTS_MMAP_ASSERT(mmap_state.size.os.used + (SZ) >= (SZ)); \ + mmap_state.size.os.used += (SZ); \ + } while (0) +#define ERTS_MMAP_SIZE_OS_DEC(SZ) \ + do { \ + ERTS_MMAP_ASSERT(mmap_state.size.os.used >= (SZ)); \ + mmap_state.size.os.used -= (SZ); \ + } while (0) + + +static void +add_free_desc_area(char *start, char *end) +{ + ERTS_MMAP_ASSERT(end == (void *) 0 || end > start); + if (sizeof(ErtsFreeSegDesc) <= ((UWord) end) - ((UWord) start)) { + UWord no; + ErtsFreeSegDesc *prev_desc, *desc; + char *desc_end; + + no = 1; + prev_desc = (ErtsFreeSegDesc *) start; + prev_desc->start = mmap_state.desc.free_list; + desc = (ErtsFreeSegDesc *) (start + sizeof(ErtsFreeSegDesc)); + desc_end = start + 2*sizeof(ErtsFreeSegDesc); + + while (desc_end <= end) { + desc->start = (char *) prev_desc; + prev_desc = desc; + desc = (ErtsFreeSegDesc *) desc_end; + desc_end += sizeof(ErtsFreeSegDesc); + no++; + } + mmap_state.desc.free_list = (char *) prev_desc; + mmap_state.no.free_seg_descs += no; + } +} + +static ErtsFreeSegDesc * +add_unused_free_desc_area(void) +{ + char *ptr; + if (!mmap_state.desc.unused_start) + return NULL; + + ERTS_MMAP_ASSERT(mmap_state.desc.unused_end); + ERTS_MMAP_ASSERT(ERTS_PAGEALIGNED_SIZE + <= mmap_state.desc.unused_end - mmap_state.desc.unused_start); + + ptr = mmap_state.desc.unused_start + ERTS_PAGEALIGNED_SIZE; + add_free_desc_area(mmap_state.desc.unused_start, ptr); + + if ((mmap_state.desc.unused_end - ptr) >= ERTS_PAGEALIGNED_SIZE) + mmap_state.desc.unused_start = ptr; + else + mmap_state.desc.unused_end = mmap_state.desc.unused_start = NULL; + + ERTS_MMAP_ASSERT(mmap_state.desc.free_list); + return (ErtsFreeSegDesc *) mmap_state.desc.free_list; +} + +static ERTS_INLINE ErtsFreeSegDesc * +alloc_desc(void) +{ + ErtsFreeSegDesc *res; + res = (ErtsFreeSegDesc *) mmap_state.desc.free_list; + if (!res) { + res = add_unused_free_desc_area(); + if (!res) + return NULL; + } + mmap_state.desc.free_list = res->start; + ASSERT(mmap_state.no.free_segs.curr < mmap_state.no.free_seg_descs); + mmap_state.no.free_segs.curr++; + if (mmap_state.no.free_segs.max < mmap_state.no.free_segs.curr) + mmap_state.no.free_segs.max = mmap_state.no.free_segs.curr; + return res; +} + +static ERTS_INLINE void +free_desc(ErtsFreeSegDesc *desc) +{ + desc->start = mmap_state.desc.free_list; + mmap_state.desc.free_list = (char *) desc; + ERTS_MMAP_ASSERT(mmap_state.no.free_segs.curr > 0); + mmap_state.no.free_segs.curr--; +} + +static ERTS_INLINE ErtsFreeSegDesc* anode_to_desc(RBTNode* anode) +{ + return (ErtsFreeSegDesc*) ((char*)anode - offsetof(ErtsFreeSegDesc, anode)); +} + +static ERTS_INLINE ErtsFreeSegDesc* snode_to_desc(RBTNode* snode) +{ + return (ErtsFreeSegDesc*) ((char*)snode - offsetof(ErtsFreeSegDesc, snode)); +} + +static ERTS_INLINE ErtsFreeSegDesc* node_to_desc(enum SortOrder order, RBTNode* node) +{ + return order==ADDR_ORDER ? anode_to_desc(node) : snode_to_desc(node); +} + +static ERTS_INLINE SWord usable_size(enum SortOrder order, + ErtsFreeSegDesc* desc) +{ + return ((order == SA_SZ_ADDR_ORDER) ? + ERTS_SUPERALIGNED_FLOOR(desc->end) - ERTS_SUPERALIGNED_CEILING(desc->start) + : desc->end - desc->start); +} + +#ifdef HARD_DEBUG +static ERTS_INLINE SWord cmp_nodes(enum SortOrder order, + RBTNode* lhs, RBTNode* rhs) +{ + ErtsFreeSegDesc* ldesc = node_to_desc(order, lhs); + ErtsFreeSegDesc* rdesc = node_to_desc(order, rhs); + RBT_ASSERT(lhs != rhs); + if (order != ADDR_ORDER) { + SWord diff = usable_size(order, ldesc) - usable_size(order, rdesc); + if (diff) return diff; + } + if (order != SZ_REVERSE_ADDR_ORDER) { + return (char*)ldesc->start - (char*)rdesc->start; + } + else { + return (char*)rdesc->start - (char*)ldesc->start; + } +} +#endif /* HARD_DEBUG */ + +static ERTS_INLINE SWord cmp_with_node(enum SortOrder order, + SWord sz, char* addr, RBTNode* rhs) +{ + ErtsFreeSegDesc* rdesc; + if (order != ADDR_ORDER) { + SWord diff; + rdesc = snode_to_desc(rhs); + diff = sz - usable_size(order, rdesc); + if (diff) return diff; + } + else + rdesc = anode_to_desc(rhs); + + if (order != SZ_REVERSE_ADDR_ORDER) + return addr - (char*)rdesc->start; + else + return (char*)rdesc->start - addr; +} + + +static ERTS_INLINE void +left_rotate(RBTNode **root, RBTNode *x) +{ + RBTNode *y = x->right; + x->right = y->left; + if (y->left) + set_parent(y->left, x); + set_parent(y, parent(x)); + if (!parent(y)) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == parent(x)->left) + parent(x)->left = y; + else { + RBT_ASSERT(x == parent(x)->right); + parent(x)->right = y; + } + y->left = x; + set_parent(x, y); +} + +static ERTS_INLINE void +right_rotate(RBTNode **root, RBTNode *x) +{ + RBTNode *y = x->left; + x->left = y->right; + if (y->right) + set_parent(y->right, x); + set_parent(y, parent(x)); + if (!parent(y)) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == parent(x)->right) + parent(x)->right = y; + else { + RBT_ASSERT(x == parent(x)->left); + parent(x)->left = y; + } + y->right = x; + set_parent(x, y); +} + +/* + * Replace node x with node y + * NOTE: segment descriptor of y is not changed + */ +static ERTS_INLINE void +replace(RBTNode **root, RBTNode *x, RBTNode *y) +{ + + if (!parent(x)) { + RBT_ASSERT(*root == x); + *root = y; + } + else if (x == parent(x)->left) + parent(x)->left = y; + else { + RBT_ASSERT(x == parent(x)->right); + parent(x)->right = y; + } + if (x->left) { + RBT_ASSERT(parent(x->left) == x); + set_parent(x->left, y); + } + if (x->right) { + RBT_ASSERT(parent(x->right) == x); + set_parent(x->right, y); + } + + y->parent_and_color = x->parent_and_color; + y->right = x->right; + y->left = x->left; +} + +static void +tree_insert_fixup(RBTNode** root, RBTNode *node) +{ + RBTNode *x = node, *y, *papa_x, *granpa_x; + + /* + * Rearrange the tree so that it satisfies the Red-Black Tree properties + */ + + papa_x = parent(x); + RBT_ASSERT(x != *root && IS_RED(papa_x)); + do { + + /* + * x and its parent are both red. Move the red pair up the tree + * until we get to the root or until we can separate them. + */ + + granpa_x = parent(papa_x); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_BLACK(granpa_x)); + RBT_ASSERT(granpa_x); + + if (papa_x == granpa_x->left) { + y = granpa_x->right; + if (IS_RED(y)) { + SET_BLACK(y); + SET_BLACK(papa_x); + SET_RED(granpa_x); + x = granpa_x; + } + else { + + if (x == papa_x->right) { + left_rotate(root, papa_x); + papa_x = x; + x = papa_x->left; + } + + RBT_ASSERT(x == granpa_x->left->left); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(papa_x)); + RBT_ASSERT(IS_BLACK(granpa_x)); + RBT_ASSERT(IS_BLACK(y)); + + SET_BLACK(papa_x); + SET_RED(granpa_x); + right_rotate(root, granpa_x); + + RBT_ASSERT(x == parent(x)->left); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(parent(x)->right)); + RBT_ASSERT(IS_BLACK(parent(x))); + break; + } + } + else { + RBT_ASSERT(papa_x == granpa_x->right); + y = granpa_x->left; + if (IS_RED(y)) { + SET_BLACK(y); + SET_BLACK(papa_x); + SET_RED(granpa_x); + x = granpa_x; + } + else { + + if (x == papa_x->left) { + right_rotate(root, papa_x); + papa_x = x; + x = papa_x->right; + } + + RBT_ASSERT(x == granpa_x->right->right); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(papa_x)); + RBT_ASSERT(IS_BLACK(granpa_x)); + RBT_ASSERT(IS_BLACK(y)); + + SET_BLACK(papa_x); + SET_RED(granpa_x); + left_rotate(root, granpa_x); + + RBT_ASSERT(x == parent(x)->right); + RBT_ASSERT(IS_RED(x)); + RBT_ASSERT(IS_RED(parent(x)->left)); + RBT_ASSERT(IS_BLACK(parent(x))); + break; + } + } + } while (x != *root && (papa_x=parent(x), IS_RED(papa_x))); + + SET_BLACK(*root); +} + +static void +rbt_delete(RBTree* tree, RBTNode* del) +{ + Uint spliced_is_black; + RBTNode *x, *y, *z = del, *papa_y; + RBTNode null_x; /* null_x is used to get the fixup started when we + splice out a node without children. */ + + HARD_CHECK_IS_MEMBER(tree->root, del); + HARD_CHECK_TREE(tree, 0); + + null_x.parent_and_color = parent_and_color(NULL, !RED_FLG); + + /* Remove node from tree... */ + + /* Find node to splice out */ + if (!z->left || !z->right) + y = z; + else + /* Set y to z:s successor */ + for(y = z->right; y->left; y = y->left); + /* splice out y */ + x = y->left ? y->left : y->right; + spliced_is_black = IS_BLACK(y); + papa_y = parent(y); + if (x) { + set_parent(x, papa_y); + } + else if (spliced_is_black) { + x = &null_x; + x->right = x->left = NULL; + x->parent_and_color = parent_and_color(papa_y, !RED_FLG); + y->left = x; + } + + if (!papa_y) { + RBT_ASSERT(tree->root == y); + tree->root = x; + } + else { + if (y == papa_y->left) { + papa_y->left = x; + } + else { + RBT_ASSERT(y == papa_y->right); + papa_y->right = x; + } + } + if (y != z) { + /* We spliced out the successor of z; replace z by the successor */ + RBT_ASSERT(z != &null_x); + replace(&tree->root, z, y); + } + + if (spliced_is_black) { + RBTNode* papa_x; + /* We removed a black node which makes the resulting tree + violate the Red-Black Tree properties. Fixup tree... */ + + papa_x = parent(x); + while (IS_BLACK(x) && papa_x) { + + /* + * x has an "extra black" which we move up the tree + * until we reach the root or until we can get rid of it. + * + * y is the sibbling of x + */ + + if (x == papa_x->left) { + y = papa_x->right; + RBT_ASSERT(y); + if (IS_RED(y)) { + RBT_ASSERT(y->right); + RBT_ASSERT(y->left); + SET_BLACK(y); + RBT_ASSERT(IS_BLACK(papa_x)); + SET_RED(papa_x); + left_rotate(&tree->root, papa_x); + RBT_ASSERT(papa_x == parent(x)); + y = papa_x->right; + } + RBT_ASSERT(y); + RBT_ASSERT(IS_BLACK(y)); + if (IS_BLACK(y->left) && IS_BLACK(y->right)) { + SET_RED(y); + } + else { + if (IS_BLACK(y->right)) { + SET_BLACK(y->left); + SET_RED(y); + right_rotate(&tree->root, y); + RBT_ASSERT(papa_x == parent(x)); + y = papa_x->right; + } + RBT_ASSERT(y); + if (IS_RED(papa_x)) { + + SET_BLACK(papa_x); + SET_RED(y); + } + RBT_ASSERT(y->right); + SET_BLACK(y->right); + left_rotate(&tree->root, papa_x); + x = tree->root; + break; + } + } + else { + RBT_ASSERT(x == papa_x->right); + y = papa_x->left; + RBT_ASSERT(y); + if (IS_RED(y)) { + RBT_ASSERT(y->right); + RBT_ASSERT(y->left); + SET_BLACK(y); + RBT_ASSERT(IS_BLACK(papa_x)); + SET_RED(papa_x); + right_rotate(&tree->root, papa_x); + RBT_ASSERT(papa_x == parent(x)); + y = papa_x->left; + } + RBT_ASSERT(y); + RBT_ASSERT(IS_BLACK(y)); + if (IS_BLACK(y->right) && IS_BLACK(y->left)) { + SET_RED(y); + } + else { + if (IS_BLACK(y->left)) { + SET_BLACK(y->right); + SET_RED(y); + left_rotate(&tree->root, y); + RBT_ASSERT(papa_x == parent(x)); + y = papa_x->left; + } + RBT_ASSERT(y); + if (IS_RED(papa_x)) { + SET_BLACK(papa_x); + SET_RED(y); + } + RBT_ASSERT(y->left); + SET_BLACK(y->left); + right_rotate(&tree->root, papa_x); + x = tree->root; + break; + } + } + x = papa_x; + papa_x = parent(x); + } + SET_BLACK(x); + + papa_x = parent(&null_x); + if (papa_x) { + if (papa_x->left == &null_x) + papa_x->left = NULL; + else { + RBT_ASSERT(papa_x->right == &null_x); + papa_x->right = NULL; + } + RBT_ASSERT(!null_x.left); + RBT_ASSERT(!null_x.right); + } + else if (tree->root == &null_x) { + tree->root = NULL; + RBT_ASSERT(!null_x.left); + RBT_ASSERT(!null_x.right); + } + } + HARD_CHECK_TREE(tree, 0); +} + + +static void +rbt_insert(RBTree* tree, RBTNode* node) +{ +#ifdef RBT_DEBUG + ErtsFreeSegDesc *dbg_under=NULL, *dbg_over=NULL; +#endif + ErtsFreeSegDesc* desc = node_to_desc(tree->order, node); + char* seg_addr = desc->start; + SWord seg_sz = desc->end - desc->start; + + HARD_CHECK_TREE(tree, 0); + + node->left = NULL; + node->right = NULL; + + if (!tree->root) { + node->parent_and_color = parent_and_color(NULL, !RED_FLG); + tree->root = node; + } + else { + RBTNode *x = tree->root; + while (1) { + SWord diff = cmp_with_node(tree->order, seg_sz, seg_addr, x); + if (diff < 0) { + IF_RBT_DEBUG(dbg_over = node_to_desc(tree->order, x)); + if (!x->left) { + node->parent_and_color = parent_and_color(x, RED_FLG); + x->left = node; + break; + } + x = x->left; + } + else { + RBT_ASSERT(diff > 0); + IF_RBT_DEBUG(dbg_under = node_to_desc(tree->order, x)); + if (!x->right) { + node->parent_and_color = parent_and_color(x, RED_FLG); + x->right = node; + break; + } + x = x->right; + } + } + + RBT_ASSERT(parent(node)); +#ifdef RBT_DEBUG + if (tree->order == ADDR_ORDER) { + RBT_ASSERT(!dbg_under || dbg_under->end < desc->start); + RBT_ASSERT(!dbg_over || dbg_over->start > desc->end); + } +#endif + RBT_ASSERT(IS_RED(node)); + if (IS_RED(parent(node))) + tree_insert_fixup(&tree->root, node); + } + HARD_CHECK_TREE(tree, 0); +} + +/* + * Traverse tree in (reverse) sorting order + */ +static void +rbt_foreach_node(RBTree* tree, + void (*fn)(RBTNode*,void*), + void* arg, int reverse) +{ +#ifdef HARD_DEBUG + Sint blacks = -1; + Sint curr_blacks = 1; + Uint depth = 1; + Uint max_depth = 0; + Uint node_cnt = 0; +#endif + enum { RECURSE_LEFT, DO_NODE, RECURSE_RIGHT, RETURN_TO_PARENT }state; + RBTNode *x = tree->root; + + RBT_ASSERT(!x || !parent(x)); + + state = reverse ? RECURSE_RIGHT : RECURSE_LEFT; + while (x) { + switch (state) { + case RECURSE_LEFT: + if (x->left) { + RBT_ASSERT(parent(x->left) == x); + #ifdef HARD_DEBUG + ++depth; + if (IS_BLACK(x->left)) + curr_blacks++; + #endif + x = x->left; + state = reverse ? RECURSE_RIGHT : RECURSE_LEFT; + } + else { + #ifdef HARD_DEBUG + if (blacks < 0) + blacks = curr_blacks; + RBT_ASSERT(blacks == curr_blacks); + #endif + state = reverse ? RETURN_TO_PARENT : DO_NODE; + } + break; + + case DO_NODE: + #ifdef HARD_DEBUG + ++node_cnt; + if (depth > max_depth) + max_depth = depth; + #endif + (*fn) (x, arg); /* Do it! */ + state = reverse ? RECURSE_LEFT : RECURSE_RIGHT; + break; + + case RECURSE_RIGHT: + if (x->right) { + RBT_ASSERT(parent(x->right) == x); + #ifdef HARD_DEBUG + ++depth; + if (IS_BLACK(x->right)) + curr_blacks++; + #endif + x = x->right; + state = reverse ? RECURSE_RIGHT : RECURSE_LEFT; + } + else { + #ifdef HARD_DEBUG + if (blacks < 0) + blacks = curr_blacks; + RBT_ASSERT(blacks == curr_blacks); + #endif + state = reverse ? DO_NODE : RETURN_TO_PARENT; + } + break; + + case RETURN_TO_PARENT: + #ifdef HARD_DEBUG + if (IS_BLACK(x)) + curr_blacks--; + --depth; + #endif + if (parent(x)) { + if (x == parent(x)->left) { + state = reverse ? RETURN_TO_PARENT : DO_NODE; + } + else { + RBT_ASSERT(x == parent(x)->right); + state = reverse ? DO_NODE : RETURN_TO_PARENT; + } + } + x = parent(x); + break; + } + } +#ifdef HARD_DEBUG + RBT_ASSERT(depth == 0 || (!tree->root && depth==1)); + RBT_ASSERT(curr_blacks == 0); + RBT_ASSERT((1 << (max_depth/2)) <= node_cnt); +#endif +} + +#if defined(RBT_DEBUG) || defined(HARD_DEBUG_MSEG) +static RBTNode* rbt_prev_node(RBTNode* node) +{ + RBTNode* x; + if (node->left) { + for (x=node->left; x->right; x=x->right) + ; + return x; + } + for (x=node; parent(x); x=parent(x)) { + if (parent(x)->right == x) + return parent(x); + } + return NULL; +} +static RBTNode* rbt_next_node(RBTNode* node) +{ + RBTNode* x; + if (node->right) { + for (x=node->right; x->left; x=x->left) + ; + return x; + } + for (x=node; parent(x); x=parent(x)) { + if (parent(x)->left == x) + return parent(x); + } + return NULL; +} +#endif /* RBT_DEBUG || HARD_DEBUG_MSEG */ + + +/* The API to keep track of a bunch of separated (free) segments + (non-overlapping and non-adjacent). + */ +static void init_free_seg_map(ErtsFreeSegMap*, enum SortOrder); +static void adjacent_free_seg(ErtsFreeSegMap*, char* start, char* end, + ErtsFreeSegDesc** under, ErtsFreeSegDesc** over); +static void insert_free_seg(ErtsFreeSegMap*, ErtsFreeSegDesc*, char* start, char* end); +static void resize_free_seg(ErtsFreeSegMap*, ErtsFreeSegDesc*, char* start, char* end); +static void delete_free_seg(ErtsFreeSegMap*, ErtsFreeSegDesc*); +static ErtsFreeSegDesc* lookup_free_seg(ErtsFreeSegMap*, SWord sz); + + +static void init_free_seg_map(ErtsFreeSegMap* map, enum SortOrder order) +{ + map->atree.root = NULL; + map->atree.order = ADDR_ORDER; + map->stree.root = NULL; + map->stree.order = order; + map->nseg = 0; +} + +/* Lookup directly adjacent free segments to the given area [start->end]. + * The given area must not contain any free segments. + */ +static void adjacent_free_seg(ErtsFreeSegMap* map, char* start, char* end, + ErtsFreeSegDesc** under, ErtsFreeSegDesc** over) +{ + RBTNode* x = map->atree.root; + + *under = NULL; + *over = NULL; + while (x) { + if (start < anode_to_desc(x)->start) { + RBT_ASSERT(end <= anode_to_desc(x)->start); + if (end == anode_to_desc(x)->start) { + RBT_ASSERT(!*over); + *over = anode_to_desc(x); + } + x = x->left; + } + else { + RBT_ASSERT(start >= anode_to_desc(x)->end); + if (start == anode_to_desc(x)->end) { + RBT_ASSERT(!*under); + *under = anode_to_desc(x); + } + x = x->right; + } + } +} + +/* Initialize 'desc' and insert as new free segment [start->end]. + * The new segment must not contain or be adjacent to any free segment in 'map'. + */ +static void insert_free_seg(ErtsFreeSegMap* map, ErtsFreeSegDesc* desc, + char* start, char* end) +{ + desc->start = start; + desc->end = end; + rbt_insert(&map->atree, &desc->anode); + rbt_insert(&map->stree, &desc->snode); + map->nseg++; +} + +/* Resize existing free segment 'desc' to [start->end]. + * The new segment location must overlap the old location and + * it must not contain or be adjacent to any other free segment in 'map'. + */ +static void resize_free_seg(ErtsFreeSegMap* map, ErtsFreeSegDesc* desc, + char* start, char* end) +{ +#ifdef RBT_DEBUG + RBTNode* prev = rbt_prev_node(&desc->anode); + RBTNode* next = rbt_next_node(&desc->anode); + RBT_ASSERT(!prev || anode_to_desc(prev)->end < start); + RBT_ASSERT(!next || anode_to_desc(next)->start > end); +#endif + rbt_delete(&map->stree, &desc->snode); + desc->start = start; + desc->end = end; + rbt_insert(&map->stree, &desc->snode); +} + +/* Delete existing free segment 'desc' from 'map'. + */ +static void delete_free_seg(ErtsFreeSegMap* map, ErtsFreeSegDesc* desc) +{ + rbt_delete(&map->atree, &desc->anode); + rbt_delete(&map->stree, &desc->snode); + map->nseg--; +} + +/* Lookup a free segment in 'map' with a size of at least 'need_sz' usable bytes. + */ +static ErtsFreeSegDesc* lookup_free_seg(ErtsFreeSegMap* map, SWord need_sz) +{ + RBTNode* x = map->stree.root; + ErtsFreeSegDesc* best_desc = NULL; + const enum SortOrder order = map->stree.order; + + while (x) { + ErtsFreeSegDesc* desc = snode_to_desc(x); + SWord seg_sz = usable_size(order, desc); + + if (seg_sz < need_sz) { + x = x->right; + } + else { + best_desc = desc; + x = x->left; + } + } + return best_desc; +} + +struct build_arg_t +{ + Process* p; + Eterm* hp; + Eterm acc; +}; + +static void build_free_seg_tuple(RBTNode* node, void* arg) +{ + struct build_arg_t* a = (struct build_arg_t*)arg; + ErtsFreeSegDesc* desc = anode_to_desc(node); + Eterm start= erts_bld_uword(&a->hp, NULL, (UWord)desc->start); + Eterm end = erts_bld_uword(&a->hp, NULL, (UWord)desc->end); + Eterm tpl = TUPLE2(a->hp, start, end); + + a->hp += 3; + a->acc = CONS(a->hp, tpl, a->acc); + a->hp += 2; +} + +static +Eterm build_free_seg_list(Process* p, ErtsFreeSegMap* map) +{ + struct build_arg_t barg; + Eterm* hp_end; + const Uint may_need = map->nseg * (2 + 3 + 2*2); /* cons + tuple + bigs */ + + barg.p = p; + barg.hp = HAlloc(p, may_need); + hp_end = barg.hp + may_need; + barg.acc = NIL; + rbt_foreach_node(&map->atree, build_free_seg_tuple, &barg, 1); + + RBT_ASSERT(barg.hp <= hp_end); + HRelease(p, hp_end, barg.hp); + return barg.acc; +} + +#if ERTS_HAVE_OS_MMAP +/* Implementation of os_mmap()/os_munmap()/os_mremap()... */ + +#if HAVE_MMAP +# define ERTS_MMAP_PROT (PROT_READ|PROT_WRITE) +# if defined(MAP_ANONYMOUS) +# define ERTS_MMAP_FLAGS (MAP_ANON|MAP_PRIVATE) +# define ERTS_MMAP_FD (-1) +# elif defined(MAP_ANON) +# define ERTS_MMAP_FLAGS (MAP_ANON|MAP_PRIVATE) +# define ERTS_MMAP_FD (-1) +# else +# define ERTS_MMAP_FLAGS (MAP_PRIVATE) +# define ERTS_MMAP_FD mmap_state.mmap_fd +# endif +#endif + +static ERTS_INLINE void * +os_mmap(void *hint_ptr, UWord size, int try_superalign) +{ +#if HAVE_MMAP + void *res; +#ifdef MAP_ALIGN + if (try_superalign) + res = mmap((void *) ERTS_SUPERALIGNED_SIZE, size, ERTS_MMAP_PROT, + ERTS_MMAP_FLAGS|MAP_ALIGN, ERTS_MMAP_FD, 0); + else +#endif + res = mmap((void *) hint_ptr, size, ERTS_MMAP_PROT, + ERTS_MMAP_FLAGS, ERTS_MMAP_FD, 0); + if (res == MAP_FAILED) + return NULL; + return res; +#elif HAVE_VIRTUALALLOC + return (void *) VirtualAlloc(NULL, (SIZE_T) size, + MEM_COMMIT|MEM_RESERVE, PAGE_READWRITE); +#else +# error "missing mmap() or similar" +#endif +} + +static ERTS_INLINE void +os_munmap(void *ptr, UWord size) +{ +#if HAVE_MMAP +#ifdef ERTS_MMAP_DEBUG + int res = +#endif + munmap(ptr, size); + ERTS_MMAP_ASSERT(res == 0); +#elif HAVE_VIRTUALALLOC +#ifdef DEBUG + BOOL res = +#endif + VirtualFree((LPVOID) ptr, (SIZE_T) 0, MEM_RELEASE); + ERTS_MMAP_ASSERT(res != 0); +#else +# error "missing munmap() or similar" +#endif +} + +#ifdef ERTS_HAVE_OS_MREMAP +# if HAVE_MREMAP +# if defined(__NetBSD__) +# define ERTS_MREMAP_FLAGS (0) +# else +# define ERTS_MREMAP_FLAGS (MREMAP_MAYMOVE) +# endif +# endif +static ERTS_INLINE void * +os_mremap(void *ptr, UWord old_size, UWord new_size, int try_superalign) +{ + void *new_seg; +#if HAVE_MREMAP + new_seg = mremap(ptr, (size_t) old_size, +# if defined(__NetBSD__) + NULL, +# endif + (size_t) new_size, ERTS_MREMAP_FLAGS); + if (new_seg == (void *) MAP_FAILED) + return NULL; + return new_seg; +#else +# error "missing mremap() or similar" +#endif +} +#endif + +#ifdef ERTS_HAVE_OS_PHYSICAL_MEMORY_RESERVATION +#if HAVE_MMAP + +#define ERTS_MMAP_RESERVE_PROT (ERTS_MMAP_PROT) +#define ERTS_MMAP_RESERVE_FLAGS (ERTS_MMAP_FLAGS|MAP_FIXED) +#define ERTS_MMAP_UNRESERVE_PROT (PROT_NONE) +#define ERTS_MMAP_UNRESERVE_FLAGS (ERTS_MMAP_FLAGS|MAP_NORESERVE|MAP_FIXED) +#define ERTS_MMAP_VIRTUAL_PROT (PROT_NONE) +#define ERTS_MMAP_VIRTUAL_FLAGS (ERTS_MMAP_FLAGS|MAP_NORESERVE) + +static int +os_reserve_physical(char *ptr, UWord size) +{ + void *res = mmap((void *) ptr, (size_t) size, ERTS_MMAP_RESERVE_PROT, + ERTS_MMAP_RESERVE_FLAGS, ERTS_MMAP_FD, 0); + if (res == (void *) MAP_FAILED) + return 0; + return 1; +} + +static void +os_unreserve_physical(char *ptr, UWord size) +{ + void *res = mmap((void *) ptr, (size_t) size, ERTS_MMAP_UNRESERVE_PROT, + ERTS_MMAP_UNRESERVE_FLAGS, ERTS_MMAP_FD, 0); + if (res == (void *) MAP_FAILED) + erl_exit(ERTS_ABORT_EXIT, "Failed to unreserve memory"); +} + +static void * +os_mmap_virtual(char *ptr, UWord size) +{ + void *res = mmap((void *) ptr, (size_t) size, ERTS_MMAP_VIRTUAL_PROT, + ERTS_MMAP_VIRTUAL_FLAGS, ERTS_MMAP_FD, 0); + if (res == (void *) MAP_FAILED) + return NULL; + return res; +} + +#else +#error "Missing reserve/unreserve physical memory implementation" +#endif +#endif /* ERTS_HAVE_OS_RESERVE_PHYSICAL_MEMORY */ + +#endif /* ERTS_HAVE_OS_MMAP */ + +static int reserve_noop(char *ptr, UWord size) +{ +#ifdef ERTS_MMAP_DEBUG_FILL_AREAS + Uint32 *uip, *end = (Uint32 *) (ptr + size); + + for (uip = (Uint32 *) ptr; uip < end; uip++) + ERTS_MMAP_ASSERT(*uip == (Uint32) 0xdeadbeef); + for (uip = (Uint32 *) ptr; uip < end; uip++) + *uip = (Uint32) 0xfeedfeed; +#endif + return 1; +} + +static void unreserve_noop(char *ptr, UWord size) +{ +#ifdef ERTS_MMAP_DEBUG_FILL_AREAS + Uint32 *uip, *end = (Uint32 *) (ptr + size); + + for (uip = (Uint32 *) ptr; uip < end; uip++) + *uip = (Uint32) 0xdeadbeef; +#endif +} + +static UWord +alloc_desc_insert_free_seg(ErtsFreeSegMap *map, char* start, char* end) +{ + char *ptr; + ErtsFreeSegMap *da_map; + ErtsFreeSegDesc *desc = alloc_desc(); + if (desc) { + insert_free_seg(map, desc, start, end); + return 0; + } + + /* + * Ahh; ran out of free segment descriptors. + * + * First try to map a new page... + */ + +#if ERTS_HAVE_OS_MMAP + if (!mmap_state.no_os_mmap) { + ptr = os_mmap(mmap_state.desc.new_area_hint, ERTS_PAGEALIGNED_SIZE, 0); + if (ptr) { + mmap_state.desc.new_area_hint = ptr+ERTS_PAGEALIGNED_SIZE; + ERTS_MMAP_SIZE_OS_INC(ERTS_PAGEALIGNED_SIZE); + add_free_desc_area(ptr, ptr+ERTS_PAGEALIGNED_SIZE); + desc = alloc_desc(); + ERTS_MMAP_ASSERT(desc); + insert_free_seg(map, desc, start, end); + return 0; + } + } +#endif + + /* + * ...then try to find a good place in the supercarrier... + */ + da_map = &mmap_state.sua.map; + desc = lookup_free_seg(da_map, ERTS_PAGEALIGNED_SIZE); + if (desc) { + if (mmap_state.reserve_physical(desc->start, ERTS_PAGEALIGNED_SIZE)) + ERTS_MMAP_SIZE_SC_SUA_INC(ERTS_PAGEALIGNED_SIZE); + else + desc = NULL; + + } + else { + da_map = &mmap_state.sa.map; + desc = lookup_free_seg(da_map, ERTS_PAGEALIGNED_SIZE); + if (desc) { + if (mmap_state.reserve_physical(desc->start, ERTS_PAGEALIGNED_SIZE)) + ERTS_MMAP_SIZE_SC_SA_INC(ERTS_PAGEALIGNED_SIZE); + else + desc = NULL; + } + } + if (desc) { + char *da_end = desc->start + ERTS_PAGEALIGNED_SIZE; + add_free_desc_area(desc->start, da_end); + if (da_end != desc->end) + resize_free_seg(da_map, desc, da_end, desc->end); + else { + delete_free_seg(da_map, desc); + free_desc(desc); + } + + desc = alloc_desc(); + ERTS_MMAP_ASSERT(desc); + insert_free_seg(map, desc, start, end); + return 0; + } + + /* + * ... and then as last resort use the first page of the + * free segment we are trying to insert for free descriptors. + */ + ptr = start + ERTS_PAGEALIGNED_SIZE; + ERTS_MMAP_ASSERT(ptr <= end); + + add_free_desc_area(start, ptr); + + if (ptr != end) { + desc = alloc_desc(); + ERTS_MMAP_ASSERT(desc); + insert_free_seg(map, desc, ptr, end); + } + + return ERTS_PAGEALIGNED_SIZE; +} + +void * +erts_mmap(Uint32 flags, UWord *sizep) +{ + char *seg; + UWord asize = ERTS_PAGEALIGNED_CEILING(*sizep); + + /* Map in premapped supercarrier */ + if (mmap_state.supercarrier && !(ERTS_MMAPFLG_OS_ONLY & flags)) { + char *end; + ErtsFreeSegDesc *desc; + Uint32 superaligned = (ERTS_MMAPFLG_SUPERALIGNED & flags); + + erts_smp_mtx_lock(&mmap_state.mtx); + + ERTS_MMAP_OP_START(*sizep); + + if (!superaligned) { + desc = lookup_free_seg(&mmap_state.sua.map, asize); + if (desc) { + seg = desc->start; + end = seg+asize; + if (!mmap_state.reserve_physical(seg, asize)) + goto supercarrier_reserve_failure; + if (desc->end == end) { + delete_free_seg(&mmap_state.sua.map, desc); + free_desc(desc); + } + else { + ERTS_MMAP_ASSERT(end < desc->end); + resize_free_seg(&mmap_state.sua.map, desc, end, desc->end); + } + ERTS_MMAP_SIZE_SC_SUA_INC(asize); + goto supercarrier_success; + } + + if (asize <= mmap_state.sua.bot - mmap_state.sa.top) { + if (!mmap_state.reserve_physical(mmap_state.sua.bot - asize, + asize)) + goto supercarrier_reserve_failure; + mmap_state.sua.bot -= asize; + seg = mmap_state.sua.bot; + ERTS_MMAP_SIZE_SC_SUA_INC(asize); + goto supercarrier_success; + } + } + + asize = ERTS_SUPERALIGNED_CEILING(asize); + + desc = lookup_free_seg(&mmap_state.sa.map, asize); + if (desc) { + char *start = seg = desc->start; + seg = (char *) ERTS_SUPERALIGNED_CEILING(seg); + end = seg+asize; + if (!mmap_state.reserve_physical(start, (UWord) (end - start))) + goto supercarrier_reserve_failure; + ERTS_MMAP_SIZE_SC_SA_INC(asize); + if (desc->end == end) { + if (start != seg) + resize_free_seg(&mmap_state.sa.map, desc, start, seg); + else { + delete_free_seg(&mmap_state.sa.map, desc); + free_desc(desc); + } + } + else { + ERTS_MMAP_ASSERT(end < desc->end); + resize_free_seg(&mmap_state.sa.map, desc, end, desc->end); + if (start != seg) { + UWord ad_sz; + ad_sz = alloc_desc_insert_free_seg(&mmap_state.sua.map, + start, seg); + start += ad_sz; + if (start != seg) + mmap_state.unreserve_physical(start, (UWord) (seg - start)); + } + } + goto supercarrier_success; + } + + if (superaligned) { + char *start = mmap_state.sa.top; + seg = (char *) ERTS_SUPERALIGNED_CEILING(start); + + if (asize + (seg - start) <= mmap_state.sua.bot - start) { + end = seg + asize; + if (!mmap_state.reserve_physical(start, (UWord) (end - start))) + goto supercarrier_reserve_failure; + mmap_state.sa.top = end; + ERTS_MMAP_SIZE_SC_SA_INC(asize); + if (start != seg) { + UWord ad_sz; + ad_sz = alloc_desc_insert_free_seg(&mmap_state.sua.map, + start, seg); + start += ad_sz; + if (start != seg) + mmap_state.unreserve_physical(start, (UWord) (seg - start)); + } + goto supercarrier_success; + } + + desc = lookup_free_seg(&mmap_state.sua.map, asize + ERTS_SUPERALIGNED_SIZE); + if (desc) { + char *org_start = desc->start; + char *org_end = desc->end; + + seg = (char *) ERTS_SUPERALIGNED_CEILING(org_start); + end = seg + asize; + if (!mmap_state.reserve_physical(seg, (UWord) (org_end - seg))) + goto supercarrier_reserve_failure; + ERTS_MMAP_SIZE_SC_SUA_INC(asize); + if (org_start != seg) { + ERTS_MMAP_ASSERT(org_start < seg); + resize_free_seg(&mmap_state.sua.map, desc, org_start, seg); + desc = NULL; + } + if (end != org_end) { + UWord ad_sz = 0; + ERTS_MMAP_ASSERT(end < org_end); + if (desc) + resize_free_seg(&mmap_state.sua.map, desc, end, org_end); + else + ad_sz = alloc_desc_insert_free_seg(&mmap_state.sua.map, + end, org_end); + end += ad_sz; + if (end != org_end) + mmap_state.unreserve_physical(end, + (UWord) (org_end - end)); + } + goto supercarrier_success; + } + } + + ERTS_MMAP_OP_ABORT(); + erts_smp_mtx_unlock(&mmap_state.mtx); + } + +#if ERTS_HAVE_OS_MMAP + /* Map using OS primitives */ + if (!(ERTS_MMAPFLG_SUPERCARRIER_ONLY & flags) && !mmap_state.no_os_mmap) { + if (!(ERTS_MMAPFLG_SUPERALIGNED & flags)) { + seg = os_mmap(NULL, asize, 0); + if (!seg) + goto failure; + } + else { + asize = ERTS_SUPERALIGNED_CEILING(*sizep); + seg = os_mmap(NULL, asize, 1); + if (!seg) + goto failure; + + if (!ERTS_IS_SUPERALIGNED(seg)) { + char *ptr; + UWord sz; + + os_munmap(seg, asize); + + ptr = os_mmap(NULL, asize + ERTS_SUPERALIGNED_SIZE, 1); + if (!ptr) + goto failure; + + seg = (char *) ERTS_SUPERALIGNED_CEILING(ptr); + sz = (UWord) (seg - ptr); + ERTS_MMAP_ASSERT(sz <= ERTS_SUPERALIGNED_SIZE); + if (sz) + os_munmap(ptr, sz); + sz = ERTS_SUPERALIGNED_SIZE - sz; + if (sz) + os_munmap(seg+asize, sz); + } + } + + ERTS_MMAP_OP_LCK(seg, *sizep, asize); + ERTS_MMAP_SIZE_OS_INC(asize); + *sizep = asize; + return (void *) seg; + } +failure: +#endif + ERTS_MMAP_OP_LCK(NULL, *sizep, 0); + *sizep = 0; + return NULL; + +supercarrier_success: + +#ifdef ERTS_MMAP_DEBUG + if (ERTS_MMAPFLG_SUPERALIGNED & flags) { + ERTS_MMAP_ASSERT(ERTS_IS_SUPERALIGNED(seg)); + ERTS_MMAP_ASSERT(ERTS_IS_SUPERALIGNED(asize)); + } + else { + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(seg)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(asize)); + } +#endif + + ERTS_MMAP_OP_END(seg, asize); + erts_smp_mtx_unlock(&mmap_state.mtx); + + *sizep = asize; + return (void *) seg; + +supercarrier_reserve_failure: + erts_smp_mtx_unlock(&mmap_state.mtx); + *sizep = 0; + return NULL; +} + +void +erts_munmap(Uint32 flags, void *ptr, UWord size) +{ + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(ptr)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(size)); + + if (!ERTS_MMAP_IN_SUPERCARRIER(ptr)) { + ERTS_MMAP_ASSERT(!mmap_state.no_os_mmap); +#if ERTS_HAVE_OS_MMAP + ERTS_MUNMAP_OP_LCK(ptr, size); + ERTS_MMAP_SIZE_OS_DEC(size); + os_munmap(ptr, size); +#endif + } + else { + char *start, *end; + ErtsFreeSegMap *map; + ErtsFreeSegDesc *prev, *next, *desc; + UWord ad_sz = 0; + + ERTS_MMAP_ASSERT(mmap_state.supercarrier); + + start = (char *) ptr; + end = start + size; + + erts_smp_mtx_lock(&mmap_state.mtx); + + ERTS_MUNMAP_OP(ptr, size); + + if (ERTS_MMAP_IN_SUPERALIGNED_AREA(ptr)) { + + map = &mmap_state.sa.map; + adjacent_free_seg(map, start, end, &prev, &next); + + ERTS_MMAP_SIZE_SC_SA_DEC(size); + if (end == mmap_state.sa.top) { + ERTS_MMAP_ASSERT(!next); + if (prev) { + start = prev->start; + delete_free_seg(map, prev); + free_desc(prev); + } + mmap_state.sa.top = start; + goto supercarrier_success; + } + } + else { + map = &mmap_state.sua.map; + adjacent_free_seg(map, start, end, &prev, &next); + + ERTS_MMAP_SIZE_SC_SUA_DEC(size); + if (start == mmap_state.sua.bot) { + ERTS_MMAP_ASSERT(!prev); + if (next) { + end = next->end; + delete_free_seg(map, next); + free_desc(next); + } + mmap_state.sua.bot = end; + goto supercarrier_success; + } + } + + desc = NULL; + + if (next) { + ERTS_MMAP_ASSERT(end < next->end); + end = next->end; + if (prev) { + delete_free_seg(map, next); + free_desc(next); + goto save_prev; + } + desc = next; + } else if (prev) { + save_prev: + ERTS_MMAP_ASSERT(prev->start < start); + start = prev->start; + desc = prev; + } + + if (desc) + resize_free_seg(map, desc, start, end); + else + ad_sz = alloc_desc_insert_free_seg(map, start, end); + + supercarrier_success: { + UWord unres_sz; + + ERTS_MMAP_ASSERT(size >= ad_sz); + unres_sz = size - ad_sz; + if (unres_sz) + mmap_state.unreserve_physical(((char *) ptr) + ad_sz, unres_sz); + + erts_smp_mtx_unlock(&mmap_state.mtx); + } + } +} + +static void * +remap_move(Uint32 flags, void *ptr, UWord old_size, UWord *sizep) +{ + UWord size = *sizep; + void *new_ptr = erts_mmap(flags, &size); + if (!new_ptr) + return NULL; + *sizep = size; + if (old_size < size) + size = old_size; + sys_memcpy(new_ptr, ptr, (size_t) size); + erts_munmap(flags, ptr, old_size); + return new_ptr; +} + +void * +erts_mremap(Uint32 flags, void *ptr, UWord old_size, UWord *sizep) +{ + void *new_ptr; + Uint32 superaligned; + UWord asize; + + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(ptr)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(old_size)); + ERTS_MMAP_ASSERT(sizep && ERTS_IS_PAGEALIGNED(*sizep)); + + if (!ERTS_MMAP_IN_SUPERCARRIER(ptr)) { + + ERTS_MMAP_ASSERT(!mmap_state.no_os_mmap); + + if (!(ERTS_MMAPFLG_OS_ONLY & flags) && mmap_state.supercarrier) { + new_ptr = remap_move(ERTS_MMAPFLG_SUPERCARRIER_ONLY|flags, ptr, + old_size, sizep); + if (new_ptr) + return new_ptr; + } + + if (ERTS_MMAPFLG_SUPERCARRIER_ONLY & flags) { + ERTS_MREMAP_OP_LCK(NULL, ptr, old_size, *sizep, old_size); + return NULL; + } + +#if ERTS_HAVE_OS_MREMAP || ERTS_HAVE_GENUINE_OS_MMAP + superaligned = (ERTS_MMAPFLG_SUPERALIGNED & flags); + + if (superaligned) { + asize = ERTS_SUPERALIGNED_CEILING(*sizep); + if (asize == old_size && ERTS_IS_SUPERALIGNED(ptr)) { + ERTS_MREMAP_OP_LCK(ptr, ptr, old_size, *sizep, asize); + *sizep = asize; + return ptr; + } + } + else { + asize = ERTS_PAGEALIGNED_CEILING(*sizep); + if (asize == old_size) { + ERTS_MREMAP_OP_LCK(ptr, ptr, old_size, *sizep, asize); + *sizep = asize; + return ptr; + } + } + +#if ERTS_HAVE_GENUINE_OS_MMAP + if (asize < old_size + && (!superaligned + || ERTS_IS_SUPERALIGNED(ptr))) { + UWord um_sz; + new_ptr = ((char *) ptr) + asize; + ERTS_MMAP_ASSERT((((char *)ptr) + old_size) > (char *) new_ptr); + um_sz = (UWord) ((((char *) ptr) + old_size) - (char *) new_ptr); + ERTS_MMAP_SIZE_OS_DEC(um_sz); + os_munmap(new_ptr, um_sz); + ERTS_MREMAP_OP_LCK(ptr, ptr, old_size, *sizep, asize); + *sizep = asize; + return ptr; + } +#endif +#if ERTS_HAVE_OS_MREMAP + if (superaligned) + return remap_move(flags, new_ptr, old_size, sizep); + else { + new_ptr = os_mremap(ptr, old_size, asize, 0); + if (!new_ptr) + return NULL; + if (asize > old_size) + ERTS_MMAP_SIZE_OS_INC(asize - old_size); + else + ERTS_MMAP_SIZE_OS_DEC(old_size - asize); + ERTS_MREMAP_OP_LCK(new_ptr, ptr, old_size, *sizep, asize); + *sizep = asize; + return new_ptr; + } +#endif +#endif + } + else { /* In super carrier */ + char *start, *end, *new_end; + ErtsFreeSegMap *map; + ErtsFreeSegDesc *prev, *next; + UWord ad_sz = 0; + + ERTS_MMAP_ASSERT(mmap_state.supercarrier); + + if (ERTS_MMAPFLG_OS_ONLY & flags) + return remap_move(flags, ptr, old_size, sizep); + + superaligned = (ERTS_MMAPFLG_SUPERALIGNED & flags); + + asize = (superaligned + ? ERTS_SUPERALIGNED_CEILING(*sizep) + : ERTS_PAGEALIGNED_CEILING(*sizep)); + + erts_smp_mtx_lock(&mmap_state.mtx); + + if (ERTS_MMAP_IN_SUPERALIGNED_AREA(ptr) + ? (!superaligned && lookup_free_seg(&mmap_state.sua.map, asize)) + : (superaligned && lookup_free_seg(&mmap_state.sa.map, asize))) { + erts_smp_mtx_unlock(&mmap_state.mtx); + /* + * Segment currently in wrong area (due to a previous memory + * shortage), move it to the right area. + * (remap_move() will succeed) + */ + return remap_move(ERTS_MMAPFLG_SUPERCARRIER_ONLY|flags, ptr, + old_size, sizep); + } + + ERTS_MREMAP_OP_START(ptr, old_size, *sizep); + + if (asize == old_size) { + new_ptr = ptr; + goto supercarrier_resize_success; + } + + start = (char *) ptr; + end = start + old_size; + new_end = start+asize; + + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(ptr)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(old_size)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(asize)); + + if (asize < old_size) { + UWord unres_sz; + new_ptr = ptr; + if (!ERTS_MMAP_IN_SUPERALIGNED_AREA(ptr)) { + map = &mmap_state.sua.map; + ERTS_MMAP_SIZE_SC_SUA_DEC(old_size - asize); + } + else { + if (end == mmap_state.sa.top) { + mmap_state.sa.top = new_end; + mmap_state.unreserve_physical(((char *) ptr) + asize, + old_size - asize); + goto supercarrier_resize_success; + } + ERTS_MMAP_SIZE_SC_SA_DEC(old_size - asize); + map = &mmap_state.sa.map; + } + + adjacent_free_seg(map, start, end, &prev, &next); + + if (next) + resize_free_seg(map, next, new_end, next->end); + else + ad_sz = alloc_desc_insert_free_seg(map, new_end, end); + ERTS_MMAP_ASSERT(old_size - asize >= ad_sz); + unres_sz = old_size - asize - ad_sz; + if (unres_sz) + mmap_state.unreserve_physical(((char *) ptr) + asize + ad_sz, + unres_sz); + goto supercarrier_resize_success; + } + + if (!ERTS_MMAP_IN_SUPERALIGNED_AREA(ptr)) { + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(ptr)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(old_size)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(asize)); + + adjacent_free_seg(&mmap_state.sua.map, start, end, &prev, &next); + + if (next && new_end <= next->end) { + if (!mmap_state.reserve_physical(((char *) ptr) + old_size, + asize - old_size)) + goto supercarrier_reserve_failure; + if (new_end < next->end) + resize_free_seg(&mmap_state.sua.map, next, new_end, next->end); + else { + delete_free_seg(&mmap_state.sua.map, next); + free_desc(next); + } + new_ptr = ptr; + ERTS_MMAP_SIZE_SC_SUA_INC(asize - old_size); + goto supercarrier_resize_success; + } + } + else { /* Superaligned area */ + + if (end == mmap_state.sa.top) { + if (new_end <= mmap_state.sua.bot) { + if (!mmap_state.reserve_physical(((char *) ptr) + old_size, + asize - old_size)) + goto supercarrier_reserve_failure; + mmap_state.sa.top = new_end; + new_ptr = ptr; + ERTS_MMAP_SIZE_SC_SA_INC(asize - old_size); + goto supercarrier_resize_success; + } + } + else { + adjacent_free_seg(&mmap_state.sa.map, start, end, &prev, &next); + if (next && new_end <= next->end) { + if (!mmap_state.reserve_physical(((char *) ptr) + old_size, + asize - old_size)) + goto supercarrier_reserve_failure; + if (new_end < next->end) + resize_free_seg(&mmap_state.sa.map, next, new_end, next->end); + else { + delete_free_seg(&mmap_state.sa.map, next); + free_desc(next); + } + new_ptr = ptr; + ERTS_MMAP_SIZE_SC_SA_INC(asize - old_size); + goto supercarrier_resize_success; + } + } + } + + ERTS_MMAP_OP_ABORT(); + erts_smp_mtx_unlock(&mmap_state.mtx); + + /* Failed to resize... */ + } + + return remap_move(flags, ptr, old_size, sizep); + +supercarrier_resize_success: + +#ifdef ERTS_MMAP_DEBUG + if ((ERTS_MMAPFLG_SUPERALIGNED & flags) + || ERTS_MMAP_IN_SUPERALIGNED_AREA(new_ptr)) { + ERTS_MMAP_ASSERT(ERTS_IS_SUPERALIGNED(new_ptr)); + ERTS_MMAP_ASSERT(ERTS_IS_SUPERALIGNED(asize)); + } + else { + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(new_ptr)); + ERTS_MMAP_ASSERT(ERTS_IS_PAGEALIGNED(asize)); + } +#endif + + ERTS_MREMAP_OP_END(new_ptr, asize); + erts_smp_mtx_unlock(&mmap_state.mtx); + + *sizep = asize; + return new_ptr; + +supercarrier_reserve_failure: + ERTS_MREMAP_OP_END(NULL, old_size); + erts_smp_mtx_unlock(&mmap_state.mtx); + *sizep = old_size; + return NULL; + +} + +int erts_mmap_in_supercarrier(void *ptr) +{ + return ERTS_MMAP_IN_SUPERCARRIER(ptr); +} + + +static struct { + Eterm total; + Eterm total_sa; + Eterm total_sua; + Eterm used; + Eterm used_sa; + Eterm used_sua; + Eterm max; + Eterm allocated; + Eterm reserved; + Eterm sizes; + Eterm free_segs; + Eterm supercarrier; + Eterm os; + Eterm scs; + Eterm sco; + Eterm scrpm; + Eterm scmgc; + + int is_initialized; + erts_mtx_t init_mutex; +}am; + +static void ERTS_INLINE atom_init(Eterm *atom, char *name) +{ + *atom = am_atom_put(name, strlen(name)); +} +#define AM_INIT(AM) atom_init(&am.AM, #AM) + +static void init_atoms(void) +{ + erts_mtx_lock(&am.init_mutex); + + if (!am.is_initialized) { + AM_INIT(total); + AM_INIT(total_sa); + AM_INIT(total_sua); + AM_INIT(used); + AM_INIT(used_sa); + AM_INIT(used_sua); + AM_INIT(max); + AM_INIT(allocated); + AM_INIT(reserved); + AM_INIT(sizes); + AM_INIT(free_segs); + AM_INIT(supercarrier); + AM_INIT(os); + AM_INIT(scs); + AM_INIT(sco); + AM_INIT(scrpm); + AM_INIT(scmgc); + am.is_initialized = 1; + } + erts_mtx_unlock(&am.init_mutex); +}; + + +#ifdef HARD_DEBUG_MSEG +static void hard_dbg_mseg_init(void); +#endif + +void +erts_mmap_init(ErtsMMapInit *init) +{ + int virtual_map = 0; + char *start = NULL, *end = NULL; + UWord pagesize; +#if defined(__WIN32__) + SYSTEM_INFO sysinfo; + GetSystemInfo(&sysinfo); + pagesize = (UWord) sysinfo.dwPageSize; +#elif defined(_SC_PAGESIZE) + pagesize = (UWord) sysconf(_SC_PAGESIZE); +#elif defined(HAVE_GETPAGESIZE) + pagesize = (UWord) getpagesize(); +#else +# error "Do not know how to get page size" +#endif +#if defined(HARD_DEBUG) || 0 + erts_fprintf(stderr, "erts_mmap: scs = %bpu\n", init->scs); + erts_fprintf(stderr, "erts_mmap: sco = %i\n", init->sco); + erts_fprintf(stderr, "erts_mmap: scmgc = %i\n", init->scmgc); +#endif + erts_page_inv_mask = pagesize - 1; + if (pagesize & erts_page_inv_mask) + erl_exit(-1, "erts_mmap: Invalid pagesize: %bpu\n", + pagesize); + + ERTS_MMAP_OP_RINGBUF_INIT(); + + erts_have_erts_mmap = 0; + + mmap_state.supercarrier = 0; + mmap_state.reserve_physical = reserve_noop; + mmap_state.unreserve_physical = unreserve_noop; + +#if HAVE_MMAP && !defined(MAP_ANON) + mmap_state.mmap_fd = open("/dev/zero", O_RDWR); + if (mmap_state.mmap_fd < 0) + erl_exit(-1, "erts_mmap: Failed to open /dev/zero\n"); +#endif + + erts_smp_mtx_init(&mmap_state.mtx, "erts_mmap"); + erts_mtx_init(&am.init_mutex, "mmap_init_atoms"); + +#ifdef ERTS_HAVE_OS_PHYSICAL_MEMORY_RESERVATION + if (init->virtual_range.start) { + char *ptr; + UWord sz; + ptr = (char *) ERTS_PAGEALIGNED_CEILING(init->virtual_range.start); + end = (char *) ERTS_PAGEALIGNED_FLOOR(init->virtual_range.end); + sz = end - ptr; + start = os_mmap_virtual(ptr, sz); + if (!start || start > ptr || start >= end) + erl_exit(-1, + "erts_mmap: Failed to create virtual range for super carrier\n"); + sz = start - ptr; + if (sz) + os_munmap(end, sz); + mmap_state.reserve_physical = os_reserve_physical; + mmap_state.unreserve_physical = os_unreserve_physical; + virtual_map = 1; + } + else +#endif + if (init->predefined_area.start) { + start = init->predefined_area.start; + end = init->predefined_area.end; + if (end != (void *) 0 && end < start) + end = start; + } +#if ERTS_HAVE_OS_MMAP + else if (init->scs) { + UWord sz; + sz = ERTS_PAGEALIGNED_CEILING(init->scs); +#ifdef ERTS_HAVE_OS_PHYSICAL_MEMORY_RESERVATION + if (!init->scrpm) { + start = os_mmap_virtual(NULL, sz); + mmap_state.reserve_physical = os_reserve_physical; + mmap_state.unreserve_physical = os_unreserve_physical; + virtual_map = 1; + } + else +#endif + { + /* + * The whole supercarrier will by physically + * reserved all the time. + */ + start = os_mmap(NULL, sz, 1); + } + if (!start) + erl_exit(-1, + "erts_mmap: Failed to create super carrier of size %bpu MB\n", + init->scs/1024/1024); + end = start + sz; +#ifdef ERTS_MMAP_DEBUG_FILL_AREAS + if (!virtual_map) { + Uint32 *uip; + + for (uip = (Uint32 *) start; uip < (Uint32 *) end; uip++) + *uip = (Uint32) 0xdeadbeef; + } +#endif + } + if (!mmap_state.no_os_mmap) + erts_have_erts_mmap |= ERTS_HAVE_ERTS_OS_MMAP; +#endif + + mmap_state.no.free_seg_descs = 0; + mmap_state.no.free_segs.curr = 0; + mmap_state.no.free_segs.max = 0; + + mmap_state.size.supercarrier.total = 0; + mmap_state.size.supercarrier.used.total = 0; + mmap_state.size.supercarrier.used.sa = 0; + mmap_state.size.supercarrier.used.sua = 0; + mmap_state.size.os.used = 0; + + mmap_state.desc.new_area_hint = NULL; + + if (!start) { + mmap_state.sa.bot = NULL; + mmap_state.sua.top = NULL; + mmap_state.sa.bot = NULL; + mmap_state.sua.top = NULL; + mmap_state.no_os_mmap = 0; + mmap_state.supercarrier = 0; + } + else { + size_t desc_size; + + mmap_state.no_os_mmap = init->sco; + + desc_size = init->scmgc; + if (desc_size < 100) + desc_size = 100; + desc_size *= sizeof(ErtsFreeSegDesc); + if ((desc_size + + ERTS_SUPERALIGNED_SIZE + + ERTS_PAGEALIGNED_SIZE) > end - start) + erl_exit(-1, "erts_mmap: No space for segments in super carrier\n"); + + mmap_state.sa.bot = start; + mmap_state.sa.bot += desc_size; + mmap_state.sa.bot = (char *) ERTS_SUPERALIGNED_CEILING(mmap_state.sa.bot); + mmap_state.sa.top = mmap_state.sa.bot; + mmap_state.sua.top = end; + mmap_state.sua.bot = mmap_state.sua.top; + + mmap_state.size.supercarrier.used.total += (UWord) (mmap_state.sa.bot - start); + + mmap_state.desc.free_list = NULL; + mmap_state.desc.reserved = 0; + + if (end == (void *) 0) { + /* + * Very unlikely, but we need a guarantee + * that `mmap_state.sua.top` always will + * compare as larger than all segment pointers + * into the super carrier... + */ + mmap_state.sua.top -= ERTS_PAGEALIGNED_SIZE; + mmap_state.size.supercarrier.used.total += ERTS_PAGEALIGNED_SIZE; +#ifdef ERTS_HAVE_OS_PHYSICAL_MEMORY_RESERVATION + if (!virtual_map || os_reserve_physical(mmap_state.sua.top, ERTS_PAGEALIGNED_SIZE)) +#endif + add_free_desc_area(mmap_state.sua.top, end); + mmap_state.desc.reserved += (end - mmap_state.sua.top) / sizeof(ErtsFreeSegDesc); + } + + mmap_state.size.supercarrier.total = (UWord) (mmap_state.sua.top - start); + + /* + * Area before (and after) super carrier + * will be used for free segment descritors. + */ +#ifdef ERTS_HAVE_OS_PHYSICAL_MEMORY_RESERVATION + if (virtual_map && !os_reserve_physical(start, mmap_state.sa.bot - start)) + erl_exit(-1, "erts_mmap: Failed to reserve physical memory for descriptors\n"); +#endif + mmap_state.desc.unused_start = start; + mmap_state.desc.unused_end = mmap_state.sa.bot; + mmap_state.desc.reserved += ((mmap_state.desc.unused_end - start) + / sizeof(ErtsFreeSegDesc)); + + init_free_seg_map(&mmap_state.sa.map, SA_SZ_ADDR_ORDER); + init_free_seg_map(&mmap_state.sua.map, SZ_REVERSE_ADDR_ORDER); + + mmap_state.supercarrier = 1; + erts_have_erts_mmap |= ERTS_HAVE_ERTS_SUPERCARRIER_MMAP; + + mmap_state.desc.new_area_hint = end; + + } + +#if !ERTS_HAVE_OS_MMAP + mmap_state.no_os_mmap = 1; +#endif + +#ifdef HARD_DEBUG_MSEG + hard_dbg_mseg_init(); +#endif +} + + +static ERTS_INLINE void +add_2tup(Uint **hpp, Uint *szp, Eterm *lp, Eterm el1, Eterm el2) +{ + *lp = erts_bld_cons(hpp, szp, erts_bld_tuple(hpp, szp, 2, el1, el2), *lp); +} + +Eterm erts_mmap_info(int *print_to_p, + void *print_to_arg, + Eterm** hpp, Uint* szp, + struct erts_mmap_info_struct* emis) +{ + Eterm size_tags[] = { am.total, am.total_sa, am.total_sua, am.used, am.used_sa, am.used_sua }; + Eterm seg_tags[] = { am.used, am.max, am.allocated, am.reserved, am.used_sa, am.used_sua }; + Eterm group[2]; + Eterm group_tags[] = { am.sizes, am.free_segs }; + Eterm list[2]; + Eterm list_tags[2]; /* { am.supercarrier, am.os } */ + int lix; + Eterm res = THE_NON_VALUE; + + if (!hpp) { + erts_smp_mtx_lock(&mmap_state.mtx); + emis->sizes[0] = mmap_state.size.supercarrier.total; + emis->sizes[1] = mmap_state.sa.top - mmap_state.sa.bot; + emis->sizes[2] = mmap_state.sua.top - mmap_state.sua.bot; + emis->sizes[3] = mmap_state.size.supercarrier.used.total; + emis->sizes[4] = mmap_state.size.supercarrier.used.sa; + emis->sizes[5] = mmap_state.size.supercarrier.used.sua; + + emis->segs[0] = mmap_state.no.free_segs.curr; + emis->segs[1] = mmap_state.no.free_segs.max; + emis->segs[2] = mmap_state.no.free_seg_descs; + emis->segs[3] = mmap_state.desc.reserved; + emis->segs[4] = mmap_state.sa.map.nseg; + emis->segs[5] = mmap_state.sua.map.nseg; + + emis->os_used = mmap_state.size.os.used; + erts_smp_mtx_unlock(&mmap_state.mtx); + } + + if (print_to_p) { + int to = *print_to_p; + void *arg = print_to_arg; + if (mmap_state.supercarrier) { + const char* prefix = "supercarrier "; + erts_print(to, arg, "%stotal size: %bpu\n", prefix, emis->sizes[0]); + erts_print(to, arg, "%stotal sa size: %bpu\n", prefix, emis->sizes[1]); + erts_print(to, arg, "%stotal sua size: %bpu\n", prefix, emis->sizes[2]); + erts_print(to, arg, "%sused size: %bpu\n", prefix, emis->sizes[3]); + erts_print(to, arg, "%sused sa size: %bpu\n", prefix, emis->sizes[4]); + erts_print(to, arg, "%sused sua size: %bpu\n", prefix, emis->sizes[5]); + erts_print(to, arg, "%sused free segs: %bpu\n", prefix, emis->segs[0]); + erts_print(to, arg, "%smax free segs: %bpu\n", prefix, emis->segs[1]); + erts_print(to, arg, "%sallocated free segs: %bpu\n", prefix, emis->segs[2]); + erts_print(to, arg, "%sreserved free segs: %bpu\n", prefix, emis->segs[3]); + erts_print(to, arg, "%ssa free segs: %bpu\n", prefix, emis->segs[4]); + erts_print(to, arg, "%ssua free segs: %bpu\n", prefix, emis->segs[5]); + } + if (!mmap_state.no_os_mmap) { + erts_print(to, arg, "os mmap size used: %bpu\n", emis->os_used); + } + } + + + if (hpp || szp) { + if (!am.is_initialized) { + init_atoms(); + } + + lix = 0; + if (mmap_state.supercarrier) { + group[0] = erts_bld_atom_uword_2tup_list(hpp, szp, + sizeof(size_tags)/sizeof(Eterm), + size_tags, emis->sizes); + group[1] = erts_bld_atom_uword_2tup_list(hpp, szp, + sizeof(seg_tags)/sizeof(Eterm), + seg_tags, emis->segs); + list[lix] = erts_bld_2tup_list(hpp, szp, 2, group_tags, group); + list_tags[lix] = am.supercarrier; + lix++; + } + + if (!mmap_state.no_os_mmap) { + group[0] = erts_bld_atom_uword_2tup_list(hpp, szp, + 1, &am.used, &emis->os_used); + list[lix] = erts_bld_2tup_list(hpp, szp, 1, group_tags, group); + list_tags[lix] = am.os; + lix++; + } + res = erts_bld_2tup_list(hpp, szp, lix, list_tags, list); + } + return res; +} + +Eterm erts_mmap_info_options(char *prefix, + int *print_to_p, + void *print_to_arg, + Uint **hpp, + Uint *szp) +{ + const UWord scs = mmap_state.sua.top - mmap_state.sa.bot; + const Eterm sco = mmap_state.no_os_mmap ? am_true : am_false; + const Eterm scrpm = (mmap_state.reserve_physical == reserve_noop) ? am_true : am_false; + Eterm res = THE_NON_VALUE; + + if (print_to_p) { + int to = *print_to_p; + void *arg = print_to_arg; + erts_print(to, arg, "%sscs: %bpu\n", prefix, scs); + if (mmap_state.supercarrier) { + erts_print(to, arg, "%ssco: %T\n", prefix, sco); + erts_print(to, arg, "%sscrpm: %T\n", prefix, scrpm); + erts_print(to, arg, "%sscmgc: %beu\n", prefix, mmap_state.desc.reserved); + } + } + + if (hpp || szp) { + if (!am.is_initialized) { + init_atoms(); + } + + res = NIL; + if (mmap_state.supercarrier) { + add_2tup(hpp, szp, &res, am.scmgc, + erts_bld_uint(hpp,szp, mmap_state.desc.reserved)); + add_2tup(hpp, szp, &res, am.scrpm, scrpm); + add_2tup(hpp, szp, &res, am.sco, sco); + } + add_2tup(hpp, szp, &res, am.scs, erts_bld_uword(hpp, szp, scs)); + } + return res; +} + + +Eterm erts_mmap_debug_info(Process* p) +{ + if (mmap_state.supercarrier) { + ERTS_DECL_AM(sabot); + ERTS_DECL_AM(satop); + ERTS_DECL_AM(suabot); + ERTS_DECL_AM(suatop); + Eterm sa_list, sua_list, list; + Eterm tags[] = { AM_sabot, AM_satop, AM_suabot, AM_suatop }; + UWord values[4]; + Eterm *hp, *hp_end; + Uint may_need; + const Uint PTR_BIG_SZ = HALFWORD_HEAP ? 3 : 2; + + erts_smp_mtx_lock(&mmap_state.mtx); + values[0] = (UWord)mmap_state.sa.bot; + values[1] = (UWord)mmap_state.sa.top; + values[2] = (UWord)mmap_state.sua.bot; + values[3] = (UWord)mmap_state.sua.top; + sa_list = build_free_seg_list(p, &mmap_state.sa.map); + sua_list = build_free_seg_list(p, &mmap_state.sua.map); + erts_smp_mtx_unlock(&mmap_state.mtx); + + may_need = 4*(2+3+PTR_BIG_SZ) + 2*(2+3); + hp = HAlloc(p, may_need); + hp_end = hp + may_need; + + list = erts_bld_atom_uword_2tup_list(&hp, NULL, + sizeof(values)/sizeof(*values), + tags, values); + + sa_list = TUPLE2(hp, am_atom_put("sa_free_segs",12), sa_list); hp+=3; + sua_list = TUPLE2(hp, am_atom_put("sua_free_segs",13), sua_list); hp+=3; + list = CONS(hp, sua_list, list); hp+=2; + list = CONS(hp, sa_list, list); hp+=2; + + ASSERT(hp <= hp_end); + HRelease(p, hp_end, hp); + return list; + } + else { + return am_undefined; + } +} + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *\ + * Debug functions * +\* */ + + +#ifdef HARD_DEBUG + +static int rbt_assert_is_member(RBTNode* root, RBTNode* node) +{ + while (node != root) { + RBT_ASSERT(parent(node)); + RBT_ASSERT(parent(node)->left == node || parent(node)->right == node); + node = parent(node); + } + return 1; +} + + +#if 0 +# define PRINT_TREE +#else +# undef PRINT_TREE +#endif + +#ifdef PRINT_TREE +static void print_tree(enum SortOrder order, RBTNode*); +#endif + +/* + * Checks that the order between parent and children are correct, + * and that the Red-Black Tree properies are satisfied. if size > 0, + * check_tree() returns the node that satisfies "address order first fit" + * + * The Red-Black Tree properies are: + * 1. Every node is either red or black. + * 2. Every leaf (NIL) is black. + * 3. If a node is red, then both its children are black. + * 4. Every simple path from a node to a descendant leaf + * contains the same number of black nodes. + * + */ + +struct check_arg_t { + RBTree* tree; + ErtsFreeSegDesc* prev_seg; + Uint size; + RBTNode *res; +}; +static void check_node_callback(RBTNode* x, void* arg); + + +static RBTNode * +check_tree(RBTree* tree, Uint size) +{ + struct check_arg_t carg; + carg.tree = tree; + carg.prev_seg = NULL; + carg.size = size; + carg.res = NULL; + +#ifdef PRINT_TREE + print_tree(tree->order, tree->root); +#endif + + if (!tree->root) + return NULL; + + RBT_ASSERT(IS_BLACK(tree->root)); + RBT_ASSERT(!parent(tree->root)); + + rbt_foreach_node(tree, check_node_callback, &carg, 0); + + return carg.res; +} + +static void check_node_callback(RBTNode* x, void* arg) +{ + struct check_arg_t* a = (struct check_arg_t*) arg; + ErtsFreeSegDesc* seg; + + if (IS_RED(x)) { + RBT_ASSERT(IS_BLACK(x->right)); + RBT_ASSERT(IS_BLACK(x->left)); + } + + RBT_ASSERT(parent(x) || x == a->tree->root); + + if (x->left) { + RBT_ASSERT(cmp_nodes(a->tree->order, x->left, x) < 0); + } + if (x->right) { + RBT_ASSERT(cmp_nodes(a->tree->order, x->right, x) > 0); + } + + seg = node_to_desc(a->tree->order, x); + RBT_ASSERT(seg->start < seg->end); + if (a->size && (seg->end - seg->start) >= a->size) { + if (!a->res || cmp_nodes(a->tree->order, x, a->res) < 0) { + a->res = x; + } + } + if (a->tree->order == ADDR_ORDER) { + RBT_ASSERT(!a->prev_seg || a->prev_seg->end < seg->start); + a->prev_seg = seg; + } +} + +#endif /* HARD_DEBUG */ + + +#ifdef PRINT_TREE +#define INDENT_STEP 2 + +#include <stdio.h> + +static void +print_tree_aux(enum SortOrder order, RBTNode *x, int indent) +{ + int i; + + if (x) { + ErtsFreeSegDesc* desc = node_to_desc(order, x); + print_tree_aux(order, x->right, indent + INDENT_STEP); + for (i = 0; i < indent; i++) { + putc(' ', stderr); + } + fprintf(stderr, "%s: sz=%lx [%p - %p] desc=%p\r\n", + IS_BLACK(x) ? "BLACK" : "RED", + desc->end - desc->start, desc->start, desc->end, desc); + print_tree_aux(order, x->left, indent + INDENT_STEP); + } +} + + +static void +print_tree(enum SortOrder order, RBTNode* root) +{ + fprintf(stderr, " --- %s ordered tree begin ---\r\n", sort_order_names[order]); + print_tree_aux(order, root, 0); + fprintf(stderr, " --- %s ordered tree end ---\r\n", sort_order_names[order]); +} + +#endif /* PRINT_TREE */ + + +#ifdef FREE_SEG_API_SMOKE_TEST + +void test_it(void) +{ + ErtsFreeSegMap map; + ErtsFreeSegDesc *desc, *under, *over, *d1, *d2; + const int i = 1; /* reverse addr order */ + + { + init_free_seg_map(&map, SZ_REVERSE_ADDR_ORDER); + + insert_free_seg(&map, alloc_desc(), (char*)0x11000, (char*)0x12000); + HARD_CHECK_TREE(&map.atree, 0); HARD_CHECK_TREE(&map.stree, 0); + insert_free_seg(&map, alloc_desc(), (char*)0x13000, (char*)0x14000); + HARD_CHECK_TREE(&map.atree, 0); HARD_CHECK_TREE(&map.stree, 0); + insert_free_seg(&map, alloc_desc(), (char*)0x15000, (char*)0x17000); + HARD_CHECK_TREE(&map.atree, 0); HARD_CHECK_TREE(&map.stree, 0); + insert_free_seg(&map, alloc_desc(), (char*)0x8000, (char*)0x10000); + HARD_CHECK_TREE(&map.atree, 0); HARD_CHECK_TREE(&map.stree, 0); + + desc = lookup_free_seg(&map, 0x500); + ERTS_ASSERT(desc->start == (char*)(i?0x13000L:0x11000L)); + + desc = lookup_free_seg(&map, 0x1500); + ERTS_ASSERT(desc->start == (char*)0x15000); + + adjacent_free_seg(&map, (char*)0x6666, (char*)0x7777, &under, &over); + ERTS_ASSERT(!under && !over); + + adjacent_free_seg(&map, (char*)0x6666, (char*)0x8000, &under, &over); + ERTS_ASSERT(!under && over->start == (char*)0x8000); + + adjacent_free_seg(&map, (char*)0x10000, (char*)0x10500, &under, &over); + ERTS_ASSERT(under->end == (char*)0x10000 && !over); + + adjacent_free_seg(&map, (char*)0x10100, (char*)0x10500, &under, &over); + ERTS_ASSERT(!under && !over); + + adjacent_free_seg(&map, (char*)0x10100, (char*)0x11000, &under, &over); + ERTS_ASSERT(!under && over && over->start == (char*)0x11000); + + adjacent_free_seg(&map, (char*)0x12000, (char*)0x12500, &under, &over); + ERTS_ASSERT(under && under->end == (char*)0x12000 && !over); + + adjacent_free_seg(&map, (char*)0x12000, (char*)0x13000, &under, &over); + ERTS_ASSERT(under && under->end == (char*)0x12000 && + over && over->start == (char*)0x13000); + + adjacent_free_seg(&map, (char*)0x12500, (char*)0x13000, &under, &over); + ERTS_ASSERT(!under && over && over->start == (char*)0x13000); + + d1 = lookup_free_seg(&map, 0x500); + ERTS_ASSERT(d1->start == (char*)(i?0x13000L:0x11000L)); + + resize_free_seg(&map, d1, d1->start - 0x800, (char*)d1->end); + HARD_CHECK_TREE(&map.atree, 0); HARD_CHECK_TREE(&map.stree, 0); + + d2 = lookup_free_seg(&map, 0x1200); + ERTS_ASSERT(d2 == d1); + + delete_free_seg(&map, d1); + HARD_CHECK_TREE(&map.atree, 0); HARD_CHECK_TREE(&map.stree, 0); + + d1 = lookup_free_seg(&map, 0x1200); + ERTS_ASSERT(d1->start == (char*)0x15000); + } +} + +#endif /* FREE_SEG_API_SMOKE_TEST */ + + +#ifdef HARD_DEBUG_MSEG + +/* + * Debug stuff used by erl_mseg to check that it does the right thing. + * The reason for keeping it here is that we (ab)use the rb-tree code + * for keeping track of *allocated* segments. + */ + +typedef struct ErtsFreeSegDesc_fake_ { + /*RBTNode snode; Save memory by skipping unused size tree node */ + RBTNode anode; /* node in 'atree' */ + union { + char* start; + struct ErtsFreeSegDesc_fake_* next_free; + }u; + char* end; +}ErtsFreeSegDesc_fake; + +static ErtsFreeSegDesc_fake hard_dbg_mseg_desc_pool[10000]; +static ErtsFreeSegDesc_fake* hard_dbg_mseg_desc_first; +RBTree hard_dbg_mseg_tree; + +static erts_mtx_t hard_dbg_mseg_mtx; + +static void hard_dbg_mseg_init(void) +{ + ErtsFreeSegDesc_fake* p; + + erts_mtx_init(&hard_dbg_mseg_mtx, "hard_dbg_mseg"); + hard_dbg_mseg_tree.root = NULL; + hard_dbg_mseg_tree.order = ADDR_ORDER; + + p = &hard_dbg_mseg_desc_pool[(sizeof(hard_dbg_mseg_desc_pool) / + sizeof(*hard_dbg_mseg_desc_pool)) - 1]; + p->u.next_free = NULL; + while (--p >= hard_dbg_mseg_desc_pool) { + p->u.next_free = (p+1); + } + hard_dbg_mseg_desc_first = &hard_dbg_mseg_desc_pool[0]; +} + +static ErtsFreeSegDesc* hard_dbg_alloc_desc(void) +{ + ErtsFreeSegDesc_fake* p = hard_dbg_mseg_desc_first; + ERTS_ASSERT(p || !"HARD_DEBUG_MSEG: Out of mseg descriptors"); + hard_dbg_mseg_desc_first = p->u.next_free; + + /* Creative pointer arithmetic to return something that looks like + * a ErtsFreeSegDesc as long as we don't use the absent 'snode'. + */ + return (ErtsFreeSegDesc*) ((char*)p - offsetof(ErtsFreeSegDesc,anode)); +} + +static void hard_dbg_free_desc(ErtsFreeSegDesc* desc) +{ + ErtsFreeSegDesc_fake* p = (ErtsFreeSegDesc_fake*) &desc->anode; + memset(p, 0xfe, sizeof(*p)); + p->u.next_free = hard_dbg_mseg_desc_first; + hard_dbg_mseg_desc_first = p; +} + +static void check_seg_writable(void* seg, UWord sz) +{ + UWord* seg_end = (UWord*)((char*)seg + sz); + volatile UWord* p; + ERTS_ASSERT(ERTS_IS_PAGEALIGNED(seg)); + ERTS_ASSERT(ERTS_IS_PAGEALIGNED(sz)); + for (p=(UWord*)seg; p<seg_end; p += (ERTS_INV_PAGEALIGNED_MASK+1)/sizeof(UWord)) { + UWord write_back = *p; + *p = 0xfade2b1acc; + *p = write_back; + } +} + +void hard_dbg_insert_mseg(void* seg, UWord sz) +{ + check_seg_writable(seg, sz); + erts_mtx_lock(&hard_dbg_mseg_mtx); + { + ErtsFreeSegDesc *desc = hard_dbg_alloc_desc(); + RBTNode *prev, *next; + desc->start = (char*)seg; + desc->end = desc->start + sz - 1; /* -1 to allow adjacent segments in tree */ + rbt_insert(&hard_dbg_mseg_tree, &desc->anode); + prev = rbt_prev_node(&desc->anode); + next = rbt_next_node(&desc->anode); + ERTS_ASSERT(!prev || anode_to_desc(prev)->end < desc->start); + ERTS_ASSERT(!next || anode_to_desc(next)->start > desc->end); + } + erts_mtx_unlock(&hard_dbg_mseg_mtx); +} + +static ErtsFreeSegDesc* hard_dbg_lookup_seg_at(RBTree* tree, char* start) +{ + RBTNode* x = tree->root; + + while (x) { + ErtsFreeSegDesc* desc = anode_to_desc(x); + if (start < desc->start) { + x = x->left; + } + else if (start > desc->start) { + ERTS_ASSERT(start > desc->end); + x = x->right; + } + else + return desc; + } + return NULL; +} + +void hard_dbg_remove_mseg(void* seg, UWord sz) +{ + check_seg_writable(seg, sz); + erts_mtx_lock(&hard_dbg_mseg_mtx); + { + ErtsFreeSegDesc* desc = hard_dbg_lookup_seg_at(&hard_dbg_mseg_tree, (char*)seg); + ERTS_ASSERT(desc); + ERTS_ASSERT(desc->start == (char*)seg); + ERTS_ASSERT(desc->end == (char*)seg + sz - 1); + + rbt_delete(&hard_dbg_mseg_tree, &desc->anode); + hard_dbg_free_desc(desc); + } + erts_mtx_unlock(&hard_dbg_mseg_mtx); +} + +#endif /* HARD_DEBUG_MSEG */ diff --git a/erts/emulator/sys/common/erl_mmap.h b/erts/emulator/sys/common/erl_mmap.h new file mode 100644 index 0000000000..e6934dbb26 --- /dev/null +++ b/erts/emulator/sys/common/erl_mmap.h @@ -0,0 +1,134 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2013. All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the "License"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an "AS IS" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + * %CopyrightEnd% + */ + +#ifndef ERL_MMAP_H__ +#define ERL_MMAP_H__ + +#include "sys.h" + +#define ERTS_MMAP_SUPERALIGNED_BITS (18) +/* Affects hard limits for sbct and lmbcs documented in erts_alloc.xml */ + +#define ERTS_MMAPFLG_OS_ONLY (((Uint32) 1) << 0) +#define ERTS_MMAPFLG_SUPERCARRIER_ONLY (((Uint32) 1) << 1) +#define ERTS_MMAPFLG_SUPERALIGNED (((Uint32) 1) << 2) + +#define ERTS_HAVE_ERTS_OS_MMAP (1 << 0) +#define ERTS_HAVE_ERTS_SUPERCARRIER_MMAP (1 << 1) +extern int erts_have_erts_mmap; +extern UWord erts_page_inv_mask; + +typedef struct { + struct { + char *start; + char *end; + } virtual_range; + struct { + char *start; + char *end; + } predefined_area; + UWord scs; /* super carrier size */ + int sco; /* super carrier only? */ + Uint scmgc; /* super carrier: max guaranteed (number of) carriers */ + int scrpm; +}ErtsMMapInit; + +#define ERTS_MMAP_INIT_DEFAULT_INITER \ + {{NULL, NULL}, {NULL, NULL}, 0, 1, (1 << 16), 1} + +void *erts_mmap(Uint32 flags, UWord *sizep); +void erts_munmap(Uint32 flags, void *ptr, UWord size); +void *erts_mremap(Uint32 flags, void *ptr, UWord old_size, UWord *sizep); +int erts_mmap_in_supercarrier(void *ptr); +void erts_mmap_init(ErtsMMapInit*); +struct erts_mmap_info_struct +{ + UWord sizes[6]; + UWord segs[6]; + UWord os_used; +}; +Eterm erts_mmap_info(int *print_to_p, void *print_to_arg, + Eterm** hpp, Uint* szp, struct erts_mmap_info_struct*); +Eterm erts_mmap_info_options(char *prefix, int *print_to_p, void *print_to_arg, + Uint **hpp, Uint *szp); +struct process; +Eterm erts_mmap_debug_info(struct process*); + +#define ERTS_SUPERALIGNED_SIZE \ + (1 << ERTS_MMAP_SUPERALIGNED_BITS) +#define ERTS_INV_SUPERALIGNED_MASK \ + ((UWord) (ERTS_SUPERALIGNED_SIZE - 1)) +#define ERTS_SUPERALIGNED_MASK \ + (~ERTS_INV_SUPERALIGNED_MASK) +#define ERTS_SUPERALIGNED_FLOOR(X) \ + (((UWord) (X)) & ERTS_SUPERALIGNED_MASK) +#define ERTS_SUPERALIGNED_CEILING(X) \ + ERTS_SUPERALIGNED_FLOOR((X) + ERTS_INV_SUPERALIGNED_MASK) +#define ERTS_IS_SUPERALIGNED(X) \ + (((UWord) (X) & ERTS_INV_SUPERALIGNED_MASK) == 0) + +#define ERTS_INV_PAGEALIGNED_MASK \ + (erts_page_inv_mask) +#define ERTS_PAGEALIGNED_MASK \ + (~ERTS_INV_PAGEALIGNED_MASK) +#define ERTS_PAGEALIGNED_FLOOR(X) \ + (((UWord) (X)) & ERTS_PAGEALIGNED_MASK) +#define ERTS_PAGEALIGNED_CEILING(X) \ + ERTS_PAGEALIGNED_FLOOR((X) + ERTS_INV_PAGEALIGNED_MASK) +#define ERTS_IS_PAGEALIGNED(X) \ + (((UWord) (X) & ERTS_INV_PAGEALIGNED_MASK) == 0) +#define ERTS_PAGEALIGNED_SIZE \ + (ERTS_INV_PAGEALIGNED_MASK + 1) + +#ifndef HAVE_MMAP +# define HAVE_MMAP 0 +#endif +#ifndef HAVE_MREMAP +# define HAVE_MREMAP 0 +#endif +#if HAVE_MMAP +# define ERTS_HAVE_OS_MMAP 1 +# define ERTS_HAVE_GENUINE_OS_MMAP 1 +# if HAVE_MREMAP +# define ERTS_HAVE_OS_MREMAP 1 +# endif +# if defined(MAP_FIXED) && defined(MAP_NORESERVE) +# define ERTS_HAVE_OS_PHYSICAL_MEMORY_RESERVATION 1 +# endif +#endif + +#ifndef HAVE_VIRTUALALLOC +# define HAVE_VIRTUALALLOC 0 +#endif +#if HAVE_VIRTUALALLOC +# define ERTS_HAVE_OS_MMAP 1 +#endif + +/*#define HARD_DEBUG_MSEG*/ +#ifdef HARD_DEBUG_MSEG +# define HARD_DBG_INSERT_MSEG hard_dbg_insert_mseg +# define HARD_DBG_REMOVE_MSEG hard_dbg_remove_mseg +void hard_dbg_insert_mseg(void* seg, UWord sz); +void hard_dbg_remove_mseg(void* seg, UWord sz); +#else +# define HARD_DBG_INSERT_MSEG(SEG,SZ) +# define HARD_DBG_REMOVE_MSEG(SEG,SZ) +#endif + +#endif /* ERL_MMAP_H__ */ diff --git a/erts/emulator/sys/common/erl_mseg.c b/erts/emulator/sys/common/erl_mseg.c index 2748edba02..94a381e168 100644 --- a/erts/emulator/sys/common/erl_mseg.c +++ b/erts/emulator/sys/common/erl_mseg.c @@ -100,45 +100,6 @@ static int atoms_initialized; typedef struct mem_kind_t MemKind; -#if HALFWORD_HEAP -static int initialize_pmmap(void); -static void *pmmap(size_t size); -static int pmunmap(void *p, size_t size); -static void *pmremap(void *old_address, size_t old_size, - size_t new_size); -#endif - -#if HAVE_MMAP -/* Mmap ... */ - -#define MMAP_PROT (PROT_READ|PROT_WRITE) - - -#ifdef MAP_ANON -# define MMAP_FLAGS (MAP_ANON|MAP_PRIVATE) -# define MMAP_FD (-1) -#else -# define MMAP_FLAGS (MAP_PRIVATE) -# define MMAP_FD mmap_fd -static int mmap_fd; -#endif - -#if HAVE_MREMAP -# define HAVE_MSEG_RECREATE 1 -#else -# define HAVE_MSEG_RECREATE 0 -#endif - -#if HALFWORD_HEAP -#define CAN_PARTLY_DESTROY 0 -#else -#define CAN_PARTLY_DESTROY 1 -#endif -#else /* #if HAVE_MMAP */ -#define CAN_PARTLY_DESTROY 0 -#error "Not supported" -#endif /* #if HAVE_MMAP */ - const ErtsMsegOpt_t erts_mseg_default_opt = { 1, /* Use cache */ 1, /* Preserv data */ @@ -163,9 +124,7 @@ typedef struct { CallCounter create; CallCounter create_resize; CallCounter destroy; -#if HAVE_MSEG_RECREATE CallCounter recreate; -#endif CallCounter clear_cache; CallCounter check_cache; } ErtsMsegCalls; @@ -173,7 +132,7 @@ typedef struct { typedef struct cache_t_ cache_t; struct cache_t_ { - Uint size; + UWord size; void *seg; cache_t *next; cache_t *prev; @@ -236,11 +195,6 @@ struct ErtsMsegAllctr_t_ { Uint rel_max_cache_bad_fit; ErtsMsegCalls calls; - -#if CAN_PARTLY_DESTROY - Uint min_seg_size; -#endif - }; typedef union { @@ -344,69 +298,31 @@ schedule_cache_check(ErtsMsegAllctr_t *ma) { } } -/* remove ErtsMsegAllctr_t from arguments? - * only used for statistics - */ -static ERTS_INLINE void * -mmap_align(ErtsMsegAllctr_t *ma, void *addr, size_t length, int prot, int flags, int fd, off_t offset) { - - char *p, *q; - UWord d; - - p = mmap(addr, length, prot, flags, fd, offset); - - if (MAP_IS_ALIGNED(p) || p == MAP_FAILED) - return p; - - if (ma) - INC_CC(ma, create_resize); - - munmap(p, length); - - if ((p = mmap(addr, length + MSEG_ALIGNED_SIZE, prot, flags, fd, offset)) == MAP_FAILED) - return MAP_FAILED; - - q = (void *)ALIGNED_CEILING((char *)p); - d = (UWord)(q - p); - - if (d > 0) - munmap(p, d); - - if (MSEG_ALIGNED_SIZE - d > 0) - munmap((void *)(q + length), MSEG_ALIGNED_SIZE - d); - - return q; -} +/* #define ERTS_PRINT_ERTS_MMAP */ static ERTS_INLINE void * -mseg_create(ErtsMsegAllctr_t *ma, MemKind* mk, Uint size) +mseg_create(ErtsMsegAllctr_t *ma, Uint flags, MemKind* mk, UWord *sizep) { +#ifdef ERTS_PRINT_ERTS_MMAP + UWord req_size = *sizep; +#endif void *seg; - ASSERT(size % MSEG_ALIGNED_SIZE == 0); - + Uint32 mmap_flags = 0; #if HALFWORD_HEAP - if (mk == &ma->low_mem) { - seg = pmmap(size); - if ((unsigned long) seg & CHECK_POINTER_MASK) { - erts_fprintf(stderr,"Pointer mask failure (0x%08lx)\n",(unsigned long) seg); - return NULL; - } - } else + mmap_flags |= ((mk == &ma->low_mem) + ? ERTS_MMAPFLG_SUPERCARRIER_ONLY + : ERTS_MMAPFLG_OS_ONLY); #endif - { -#if HAVE_MMAP - { - seg = (void *) mmap_align(ma, (void *) 0, (size_t) size, - MMAP_PROT, MMAP_FLAGS, MMAP_FD, 0); - if (seg == (void *) MAP_FAILED) - seg = NULL; - - ASSERT(MAP_IS_ALIGNED(seg) || !seg); - } -#else -# error "Missing mseg_create() implementation" + if (MSEG_FLG_IS_2POW(flags)) + mmap_flags |= ERTS_MMAPFLG_SUPERALIGNED; + + seg = erts_mmap(mmap_flags, sizep); + +#ifdef ERTS_PRINT_ERTS_MMAP + erts_fprintf(stderr, "%p = erts_mmap(%s, {%bpu, %bpu});\n", seg, + (mmap_flags & ERTS_MMAPFLG_SUPERALIGNED) ? "sa" : "sua", + req_size, *sizep); #endif - } INC_CC(ma, create); @@ -414,91 +330,55 @@ mseg_create(ErtsMsegAllctr_t *ma, MemKind* mk, Uint size) } static ERTS_INLINE void -mseg_destroy(ErtsMsegAllctr_t *ma, MemKind* mk, void *seg, Uint size) { - ERTS_DECLARE_DUMMY(int res); - +mseg_destroy(ErtsMsegAllctr_t *ma, Uint flags, MemKind* mk, void *seg_p, UWord size) { + + Uint32 mmap_flags = 0; #if HALFWORD_HEAP - if (mk == &ma->low_mem) { - res = pmunmap((void *) seg, size); - } - else + mmap_flags |= ((mk == &ma->low_mem) + ? ERTS_MMAPFLG_SUPERCARRIER_ONLY + : ERTS_MMAPFLG_OS_ONLY); #endif - { -#ifdef HAVE_MMAP - res = munmap((void *) seg, size); -#else -# error "Missing mseg_destroy() implementation" + if (MSEG_FLG_IS_2POW(flags)) + mmap_flags |= ERTS_MMAPFLG_SUPERALIGNED; + + erts_munmap(mmap_flags, seg_p, size); +#ifdef ERTS_PRINT_ERTS_MMAP + erts_fprintf(stderr, "erts_munmap(%s, %p, %bpu);\n", + (mmap_flags & ERTS_MMAPFLG_SUPERALIGNED) ? "sa" : "sua", + seg_p, *size); #endif - } - - ASSERT(size % MSEG_ALIGNED_SIZE == 0); - ASSERT(res == 0); - INC_CC(ma, destroy); } -#if HAVE_MSEG_RECREATE -#if defined(__NetBSD__) -#define MREMAP_FLAGS (0) -#else -#define MREMAP_FLAGS (MREMAP_MAYMOVE) -#endif - - -/* mseg_recreate - * May return *unaligned* segments as in address not aligned to MSEG_ALIGNMENT - * it is still page aligned - * - * This is fine for single block carriers as long as we don't cache misaligned - * segments (since multiblock carriers may use them) - * - * For multiblock carriers we *need* MSEG_ALIGNMENT but mbc's will never be - * reallocated. - * - * This should probably be fixed the following way: - * 1) Use an option to segment allocation - NEED_ALIGNMENT - * 2) Add mremap_align which takes care of aligning a new a mremaped area - * 3) Fix the cache to handle of aligned and unaligned segments - */ - static ERTS_INLINE void * -mseg_recreate(ErtsMsegAllctr_t *ma, MemKind* mk, void *old_seg, Uint old_size, Uint new_size) +mseg_recreate(ErtsMsegAllctr_t *ma, Uint flags, MemKind* mk, void *old_seg, UWord old_size, UWord *sizep) { +#ifdef ERTS_PRINT_ERTS_MMAP + UWord req_size = *sizep; +#endif void *new_seg; - - ASSERT(old_size % MSEG_ALIGNED_SIZE == 0); - ASSERT(new_size % MSEG_ALIGNED_SIZE == 0); - + Uint32 mmap_flags = 0; #if HALFWORD_HEAP - if (mk == &ma->low_mem) { - new_seg = (void *) pmremap((void *) old_seg, - (size_t) old_size, - (size_t) new_size); - } - else + mmap_flags |= ((mk == &ma->low_mem) + ? ERTS_MMAPFLG_SUPERCARRIER_ONLY + : ERTS_MMAPFLG_OS_ONLY); #endif - { -#if HAVE_MREMAP -#if defined(__NetBSD__) - new_seg = mremap(old_seg, (size_t)old_size, NULL, new_size, MREMAP_FLAGS); -#else - new_seg = mremap(old_seg, (size_t)old_size, (size_t)new_size, MREMAP_FLAGS); -#endif - if (new_seg == (void *) MAP_FAILED) - new_seg = NULL; -#else -#error "Missing mseg_recreate() implementation" -#endif - } + if (MSEG_FLG_IS_2POW(flags)) + mmap_flags |= ERTS_MMAPFLG_SUPERALIGNED; + new_seg = erts_mremap(mmap_flags, old_seg, old_size, sizep); + +#ifdef ERTS_PRINT_ERTS_MMAP + erts_fprintf(stderr, "%p = erts_mremap(%s, %p, %bpu, {%bpu, %bpu});\n", + new_seg, (mmap_flags & ERTS_MMAPFLG_SUPERALIGNED) ? "sa" : "sua", + old_seg, old_size, req_size, *sizep); +#endif INC_CC(ma, recreate); return new_seg; } -#endif /* #if HAVE_MSEG_RECREATE */ - #ifdef DEBUG #define ERTS_DBG_MA_CHK_THR_ACCESS(MA) \ do { \ @@ -528,7 +408,7 @@ static ERTS_INLINE void mseg_cache_clear_node(cache_t *c) { c->prev = c; } -static ERTS_INLINE int cache_bless_segment(MemKind *mk, void *seg, Uint size, Uint flags) { +static ERTS_INLINE int cache_bless_segment(MemKind *mk, void *seg, UWord size, Uint flags) { cache_t *c; ERTS_DBG_MK_CHK_THR_ACCESS(mk); @@ -566,14 +446,13 @@ static ERTS_INLINE int cache_bless_segment(MemKind *mk, void *seg, Uint size, Ui return 1; } else if (!MSEG_FLG_IS_2POW(flags) && !erts_circleq_is_empty(&(mk->cache_unpowered_node))) { - /* No free slots. * Evict oldest slot from unpowered cache so we can cache an unpowered (sbc) segment */ c = erts_circleq_tail(&(mk->cache_unpowered_node)); erts_circleq_remove(c); - mseg_destroy(mk->ma, mk, c->seg, c->size); + mseg_destroy(mk->ma, ERTS_MSEG_FLG_NONE, mk, c->seg, c->size); mseg_cache_clear_node(c); c->seg = seg; @@ -599,7 +478,8 @@ static ERTS_INLINE int cache_bless_segment(MemKind *mk, void *seg, Uint size, Ui c = erts_circleq_tail(&(mk->cache_powered_node[i])); erts_circleq_remove(c); - mseg_destroy(mk->ma, mk, c->seg, c->size); + mseg_destroy(mk->ma, ERTS_MSEG_FLG_2POW, mk, c->seg, c->size); + mseg_cache_clear_node(c); c->seg = seg; @@ -614,18 +494,18 @@ static ERTS_INLINE int cache_bless_segment(MemKind *mk, void *seg, Uint size, Ui return 0; } -static ERTS_INLINE void *cache_get_segment(MemKind *mk, Uint *size_p, Uint flags) { +static ERTS_INLINE void *cache_get_segment(MemKind *mk, UWord *size_p, Uint flags) { - Uint size = *size_p; + UWord size = *size_p; ERTS_DBG_MK_CHK_THR_ACCESS(mk); if (MSEG_FLG_IS_2POW(flags)) { int i, ix = SIZE_TO_CACHE_AREA_IDX(size); - void *seg; + char *seg; cache_t *c; - Uint csize; + UWord csize; ASSERT(IS_2POW(size)); @@ -641,7 +521,7 @@ static ERTS_INLINE void *cache_get_segment(MemKind *mk, Uint *size_p, Uint flags ASSERT(MAP_IS_ALIGNED(c->seg)); csize = c->size; - seg = c->seg; + seg = (char*) c->seg; mk->cache_size--; mk->cache_hits++; @@ -652,9 +532,8 @@ static ERTS_INLINE void *cache_get_segment(MemKind *mk, Uint *size_p, Uint flags ASSERT(!(mk->cache_size < 0)); - if (csize != size) { - mseg_destroy(mk->ma, mk, (char *)seg + size, csize - size); - } + if (csize != size) + mseg_destroy(mk->ma, ERTS_MSEG_FLG_2POW, mk, seg + size, csize - size); return seg; } @@ -663,10 +542,10 @@ static ERTS_INLINE void *cache_get_segment(MemKind *mk, Uint *size_p, Uint flags void *seg; cache_t *c; cache_t *best = NULL; - Uint bdiff = 0; - Uint csize; - Uint bad_max_abs = mk->ma->abs_max_cache_bad_fit; - Uint bad_max_rel = mk->ma->rel_max_cache_bad_fit; + UWord bdiff = 0; + UWord csize; + UWord bad_max_abs = mk->ma->abs_max_cache_bad_fit; + UWord bad_max_rel = mk->ma->rel_max_cache_bad_fit; erts_circleq_foreach(c, &(mk->cache_unpowered_node)) { csize = c->size; @@ -728,7 +607,7 @@ static ERTS_INLINE void *cache_get_segment(MemKind *mk, Uint *size_p, Uint flags * using callbacks from aux-work in the scheduler. */ -static ERTS_INLINE Uint mseg_drop_one_memkind_cache_size(MemKind *mk, cache_t *head) { +static ERTS_INLINE Uint mseg_drop_one_memkind_cache_size(MemKind *mk, Uint flags, cache_t *head) { cache_t *c = NULL; c = erts_circleq_tail(head); @@ -737,7 +616,7 @@ static ERTS_INLINE Uint mseg_drop_one_memkind_cache_size(MemKind *mk, cache_t *h if (erts_mtrace_enabled) erts_mtrace_crr_free(SEGTYPE, SEGTYPE, c->seg); - mseg_destroy(mk->ma, mk, c->seg, c->size); + mseg_destroy(mk->ma, flags, mk, c->seg, c->size); mseg_cache_clear_node(c); erts_circleq_push_head(&(mk->cache_free), c); @@ -749,7 +628,7 @@ static ERTS_INLINE Uint mseg_drop_one_memkind_cache_size(MemKind *mk, cache_t *h return mk->cache_size; } -static ERTS_INLINE Uint mseg_drop_memkind_cache_size(MemKind *mk, cache_t *head) { +static ERTS_INLINE Uint mseg_drop_memkind_cache_size(MemKind *mk, Uint flags, cache_t *head) { cache_t *c = NULL; while (!erts_circleq_is_empty(head)) { @@ -760,7 +639,7 @@ static ERTS_INLINE Uint mseg_drop_memkind_cache_size(MemKind *mk, cache_t *head) if (erts_mtrace_enabled) erts_mtrace_crr_free(SEGTYPE, SEGTYPE, c->seg); - mseg_destroy(mk->ma, mk, c->seg, c->size); + mseg_destroy(mk->ma, flags, mk, c->seg, c->size); mseg_cache_clear_node(c); erts_circleq_push_head(&(mk->cache_free), c); @@ -788,11 +667,11 @@ static Uint mseg_check_memkind_cache(MemKind *mk) { for (i = 0; i < CACHE_AREAS; i++) { if (!erts_circleq_is_empty(&(mk->cache_powered_node[i]))) - return mseg_drop_one_memkind_cache_size(mk, &(mk->cache_powered_node[i])); + return mseg_drop_one_memkind_cache_size(mk, ERTS_MSEG_FLG_2POW, &(mk->cache_powered_node[i])); } if (!erts_circleq_is_empty(&(mk->cache_unpowered_node))) - return mseg_drop_one_memkind_cache_size(mk, &(mk->cache_unpowered_node)); + return mseg_drop_one_memkind_cache_size(mk, ERTS_MSEG_FLG_NONE, &(mk->cache_unpowered_node)); return 0; } @@ -851,12 +730,12 @@ static void mseg_clear_memkind_cache(MemKind *mk) { if (erts_circleq_is_empty(&(mk->cache_powered_node[i]))) continue; - mseg_drop_memkind_cache_size(mk, &(mk->cache_powered_node[i])); + mseg_drop_memkind_cache_size(mk, ERTS_MSEG_FLG_2POW, &(mk->cache_powered_node[i])); ASSERT(erts_circleq_is_empty(&(mk->cache_powered_node[i]))); } /* drop varied caches */ if (!erts_circleq_is_empty(&(mk->cache_unpowered_node))) - mseg_drop_memkind_cache_size(mk, &(mk->cache_unpowered_node)); + mseg_drop_memkind_cache_size(mk, ERTS_MSEG_FLG_NONE, &(mk->cache_unpowered_node)); ASSERT(erts_circleq_is_empty(&(mk->cache_unpowered_node))); ASSERT(mk->cache_size == 0); @@ -896,36 +775,35 @@ static ERTS_INLINE MemKind* memkind(ErtsMsegAllctr_t *ma, } static void * -mseg_alloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, Uint *size_p, +mseg_alloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, UWord *size_p, Uint flags, const ErtsMsegOpt_t *opt) { - Uint size; + UWord size; void *seg; MemKind* mk = memkind(ma, opt); INC_CC(ma, alloc); - /* Carrier align */ - size = ALIGNED_CEILING(*size_p); - - /* Cache optim (if applicable) */ - if (MSEG_FLG_IS_2POW(flags) && !IS_2POW(size)) - size = ceil_2pow(size); + if (!MSEG_FLG_IS_2POW(flags)) + size = ERTS_PAGEALIGNED_CEILING(*size_p); + else { + size = ALIGNED_CEILING(*size_p); + if (!IS_2POW(size)) { + /* Cache optim (if applicable) */ + size = ceil_2pow(size); + } + } -#if CAN_PARTLY_DESTROY - if (size < ma->min_seg_size) - ma->min_seg_size = size; -#endif - if (opt->cache && mk->cache_size > 0 && (seg = cache_get_segment(mk, &size, flags)) != NULL) goto done; - if ((seg = mseg_create(ma, mk, size)) == NULL) - size = 0; + seg = mseg_create(ma, flags, mk, &size); + if (!seg) + *size_p = 0; + else { done: - *size_p = size; - if (seg) { + *size_p = size; if (erts_mtrace_enabled) erts_mtrace_crr_alloc(seg, atype, ERTS_MTRACE_SEGMENT_ID, size); @@ -937,7 +815,7 @@ done: static void -mseg_dealloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, void *seg, Uint size, +mseg_dealloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, void *seg, UWord size, Uint flags, const ErtsMsegOpt_t *opt) { MemKind* mk = memkind(ma, opt); @@ -952,7 +830,7 @@ mseg_dealloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, void *seg, Uint size, if (erts_mtrace_enabled) erts_mtrace_crr_free(atype, SEGTYPE, seg); - mseg_destroy(ma, mk, seg, size); + mseg_destroy(ma, flags, mk, seg, size); done: @@ -961,11 +839,11 @@ done: static void * mseg_realloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, void *seg, - Uint old_size, Uint *new_size_p, Uint flags, const ErtsMsegOpt_t *opt) + UWord old_size, UWord *new_size_p, Uint flags, const ErtsMsegOpt_t *opt) { MemKind* mk; void *new_seg; - Uint new_size; + UWord new_size; /* Just allocate a new segment if we didn't have one before */ if (!seg || !old_size) { @@ -985,90 +863,47 @@ mseg_realloc(ErtsMsegAllctr_t *ma, ErtsAlcType_t atype, void *seg, mk = memkind(ma, opt); new_seg = seg; - /* Carrier align */ - new_size = ALIGNED_CEILING(*new_size_p); - - /* Cache optim (if applicable) */ - if (MSEG_FLG_IS_2POW(flags) && !IS_2POW(new_size)) - new_size = ceil_2pow(new_size); - - if (new_size == old_size) - ; - else if (new_size < old_size) { - Uint shrink_sz = old_size - new_size; + if (!MSEG_FLG_IS_2POW(flags)) + new_size = ERTS_PAGEALIGNED_CEILING(*new_size_p); + else { + new_size = ALIGNED_CEILING(*new_size_p); + if (!IS_2POW(new_size)) { + /* Cache optim (if applicable) */ + new_size = ceil_2pow(new_size); + } + } -#if CAN_PARTLY_DESTROY - if (new_size < ma->min_seg_size) - ma->min_seg_size = new_size; -#endif - /* +M<S>rsbcst <ratio> */ - if (shrink_sz < opt->abs_shrink_th - && 100*shrink_sz < opt->rel_shrink_th*old_size) { - new_size = old_size; + if (new_size > old_size) { + if (opt->preserv) { + new_seg = mseg_recreate(ma, flags, mk, (void *) seg, old_size, &new_size); + if (!new_seg) + new_size = old_size; } else { - -#if CAN_PARTLY_DESTROY - - if (erts_mtrace_enabled) - erts_mtrace_crr_realloc(new_seg, atype, SEGTYPE, seg, new_size); - - mseg_destroy(ma, mk, ((char *) seg) + new_size, shrink_sz); - -#elif HAVE_MSEG_RECREATE - goto do_recreate; -#else + mseg_dealloc(ma, atype, seg, old_size, flags, opt); new_seg = mseg_alloc(ma, atype, &new_size, flags, opt); - - ASSERT(MAP_IS_ALIGNED(new_seg) || !new_seg); - if (!new_seg) - new_size = old_size; - else { - sys_memcpy(((char *) new_seg), - ((char *) seg), - MIN(new_size, old_size)); - mseg_dealloc(ma, atype, seg, old_size, flags, opt); - } -#endif + new_size = 0; } } - else { + else if (new_size < old_size) { + UWord shrink_sz = old_size - new_size; - if (!opt->preserv) { - mseg_dealloc(ma, atype, seg, old_size, flags, opt); - new_seg = mseg_alloc(ma, atype, &new_size, flags, opt); - ASSERT(MAP_IS_ALIGNED(new_seg) || !new_seg); + /* +M<S>rsbcst <ratio> */ + if (shrink_sz < opt->abs_shrink_th + && 100*shrink_sz < opt->rel_shrink_th*old_size) { + new_size = old_size; } else { -#if HAVE_MSEG_RECREATE -#if !CAN_PARTLY_DESTROY - do_recreate: -#endif - new_seg = mseg_recreate(ma, mk, (void *) seg, old_size, new_size); - /* ASSERT(MAP_IS_ALIGNED(new_seg) || !new_seg); - * will not always be aligned and it ok for now - */ - - if (erts_mtrace_enabled) - erts_mtrace_crr_realloc(new_seg, atype, SEGTYPE, seg, new_size); + new_seg = mseg_recreate(ma, flags, mk, (void *) seg, old_size, &new_size); if (!new_seg) new_size = old_size; -#else - new_seg = mseg_alloc(ma, atype, &new_size, flags, opt); - - ASSERT(MAP_IS_ALIGNED(new_seg) || !new_seg); - - if (!new_seg) - new_size = old_size; - else { - sys_memcpy(((char *) new_seg), ((char *) seg), MIN(new_size, old_size)); - mseg_dealloc(ma, atype, seg, old_size, flags, opt); - } -#endif } } + if (erts_mtrace_enabled) + erts_mtrace_crr_realloc(new_seg, atype, SEGTYPE, seg, new_size); + INC_CC(ma, realloc); ASSERT(!MSEG_FLG_IS_2POW(flags) || IS_2POW(new_size)); @@ -1106,9 +941,7 @@ static struct { Eterm mseg_create; Eterm mseg_create_resize; Eterm mseg_destroy; -#if HAVE_MSEG_RECREATE Eterm mseg_recreate; -#endif Eterm mseg_clear_cache; Eterm mseg_check_cache; @@ -1129,8 +962,6 @@ init_atoms(ErtsMsegAllctr_t *ma) #ifdef DEBUG Eterm *atom; #endif - - ERTS_MSEG_UNLOCK(ma); erts_mtx_lock(&init_atoms_mutex); if (!atoms_initialized) { @@ -1163,9 +994,7 @@ init_atoms(ErtsMsegAllctr_t *ma) AM_INIT(mseg_create); AM_INIT(mseg_create_resize); AM_INIT(mseg_destroy); -#if HAVE_MSEG_RECREATE AM_INIT(mseg_recreate); -#endif AM_INIT(mseg_clear_cache); AM_INIT(mseg_check_cache); @@ -1176,7 +1005,6 @@ init_atoms(ErtsMsegAllctr_t *ma) #endif } - ERTS_MSEG_LOCK(ma); atoms_initialized = 1; erts_mtx_unlock(&init_atoms_mutex); } @@ -1239,7 +1067,9 @@ info_options(ErtsMsegAllctr_t *ma, Uint **hpp, Uint *szp) { - Eterm res = THE_NON_VALUE; + Eterm res; + + res = erts_mmap_info_options(prefix, print_to_p, print_to_arg, hpp, szp); if (print_to_p) { int to = *print_to_p; @@ -1254,7 +1084,6 @@ info_options(ErtsMsegAllctr_t *ma, if (!atoms_initialized) init_atoms(ma); - res = NIL; add_2tup(hpp, szp, &res, am.mcs, bld_uint(hpp, szp, ma->max_cache_size)); @@ -1293,9 +1122,7 @@ info_calls(ErtsMsegAllctr_t *ma, int *print_to_p, void *print_to_arg, Uint **hpp PRINT_CC(to, arg, create); PRINT_CC(to, arg, create_resize); PRINT_CC(to, arg, destroy); -#if HAVE_MSEG_RECREATE PRINT_CC(to, arg, recreate); -#endif PRINT_CC(to, arg, clear_cache); PRINT_CC(to, arg, check_cache); @@ -1316,12 +1143,10 @@ info_calls(ErtsMsegAllctr_t *ma, int *print_to_p, void *print_to_arg, Uint **hpp bld_unstable_uint(hpp, szp, ma->calls.clear_cache.giga_no), bld_unstable_uint(hpp, szp, ma->calls.clear_cache.no)); -#if HAVE_MSEG_RECREATE add_3tup(hpp, szp, &res, am.mseg_recreate, bld_unstable_uint(hpp, szp, ma->calls.recreate.giga_no), bld_unstable_uint(hpp, szp, ma->calls.recreate.no)); -#endif add_3tup(hpp, szp, &res, am.mseg_destroy, bld_unstable_uint(hpp, szp, ma->calls.destroy.giga_no), @@ -1465,14 +1290,8 @@ erts_mseg_info_options(int ix, ErtsMsegAllctr_t *ma = ERTS_MSEG_ALLCTR_IX(ix); Eterm res; - ERTS_MSEG_LOCK(ma); - - ERTS_DBG_MA_CHK_THR_ACCESS(ma); - res = info_options(ma, "option ", print_to_p, print_to_arg, hpp, szp); - ERTS_MSEG_UNLOCK(ma); - return res; } @@ -1490,10 +1309,6 @@ erts_mseg_info(int ix, Eterm values[4]; Uint n = 0; - ERTS_MSEG_LOCK(ma); - - ERTS_DBG_MA_CHK_THR_ACCESS(ma); - if (hpp || szp) { if (!atoms_initialized) @@ -1506,6 +1321,10 @@ erts_mseg_info(int ix, } values[n++] = info_version(ma, print_to_p, print_to_arg, hpp, szp); values[n++] = info_options(ma, "option ", print_to_p, print_to_arg, hpp, szp); + + ERTS_MSEG_LOCK(ma); + ERTS_DBG_MA_CHK_THR_ACCESS(ma); + #if HALFWORD_HEAP values[n++] = info_memkind(ma, &ma->low_mem, print_to_p, print_to_arg, begin_max_per, hpp, szp); values[n++] = info_memkind(ma, &ma->hi_mem, print_to_p, print_to_arg, begin_max_per, hpp, szp); @@ -1521,7 +1340,7 @@ erts_mseg_info(int ix, } void * -erts_mseg_alloc_opt(ErtsAlcType_t atype, Uint *size_p, Uint flags, const ErtsMsegOpt_t *opt) +erts_mseg_alloc_opt(ErtsAlcType_t atype, UWord *size_p, Uint flags, const ErtsMsegOpt_t *opt) { ErtsMsegAllctr_t *ma = ERTS_MSEG_ALLCTR_OPT(opt); void *seg; @@ -1529,20 +1348,23 @@ erts_mseg_alloc_opt(ErtsAlcType_t atype, Uint *size_p, Uint flags, const ErtsMse ERTS_DBG_MA_CHK_THR_ACCESS(ma); seg = mseg_alloc(ma, atype, size_p, flags, opt); ERTS_MSEG_UNLOCK(ma); + HARD_DBG_INSERT_MSEG(seg, *size_p); return seg; } void * -erts_mseg_alloc(ErtsAlcType_t atype, Uint *size_p, Uint flags) +erts_mseg_alloc(ErtsAlcType_t atype, UWord *size_p, Uint flags) { return erts_mseg_alloc_opt(atype, size_p, flags, &erts_mseg_default_opt); } void erts_mseg_dealloc_opt(ErtsAlcType_t atype, void *seg, - Uint size, Uint flags, const ErtsMsegOpt_t *opt) + UWord size, Uint flags, const ErtsMsegOpt_t *opt) { ErtsMsegAllctr_t *ma = ERTS_MSEG_ALLCTR_OPT(opt); + + HARD_DBG_REMOVE_MSEG(seg, size); ERTS_MSEG_LOCK(ma); ERTS_DBG_MA_CHK_THR_ACCESS(ma); mseg_dealloc(ma, atype, seg, size, flags, opt); @@ -1550,29 +1372,32 @@ erts_mseg_dealloc_opt(ErtsAlcType_t atype, void *seg, } void -erts_mseg_dealloc(ErtsAlcType_t atype, void *seg, Uint size, Uint flags) +erts_mseg_dealloc(ErtsAlcType_t atype, void *seg, UWord size, Uint flags) { erts_mseg_dealloc_opt(atype, seg, size, flags, &erts_mseg_default_opt); } void * erts_mseg_realloc_opt(ErtsAlcType_t atype, void *seg, - Uint old_size, Uint *new_size_p, + UWord old_size, UWord *new_size_p, Uint flags, const ErtsMsegOpt_t *opt) { ErtsMsegAllctr_t *ma = ERTS_MSEG_ALLCTR_OPT(opt); void *new_seg; + + HARD_DBG_REMOVE_MSEG(seg, old_size); ERTS_MSEG_LOCK(ma); ERTS_DBG_MA_CHK_THR_ACCESS(ma); new_seg = mseg_realloc(ma, atype, seg, old_size, new_size_p, flags, opt); ERTS_MSEG_UNLOCK(ma); + HARD_DBG_INSERT_MSEG(new_seg, *new_size_p); return new_seg; } void * erts_mseg_realloc(ErtsAlcType_t atype, void *seg, - Uint old_size, Uint *new_size_p, Uint flags) + UWord old_size, UWord *new_size_p, Uint flags) { return erts_mseg_realloc_opt(atype, seg, old_size, new_size_p, flags, &erts_mseg_default_opt); @@ -1662,16 +1487,17 @@ erts_mseg_init(ErtsMsegInit_t *init) erts_mtx_init(&init_atoms_mutex, "mseg_init_atoms"); -#if HAVE_MMAP && !defined(MAP_ANON) - mmap_fd = open("/dev/zero", O_RDWR); - if (mmap_fd < 0) - erl_exit(ERTS_ABORT_EXIT, "erts_mseg: unable to open /dev/zero\n"); -#endif +#if HALFWORD_HEAP + if (sizeof(void *) != 8) + erl_exit(-1,"Halfword emulator cannot be run in 32bit mode"); -#if HAVE_MMAP && HALFWORD_HEAP - initialize_pmmap(); + init->mmap.virtual_range.start = (char *) sbrk(0); + init->mmap.virtual_range.end = (char *) 0x100000000UL; + init->mmap.sco = 0; #endif + erts_mmap_init(&init->mmap); + if (!IS_2POW(GET_PAGE_SIZE)) erl_exit(ERTS_ABORT_EXIT, "erts_mseg: Unexpected page_size %beu\n", GET_PAGE_SIZE); @@ -1712,10 +1538,6 @@ erts_mseg_init(ErtsMsegInit_t *init) #endif sys_memzero((void *) &ma->calls, sizeof(ErtsMsegCalls)); - -#if CAN_PARTLY_DESTROY - ma->min_seg_size = ~((Uint) 0); -#endif } } @@ -1757,7 +1579,7 @@ erts_mseg_test(UWord op, UWord a1, UWord a2, UWord a3) case 0x400: /* Have erts_mseg */ return (UWord) 1; case 0x401: - return (UWord) erts_mseg_alloc(ERTS_ALC_A_INVALID, (Uint *) a1, (Uint) 0); + return (UWord) erts_mseg_alloc(ERTS_ALC_A_INVALID, (UWord *) a1, (Uint) 0); case 0x402: erts_mseg_dealloc(ERTS_ALC_A_INVALID, (void *) a1, (Uint) a2, (Uint) 0); return (UWord) 0; @@ -1765,7 +1587,7 @@ erts_mseg_test(UWord op, UWord a1, UWord a2, UWord a3) return (UWord) erts_mseg_realloc(ERTS_ALC_A_INVALID, (void *) a1, (Uint) a2, - (Uint *) a3, + (UWord *) a3, (Uint) 0); case 0x404: erts_mseg_clear_cache(); @@ -1788,405 +1610,3 @@ erts_mseg_test(UWord op, UWord a1, UWord a2, UWord a3) } } - - -#if HALFWORD_HEAP -/* - * Very simple page oriented mmap replacer. Works in the lower - * 32 bit address range of a 64bit program. - * Implements anonymous mmap mremap and munmap with address order first fit. - * The free list is expected to be very short... - * To be used for compressed pointers in Erlang halfword emulator - * implementation. The MacOS X version is more of a toy, it's not really - * for production as the halfword erlang VM relies on Linux specific memory - * mapping tricks. - */ - -/* #define HARDDEBUG 1 */ - -#ifdef HARDDEBUG -static void dump_freelist(void) -{ - FreeBlock *p = first; - - while (p) { - fprintf(stderr, "p = %p\r\np->num = %ld\r\np->next = %p\r\n\r\n", - (void *) p, (unsigned long) p->num, (void *) p->next); - p = p->next; - } -} - -#define HARDDEBUG_HW_INCOMPLETE_ALIGNMENT(PTR, SZ) \ - fprintf(stderr,"Mapping of address %p with size %ld " \ - "does not map complete pages (%s:%d)\r\n", \ - (void *) (PTR), (unsigned long) (SZ),__FILE__, __LINE__) - -#define HARDDEBUG_HW_UNALIGNED_ALIGNMENT(PTR, SZ) \ - fprintf(stderr,"Mapping of address %p with size %ld " \ - "is not page aligned (%s:%d)\r\n", \ - (void *) (PTR), (unsigned long) (SZ),__FILE__, __LINE__) - -#define HARDDEBUG_MAP_FAILED(PTR, SZ) \ - fprintf(stderr, "Could not actually map memory " \ - "at address %p with size %ld (%s:%d) ..\r\n", \ - (void *) (PTR), (unsigned long) (SZ),__FILE__, __LINE__) -#else -#define HARDDEBUG_HW_INCOMPLETE_ALIGNMENT(PTR, SZ) do{}while(0) -#define HARDDEBUG_HW_UNALIGNED_ALIGNMENT(PTR, SZ) do{}while(0) -#define HARDDEBUG_MAP_FAILED(PTR, SZ) do{}while(0) -#endif - - -#ifdef __APPLE__ -#define MAP_ANONYMOUS MAP_ANON -#endif - -#define INIT_LOCK() do {erts_mtx_init(&pmmap_mutex, "pmmap");} while(0) - -#define TAKE_LOCK() do {erts_mtx_lock(&pmmap_mutex);} while(0) - -#define RELEASE_LOCK() do {erts_mtx_unlock(&pmmap_mutex);} while(0) - -static erts_mtx_t pmmap_mutex; /* Also needed when !USE_THREADS */ - -typedef struct _free_block { - unsigned long num; /*pages*/ - struct _free_block *next; -} FreeBlock; - -/* Protect with lock */ -static FreeBlock *first; - -static void *do_map(void *ptr, size_t sz) -{ - void *res; - - if (ALIGNED_CEILING(sz) != sz) { - HARDDEBUG_HW_INCOMPLETE_ALIGNMENT(ptr, sz); - return NULL; - } - - if (((unsigned long) ptr) % MSEG_ALIGNED_SIZE) { - HARDDEBUG_HW_UNALIGNED_ALIGNMENT(ptr, sz); - return NULL; - } - -#if HAVE_MMAP - res = mmap(ptr, sz, - PROT_READ | PROT_WRITE, MAP_PRIVATE | - MAP_ANONYMOUS | MAP_FIXED, - -1 , 0); -#else -# error "Missing mmap support" -#endif - - if (res == MAP_FAILED) { - HARDDEBUG_MAP_FAILED(ptr, sz); - return NULL; - } - - return res; -} - -static int do_unmap(void *ptr, size_t sz) -{ - void *res; - - if (ALIGNED_CEILING(sz) != sz) { - HARDDEBUG_HW_INCOMPLETE_ALIGNMENT(ptr, sz); - return 1; - } - - if (((unsigned long) ptr) % MSEG_ALIGNED_SIZE) { - HARDDEBUG_HW_UNALIGNED_ALIGNMENT(ptr, sz); - return 1; - } - - res = mmap(ptr, sz, - PROT_NONE, MAP_PRIVATE | MAP_ANONYMOUS | MAP_NORESERVE | MAP_FIXED, - -1 , 0); - - if (res == MAP_FAILED) { - HARDDEBUG_MAP_FAILED(ptr, sz); - return 1; - } - - return 0; -} - -#ifdef __APPLE__ -/* - * The first 4 gig's are protected on Macos X for 64bit processes :( - * The range 0x1000000000 - 0x10FFFFFFFF is selected as an arbitrary - * value of a normally unused range... Real MMAP's will avoid - * it and all 32bit compressed pointers can be in that range... - * More expensive than on Linux where expansion of compressed - * poiters involves no masking (as they are in the first 4 gig's). - * It's also very uncertain if the MAP_NORESERVE flag really has - * any effect in MacOS X. Swap space may always be allocated... - */ -#define SET_RANGE_MIN() /* nothing */ -#define RANGE_MIN 0x1000000000UL -#define RANGE_MAX 0x1100000000UL -#define RANGE_MASK (RANGE_MIN) -#define EXTRA_MAP_FLAGS (MAP_FIXED) -#else -static size_t range_min; -#define SET_RANGE_MIN() do { range_min = (size_t) sbrk(0); } while (0) -#define RANGE_MIN range_min -#define RANGE_MAX 0x100000000UL -#define RANGE_MASK 0UL -#define EXTRA_MAP_FLAGS (0) -#endif - -static int initialize_pmmap(void) -{ - char *p,*q,*rptr; - size_t rsz; - FreeBlock *initial; - - SET_RANGE_MIN(); - if (sizeof(void *) != 8) { - erl_exit(1,"Halfword emulator cannot be run in 32bit mode"); - } - - p = (char *) RANGE_MIN; - q = (char *) RANGE_MAX; - - rsz = ALIGNED_FLOOR(q - p); - - rptr = mmap_align(NULL, (void *) p, rsz, - PROT_NONE, MAP_PRIVATE | MAP_ANONYMOUS | - MAP_NORESERVE | EXTRA_MAP_FLAGS, - -1 , 0); -#ifdef HARDDEBUG - printf("p=%p, rsz = %ld, pages = %ld, got range = %p -> %p\r\n", - p, (unsigned long) rsz, (unsigned long) (rsz / MSEG_ALIGNED_SIZE), - (void *) rptr, (void*)(rptr + rsz)); -#endif - if ((UWord)(rptr + rsz) > RANGE_MAX) { - size_t rsz_trunc = RANGE_MAX - (UWord)rptr; -#ifdef HARDDEBUG - printf("Reducing mmap'ed memory from %lu to %lu Mb, reduced range = %p -> %p\r\n", - rsz/(1024*1024), rsz_trunc/(1024*1024), rptr, rptr+rsz_trunc); -#endif - munmap((void*)RANGE_MAX, rsz - rsz_trunc); - rsz = rsz_trunc; - } - if (!do_map(rptr, MSEG_ALIGNED_SIZE)) { - erl_exit(1,"Could not actually mmap first page for halfword emulator...\n"); - } - initial = (FreeBlock *) rptr; - initial->num = (rsz / MSEG_ALIGNED_SIZE); - initial->next = NULL; - first = initial; - INIT_LOCK(); - return 0; -} - -static void *pmmap(size_t size) -{ - size_t real_size = ALIGNED_CEILING(size); - size_t num_pages = real_size / MSEG_ALIGNED_SIZE; - FreeBlock **block; - FreeBlock *tail; - FreeBlock *res; - - TAKE_LOCK(); - - for (block = &first; - *block != NULL && (*block)->num < num_pages; - block = &((*block)->next)) - ; - if (!(*block)) { - RELEASE_LOCK(); - return NULL; - } - if ((*block)->num == num_pages) { - /* nice, perfect fit */ - res = *block; - *block = (*block)->next; - } else { - tail = (FreeBlock *) (((char *) ((void *) (*block))) + real_size); - if (!do_map(tail, MSEG_ALIGNED_SIZE)) { - HARDDEBUG_MAP_FAILED(tail, MSEG_ALIGNED_SIZE); - RELEASE_LOCK(); - return NULL; - } - tail->num = (*block)->num - num_pages; - tail->next = (*block)->next; - res = *block; - *block = tail; - } - - RELEASE_LOCK(); - - if (!do_map(res, real_size)) { - HARDDEBUG_MAP_FAILED(res, real_size); - return NULL; - } - - return (void *) res; -} - -static int pmunmap(void *p, size_t size) -{ - size_t real_size = ALIGNED_CEILING(size); - size_t num_pages = real_size / MSEG_ALIGNED_SIZE; - - FreeBlock *block; - FreeBlock *last; - FreeBlock *nb = (FreeBlock *) p; - - ASSERT(((unsigned long)p & CHECK_POINTER_MASK)==0); - - if (real_size > MSEG_ALIGNED_SIZE) { - if (do_unmap(((char *) p) + MSEG_ALIGNED_SIZE, real_size - MSEG_ALIGNED_SIZE)) { - return 1; - } - } - - TAKE_LOCK(); - - last = NULL; - block = first; - while(block != NULL && ((void *) block) < p) { - last = block; - block = block->next; - } - - if (block != NULL && - ((void *) block) == ((void *) (((char *) p) + real_size))) { - /* Merge new free block with following */ - nb->num = block->num + num_pages; - nb->next = block->next; - if (do_unmap(block, MSEG_ALIGNED_SIZE)) { - RELEASE_LOCK(); - return 1; - } - } else { - /* just link in */ - nb->num = num_pages; - nb->next = block; - } - if (last != NULL) { - if (p == ((void *) (((char *) last) + (last->num * MSEG_ALIGNED_SIZE)))) { - /* Merge with previous */ - last->num += nb->num; - last->next = nb->next; - if (do_unmap(nb, MSEG_ALIGNED_SIZE)) { - RELEASE_LOCK(); - return 1; - } - } else { - last->next = nb; - } - } else { - first = nb; - } - RELEASE_LOCK(); - return 0; -} - -static void *pmremap(void *old_address, size_t old_size, - size_t new_size) -{ - size_t new_real_size = ALIGNED_CEILING(new_size); - size_t new_num_pages = new_real_size / MSEG_ALIGNED_SIZE; - size_t old_real_size = ALIGNED_CEILING(old_size); - size_t old_num_pages = old_real_size / MSEG_ALIGNED_SIZE; - if (new_num_pages == old_num_pages) { - return old_address; - } else if (new_num_pages < old_num_pages) { /* Shrink */ - size_t nfb_pages = old_num_pages - new_num_pages; - size_t nfb_real_size = old_real_size - new_real_size; - void *vnfb = (void *) (((char *)old_address) + new_real_size); - FreeBlock *nfb = (FreeBlock *) vnfb; - FreeBlock **block; - TAKE_LOCK(); - for (block = &first; - *block != NULL && (*block) < nfb; - block = &((*block)->next)) - ; - if (!(*block) || - (*block) > ((FreeBlock *)(((char *) vnfb) + nfb_real_size))) { - /* Normal link in */ - if (nfb_pages > 1) { - if (do_unmap((void *)(((char *) vnfb) + MSEG_ALIGNED_SIZE), - (nfb_pages - 1)*MSEG_ALIGNED_SIZE)) { - return NULL; - } - } - nfb->next = (*block); - nfb->num = nfb_pages; - (*block) = nfb; - } else { /* block merge */ - nfb->next = (*block)->next; - nfb->num = nfb_pages + (*block)->num; - /* unmap also the first page of the next freeblock */ - (*block) = nfb; - if (do_unmap((void *)(((char *) vnfb) + MSEG_ALIGNED_SIZE), - nfb_pages*MSEG_ALIGNED_SIZE)) { - return NULL; - } - } - RELEASE_LOCK(); - return old_address; - } else { /* Enlarge */ - FreeBlock **block; - void *old_end = (void *) (((char *)old_address) + old_real_size); - TAKE_LOCK(); - for (block = &first; - *block != NULL && (*block) < (FreeBlock *) old_address; - block = &((*block)->next)) - ; - if ((*block) == NULL || old_end > ((void *) RANGE_MAX) || - (*block) != old_end || - (*block)->num < (new_num_pages - old_num_pages)) { - /* cannot extend */ - void *result; - RELEASE_LOCK(); - result = pmmap(new_size); - if (result == NULL) { - return NULL; - } - memcpy(result,old_address,old_size); - if (pmunmap(old_address,old_size)) { - /* Oups... */ - pmunmap(result,new_size); - return NULL; - } - return result; - } else { /* extend */ - size_t remaining_pages = (*block)->num - - (new_num_pages - old_num_pages); - if (!remaining_pages) { - void *p = (void *) (((char *) (*block)) + MSEG_ALIGNED_SIZE); - void *n = (*block)->next; - size_t x = ((*block)->num - 1) * MSEG_ALIGNED_SIZE; - if (x > 0) { - if (do_map(p,x) == NULL) { - RELEASE_LOCK(); - return NULL; - } - } - (*block) = n; - } else { - FreeBlock *nfb = (FreeBlock *) ((void *) - (((char *) old_address) + - new_real_size)); - void *p = (void *) (((char *) (*block)) + MSEG_ALIGNED_SIZE); - if (do_map(p,new_real_size - old_real_size) == NULL) { - RELEASE_LOCK(); - return NULL; - } - nfb->num = remaining_pages; - nfb->next = (*block)->next; - (*block) = nfb; - } - RELEASE_LOCK(); - return old_address; - } - } -} -#endif /* HALFWORD_HEAP */ diff --git a/erts/emulator/sys/common/erl_mseg.h b/erts/emulator/sys/common/erl_mseg.h index a1b000f51c..2284b3f8f1 100644 --- a/erts/emulator/sys/common/erl_mseg.h +++ b/erts/emulator/sys/common/erl_mseg.h @@ -22,15 +22,16 @@ #include "sys.h" #include "erl_alloc_types.h" +#include "erl_mmap.h" -#ifndef HAVE_MMAP -# define HAVE_MMAP 0 -#endif -#ifndef HAVE_MREMAP -# define HAVE_MREMAP 0 -#endif - -#if HAVE_MMAP +/* + * We currently only enable mseg_alloc if we got + * a genuine mmap()/munmap() primitive. It is possible + * to utilize erts_mmap() withiout a mmap support but + * alloc_util needs to be prepared before we can do + * that. + */ +#ifdef ERTS_HAVE_GENUINE_OS_MMAP # define HAVE_ERTS_MSEG 1 # define ERTS_HAVE_MSEG_SUPER_ALIGNED 1 #else @@ -39,8 +40,7 @@ #endif #if ERTS_HAVE_MSEG_SUPER_ALIGNED -# define MSEG_ALIGN_BITS (18) - /* Affects hard limits for sbct and lmbcs documented in erts_alloc.xml */ +# define MSEG_ALIGN_BITS ERTS_MMAP_SUPERALIGNED_BITS #else /* If we don't use super aligned multiblock carriers * we will mmap with page size alignment (and thus use corresponding @@ -68,6 +68,7 @@ typedef struct { Uint rmcbf; Uint mcs; Uint nos; + ErtsMMapInit mmap; } ErtsMsegInit_t; #define ERTS_MSEG_INIT_DEFAULT_INITIALIZER \ @@ -75,7 +76,8 @@ typedef struct { 4*1024*1024, /* amcbf: Absolute max cache bad fit */ \ 20, /* rmcbf: Relative max cache bad fit */ \ 10, /* mcs: Max cache size */ \ - 1000 /* cci: Cache check interval */ \ + 1000, /* cci: Cache check interval */ \ + ERTS_MMAP_INIT_DEFAULT_INITER \ } typedef struct { @@ -91,12 +93,12 @@ typedef struct { extern const ErtsMsegOpt_t erts_mseg_default_opt; -void *erts_mseg_alloc(ErtsAlcType_t, Uint *, Uint); -void *erts_mseg_alloc_opt(ErtsAlcType_t, Uint *, Uint, const ErtsMsegOpt_t *); -void erts_mseg_dealloc(ErtsAlcType_t, void *, Uint, Uint); -void erts_mseg_dealloc_opt(ErtsAlcType_t, void *, Uint, Uint, const ErtsMsegOpt_t *); -void *erts_mseg_realloc(ErtsAlcType_t, void *, Uint, Uint *, Uint); -void *erts_mseg_realloc_opt(ErtsAlcType_t, void *, Uint, Uint *, Uint, const ErtsMsegOpt_t *); +void *erts_mseg_alloc(ErtsAlcType_t, UWord *, Uint); +void *erts_mseg_alloc_opt(ErtsAlcType_t, UWord *, Uint, const ErtsMsegOpt_t *); +void erts_mseg_dealloc(ErtsAlcType_t, void *, UWord, Uint); +void erts_mseg_dealloc_opt(ErtsAlcType_t, void *, UWord, Uint, const ErtsMsegOpt_t *); +void *erts_mseg_realloc(ErtsAlcType_t, void *, UWord, UWord *, Uint); +void *erts_mseg_realloc_opt(ErtsAlcType_t, void *, UWord, UWord *, Uint, const ErtsMsegOpt_t *); void erts_mseg_clear_cache(void); void erts_mseg_cache_check(void); Uint erts_mseg_no( const ErtsMsegOpt_t *); diff --git a/erts/emulator/sys/unix/sys.c b/erts/emulator/sys/unix/sys.c index fdc3167c62..401b37b9d2 100644 --- a/erts/emulator/sys/unix/sys.c +++ b/erts/emulator/sys/unix/sys.c @@ -2638,15 +2638,13 @@ int fd; } -#ifdef DEBUG - extern int erts_initialized; void -erl_assert_error(char* expr, char* file, int line) +erl_assert_error(const char* expr, const char* func, const char* file, int line) { fflush(stdout); - fprintf(stderr, "Assertion failed: %s in %s, line %d\n", - expr, file, line); + fprintf(stderr, "%s:%d:%s() Assertion failed: %s\n", + file, line, func, expr); fflush(stderr); #if !defined(ERTS_SMP) && 0 /* Writing a crashdump from a failed assertion when smp support @@ -2661,6 +2659,8 @@ erl_assert_error(char* expr, char* file, int line) abort(); } +#ifdef DEBUG + void erl_debug(char* fmt, ...) { diff --git a/erts/emulator/sys/win32/sys.c b/erts/emulator/sys/win32/sys.c index 6a1d6b08f4..99951bb45e 100755 --- a/erts/emulator/sys/win32/sys.c +++ b/erts/emulator/sys/win32/sys.c @@ -3224,7 +3224,7 @@ erl_bin_write(buf, sz, max) } void -erl_assert_error(char* expr, char* file, int line) +erl_assert_error(const char* expr, const char* func, const char* file, int line) { char message[1024]; diff --git a/erts/emulator/test/alloc_SUITE.erl b/erts/emulator/test/alloc_SUITE.erl index 801ed0f85a..f6ff6bb813 100644 --- a/erts/emulator/test/alloc_SUITE.erl +++ b/erts/emulator/test/alloc_SUITE.erl @@ -29,6 +29,7 @@ bucket_mask/1, rbtree/1, mseg_clear_cache/1, + erts_mmap/1, cpool/1]). -export([init_per_testcase/2, end_per_testcase/2]). @@ -41,7 +42,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> [basic, coalesce, threads, realloc_copy, bucket_index, - bucket_mask, rbtree, mseg_clear_cache, cpool]. + bucket_mask, rbtree, mseg_clear_cache, erts_mmap, cpool]. groups() -> []. @@ -110,6 +111,59 @@ cpool(suite) -> []; cpool(doc) -> []; cpool(Cfg) -> ?line drv_case(Cfg). +erts_mmap(Config) when is_list(Config) -> + case {?t:os_type(), is_halfword_vm()} of + {{unix, _}, false} -> + [erts_mmap_do(Config, SCO, SCRPM, SCMGC) + || SCO <-[true,false], SCMGC <-[1234,0], SCRPM <- [true,false]]; + + {_,true} -> + {skipped, "No supercarrier support on halfword vm"}; + {SkipOs,_} -> + ?line {skipped, + lists:flatten(["Not run on " + | io_lib:format("~p",[SkipOs])])} + end. + + +erts_mmap_do(Config, SCO, SCRPM, SCMGC) -> + SCS = 100, % Mb + O1 = "+MMscs" ++ integer_to_list(SCS) + ++ " +MMsco" ++ atom_to_list(SCO) + ++ " +MMscrpm" ++ atom_to_list(SCRPM), + Opts = case SCMGC of + 0 -> O1; + _ -> O1 ++ " +MMscmgc"++integer_to_list(SCMGC) + end, + {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 >= SCMGC), + + 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, + stop_node(Node), + Result. + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% %% Internal functions %% @@ -179,7 +233,9 @@ receive_drv_result(Port, CaseName) -> ?line {comment, Comment} end. -start_node(Config) when is_list(Config) -> +start_node(Config) -> + start_node(Config, []). +start_node(Config, Opts) when is_list(Config), is_list(Opts) -> ?line Pa = filename:dirname(code:which(?MODULE)), ?line {A, B, C} = now(), ?line Name = list_to_atom(atom_to_list(?MODULE) @@ -191,7 +247,14 @@ start_node(Config) when is_list(Config) -> ++ integer_to_list(B) ++ "-" ++ integer_to_list(C)), - ?line ?t:start_node(Name, slave, [{args, "-pa "++Pa}]). + ?line ?t:start_node(Name, slave, [{args, Opts++" -pa "++Pa}]). stop_node(Node) -> ?t:stop_node(Node). + +is_halfword_vm() -> + case {erlang:system_info({wordsize, internal}), + erlang:system_info({wordsize, external})} of + {4, 8} -> true; + {WS, WS} -> false + end. diff --git a/erts/emulator/test/big_SUITE_data/eq_big.dat b/erts/emulator/test/big_SUITE_data/eq_big.dat index 5511d1bf10..4ccb33d182 100644 --- a/erts/emulator/test/big_SUITE_data/eq_big.dat +++ b/erts/emulator/test/big_SUITE_data/eq_big.dat @@ -13001,4 +13001,5 @@ 0 = 7153697524993 bsr 475833444444444444444444444444444444444444444444. -1 = -83987348 bsr 475833444444444444444444444444444444444444444444. +0 = 1183140560213014108063589658350 bsr 146783911423364576743092537299333564210980159306769991919205685720763064069663027716481187399048043939495935. diff --git a/erts/emulator/test/call_trace_SUITE.erl b/erts/emulator/test/call_trace_SUITE.erl index eaecd32f95..ef1f2aa04c 100644 --- a/erts/emulator/test/call_trace_SUITE.erl +++ b/erts/emulator/test/call_trace_SUITE.erl @@ -1193,7 +1193,7 @@ bs_sum_b(Acc, <<>>) -> Acc. - + %%% Help functions. expect() -> diff --git a/erts/emulator/test/driver_SUITE.erl b/erts/emulator/test/driver_SUITE.erl index 104bdf8aec..7087542899 100644 --- a/erts/emulator/test/driver_SUITE.erl +++ b/erts/emulator/test/driver_SUITE.erl @@ -367,7 +367,7 @@ compare(Got, Expected) -> ?t:fail(got_bad_data) end. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Driver timer test suites %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -515,7 +515,7 @@ try_change_timer(Port, Timeout) -> ?line test_server:fail("driver failed to timeout") end. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Queue test suites %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -719,7 +719,7 @@ deq(Port, Size) -> read_head(Port, Size) -> erlang:port_control(Port, ?READ_HEAD, <<Size:32>>). - + driver_unloaded(doc) -> []; driver_unloaded(suite) -> diff --git a/erts/emulator/test/statistics_SUITE.erl b/erts/emulator/test/statistics_SUITE.erl index a93dd309c1..c428be6c5a 100644 --- a/erts/emulator/test/statistics_SUITE.erl +++ b/erts/emulator/test/statistics_SUITE.erl @@ -75,7 +75,7 @@ end_per_group(_GroupName, Config) -> Config. - + %%% Testing statistics(wall_clock). @@ -121,7 +121,7 @@ wall_clock_update1(N) when N > 0 -> wall_clock_update1(0) -> ok. - + %%% Test statistics(runtime). @@ -199,7 +199,7 @@ do_much(N) -> _ = 4784728478274827 * 72874284728472, do_much(N-1). - + reductions(doc) -> "Test that statistics(reductions) is callable, and that " "Total_Reductions and Reductions_Since_Last_Call make sense. " @@ -246,7 +246,7 @@ reductions_big_loop() -> reductions_big_loop() end. - + %%% Tests of statistics(run_queue). @@ -295,7 +295,7 @@ hog_iter(N, Mon) when N > 0 -> end; hog_iter(0, Mon) -> ?line hog_iter(10000, Mon). - + %%% Tests of statistics(scheduler_wall_time). scheduler_wall_time(doc) -> @@ -363,7 +363,7 @@ load_percentage([{Id, WN, TN}|Ss], [{Id, WP, TP}|Ps]) -> [100*(WN-WP) div (TN-TP)|load_percentage(Ss, Ps)]; load_percentage([], []) -> []. - + garbage_collection(doc) -> "Tests that statistics(garbage_collection) is callable. " "It is not clear how to test anything more."; diff --git a/erts/emulator/test/time_SUITE.erl b/erts/emulator/test/time_SUITE.erl index 4d12e3449c..a0a8a9c42c 100644 --- a/erts/emulator/test/time_SUITE.erl +++ b/erts/emulator/test/time_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2011. All Rights Reserved. +%% Copyright Ericsson AB 1997-2013. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -241,14 +241,26 @@ compare(Utc0, Local) -> %% Two linear times can be subtracted to give their difference %% in seconds. %% -%% XXX Limitations: The length of months and leap years are not -%% taken into account; thus a comparision of dates is only -%% valid if they are in the SAME month. +%% XXX Limitations: Simplified leap year calc will fail for 2100 :-) linear_time({{Year, Mon, Day}, {Hour, Min, Sec}}) -> - 86400*(366*Year + 31*(Mon-1) + (Day-1)) + + 86400*(year_to_days(Year) + month_to_days(Year,Mon) + (Day-1)) + 3600*Hour + 60*Min + Sec. +year_to_days(Year) -> + Year * 365 + (Year-1) div 4. + +month_to_days(Year, Mon) -> + DoM = [31,days_in_february(Year),31,30,31,30,31,31,30,31,30,31], + {PastMonths,_} = lists:split(Mon-1, DoM), + lists:sum(PastMonths). + +days_in_february(Year) -> + case (Year rem 4) of + 0 -> 29; + _ -> 28 + end. + %% This functions returns either the normal timezone or the %% the DST timezone, depending on the given UTC time. %% diff --git a/erts/emulator/test/trace_SUITE.erl b/erts/emulator/test/trace_SUITE.erl index 0f513f0dcb..2251575e5a 100644 --- a/erts/emulator/test/trace_SUITE.erl +++ b/erts/emulator/test/trace_SUITE.erl @@ -1427,7 +1427,7 @@ receive_nothing() -> ok end. - + %%% Models for various kinds of processes. process(Dest) -> diff --git a/erts/emulator/test/trace_port_SUITE.erl b/erts/emulator/test/trace_port_SUITE.erl index cc2eadafbc..99df8da107 100644 --- a/erts/emulator/test/trace_port_SUITE.erl +++ b/erts/emulator/test/trace_port_SUITE.erl @@ -648,7 +648,7 @@ fun_spawn(Fun, Opts) -> % [] % end. - + %%% Models for various kinds of processes. %% Sends messages when ordered to. diff --git a/erts/etc/common/erlexec.c b/erts/etc/common/erlexec.c index 30560f5a2f..c9908caf20 100644 --- a/erts/etc/common/erlexec.c +++ b/erts/etc/common/erlexec.c @@ -109,6 +109,10 @@ static char *plusM_other_switches[] = { "Mamcbf", "Mrmcbf", "Mmcs", + "Mscs", + "Mscmgc", + "Msco", + "Mscrpm", "Ye", "Ym", "Ytp", diff --git a/erts/etc/unix/Makefile b/erts/etc/unix/Makefile index e85d2fab0c..c137a31ec2 100644 --- a/erts/etc/unix/Makefile +++ b/erts/etc/unix/Makefile @@ -29,7 +29,7 @@ opt debug: etc etc: etp-commands etp-commands: etp-commands.in - sed 's:@ERL_TOP@:${ERL_TOP}:g' etp-commands.in > etp-commands + $(gen_verbose)sed 's:@ERL_TOP@:${ERL_TOP}:g' etp-commands.in > etp-commands .PHONY: docs docs: diff --git a/erts/preloaded/ebin/erlang.beam b/erts/preloaded/ebin/erlang.beam Binary files differindex f1791200e0..5a9ffa89d1 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 d40ee7c59a..2b6760c675 100644 --- a/erts/preloaded/src/erlang.erl +++ b/erts/preloaded/src/erlang.erl @@ -3499,6 +3499,8 @@ mk_res_list([]) -> mk_res_list([Alloc | Rest]) -> [{Alloc, []} | mk_res_list(Rest)]. +insert_instance(I, N, Rest) when erlang:is_atom(N) -> + [{N, I} | Rest]; insert_instance(I, N, []) -> [{instance, N, I}]; insert_instance(I, N, [{instance, M, _}|_] = Rest) when N < M -> diff --git a/lib/asn1/src/Makefile b/lib/asn1/src/Makefile index 3f24e15c04..500f4a1358 100644 --- a/lib/asn1/src/Makefile +++ b/lib/asn1/src/Makefile @@ -135,7 +135,7 @@ $(EBIN)/asn1ct_func.$(EMULATOR): asn1ct_func.erl asn1ct_eval_%.erl: asn1ct_eval_%.funcs $(gen_verbose)erl -pa $(EBIN) -noshell -noinput \ - -run prepare_templates gen_asn1ct_eval $< >$@ + -run prepare_templates gen_asn1ct_eval $< $(APP_TARGET): $(APP_SRC) ../vsn.mk $(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@ @@ -180,7 +180,7 @@ RT_TEMPLATES_TARGET = $(RT_TEMPLATES:%=%.$(EMULATOR)) asn1ct_rtt.erl: prepare_templates.$(EMULATOR) $(RT_TEMPLATES_TARGET) $(gen_verbose)erl -noshell -noinput -run prepare_templates gen_asn1ct_rtt \ - $(RT_TEMPLATES_TARGET) >asn1ct_rtt.erl + $(RT_TEMPLATES_TARGET) prepare_templates.$(EMULATOR): prepare_templates.erl $(V_ERLC) prepare_templates.erl diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl index eddcda0018..04227fd23b 100644 --- a/lib/asn1/src/asn1ct_check.erl +++ b/lib/asn1/src/asn1ct_check.erl @@ -2534,89 +2534,54 @@ normalize_integer(S,Int=#'Externalvaluereference'{value=Name},Type) -> normalize_integer(_,Int,_) -> exit({'Unknown INTEGER value',Int}). -normalize_bitstring(S,Value,Type)-> - %% There are four different Erlang formats of BIT STRING: - %% 1 - a list of ones and zeros. - %% 2 - a list of atoms. - %% 3 - as an integer, for instance in hexadecimal form. - %% 4 - as a tuple {Unused, Binary} where Unused is an integer - %% and tells how many bits of Binary are unused. - %% - %% normalize_bitstring/3 transforms Value according to: - %% A to 3, - %% B to 1, - %% C to 1 or 3 - %% D to 2, - %% Value can be on format: - %% A - {hstring, String}, where String is a hexadecimal string. - %% B - {bstring, String}, where String is a string on bit format - %% C - #'Externalvaluereference'{value=V}, where V is a defined value - %% D - list of #'Externalvaluereference', where each value component - %% is an identifier corresponing to NamedBits in Type. - %% E - list of ones and zeros, if Value already is normalized. +%% normalize_bitstring(S, Value, Type) -> bitstring() +%% Convert a literal value for a BIT STRING to an Erlang bit string. +%% +normalize_bitstring(S, Value, Type)-> case Value of {hstring,String} when is_list(String) -> - hstring_to_int(String); + hstring_to_bitstring(String); {bstring,String} when is_list(String) -> - bstring_to_bitlist(String); - Rec when is_record(Rec,'Externalvaluereference') -> - get_normalized_value(S,Value,Type, - fun normalize_bitstring/3,[]); + bstring_to_bitstring(String); + #'Externalvaluereference'{} -> + get_normalized_value(S, Value, Type, + fun normalize_bitstring/3, []); RecList when is_list(RecList) -> - case Type of - NBL when is_list(NBL) -> - F = fun(#'Externalvaluereference'{value=Name}) -> - case lists:keysearch(Name,1,NBL) of - {value,{Name,_}} -> - Name; - Other -> - throw({error,Other}) - end; - (I) when I =:= 1; I =:= 0 -> - I; - (Other) -> - throw({error,Other}) - end, - case catch lists:map(F,RecList) of - {error,Reason} -> - asn1ct:warning("default value not " - "compatible with type definition ~p~n", - [Reason],S, - "default value not " - "compatible with type definition"), - Value; - NewList -> - NewList - end; - _ -> + F = fun(#'Externalvaluereference'{value=Name}) -> + case lists:keymember(Name, 1, Type) of + true -> Name; + false -> throw({error,false}) + end; + (Name) when is_atom(Name) -> + %% Already normalized. + Name; + (Other) -> + throw({error,Other}) + end, + try + lists:map(F, RecList) + catch + throw:{error,Reason} -> asn1ct:warning("default value not " "compatible with type definition ~p~n", - [RecList],S, + [Reason],S, "default value not " "compatible with type definition"), Value end; - {Name,String} when is_atom(Name) -> - normalize_bitstring(S,String,Type); - Other -> - asn1ct:warning("illegal default value ~p~n",[Other],S, - "illegal default value"), - Value + Bs when is_bitstring(Bs) -> + %% Already normalized. + Bs end. -hstring_to_int(L) when is_list(L) -> - hstring_to_int(L,0). -hstring_to_int([H|T],Acc) when H >= $A, H =< $F -> - hstring_to_int(T,(Acc bsl 4) + (H - $A + 10) ) ; -hstring_to_int([H|T],Acc) when H >= $0, H =< $9 -> - hstring_to_int(T,(Acc bsl 4) + (H - $0)); -hstring_to_int([],Acc) -> - Acc. +hstring_to_bitstring(L) -> + << <<(hex_to_int(D)):4>> || D <- L >>. -bstring_to_bitlist([H|T]) when H == $0; H == $1 -> - [H - $0 | bstring_to_bitlist(T)]; -bstring_to_bitlist([]) -> - []. +bstring_to_bitstring(L) -> + << <<(D-$0):1>> || D <- L >>. + +hex_to_int(D) when $0 =< D, D =< $9 -> D - $0; +hex_to_int(D) when $A =< D, D =< $F -> D - ($A - 10). %% normalize_octetstring/1 changes representation of input Value to a %% list of octets. diff --git a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl index 8359b81b33..a38da8bcc2 100644 --- a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl @@ -1155,7 +1155,8 @@ gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> emit([indent(4),"_ ->",nl]), case OptOrMand of - {'DEFAULT', Def} -> + {'DEFAULT', Def0} -> + Def = asn1ct_gen:conform_value(Type, Def0), emit([indent(8),"{",{asis,Def},",",{prev,tlv},"}",nl]); 'OPTIONAL' -> emit([indent(8),"{ asn1_NOVALUE, ",{prev,tlv},"}",nl]) diff --git a/lib/asn1/src/asn1ct_constructed_per.erl b/lib/asn1/src/asn1ct_constructed_per.erl index 8d4afc0a0b..4672f7edd3 100644 --- a/lib/asn1/src/asn1ct_constructed_per.erl +++ b/lib/asn1/src/asn1ct_constructed_per.erl @@ -770,8 +770,10 @@ optionals(L) -> optionals(L,[],2). optionals([#'ComponentType'{prop='OPTIONAL'}|Rest], Acc, Pos) -> optionals(Rest, [Pos|Acc], Pos+1); -optionals([#'ComponentType'{prop={'DEFAULT',Val}}|Rest], Acc, Pos) -> - optionals(Rest, [{Pos,Val}|Acc], Pos+1); +optionals([#'ComponentType'{typespec=T,prop={'DEFAULT',Val}}|Rest], + Acc, Pos) -> + Vals = def_values(T, Val), + optionals(Rest, [{Pos,Vals}|Acc], Pos+1); optionals([#'ComponentType'{}|Rest], Acc, Pos) -> optionals(Rest, Acc, Pos+1); optionals([], Acc, _) -> @@ -888,7 +890,8 @@ gen_enc_components_call1(Erule,TopType, optional -> asn1ct_imm:enc_absent(Element, [asn1_NOVALUE], Imm1); {default,Def} -> - asn1ct_imm:enc_absent(Element, [asn1_DEFAULT,Def], Imm1) + DefValues = def_values(Type, Def), + asn1ct_imm:enc_absent(Element, DefValues, Imm1) end, Imm = case Imm2 of [] -> []; @@ -899,6 +902,38 @@ gen_enc_components_call1(_Erule,_TopType,[],Pos,_,_, Acc) -> ImmList = lists:reverse(Acc), {ImmList,Pos}. +def_values(#type{def=#'Externaltypereference'{module=Mod,type=Type}}, Def) -> + #typedef{typespec=T} = asn1_db:dbget(Mod, Type), + def_values(T, Def); +def_values(#type{def={'BIT STRING',[]}}, Bs) when is_bitstring(Bs) -> + ListBs = [B || <<B:1>> <= Bs], + IntBs = lists:foldl(fun(B, A) -> + (A bsl 1) bor B + end, 0, lists:reverse(ListBs)), + Sz = bit_size(Bs), + Compact = case 8 - Sz rem 8 of + 8 -> + {0,Bs}; + Unused -> + {Unused,<<Bs:Sz/bits,0:Unused>>} + end, + [asn1_DEFAULT,Bs,Compact,ListBs,IntBs]; +def_values(#type{def={'BIT STRING',[_|_]=Ns}}, List) when is_list(List) -> + Bs = asn1ct_gen:named_bitstring_value(List, Ns), + ListBs = [B || <<B:1>> <= Bs], + IntBs = lists:foldl(fun(B, A) -> + (A bsl 1) bor B + end, 0, lists:reverse(ListBs)), + Args = [List,Bs,ListBs,IntBs], + {call,per_common,is_default_bitstring,Args}; +def_values(#type{def={'INTEGER',Ns}}, Def) -> + [asn1_DEFAULT,Def|case lists:keyfind(Def, 2, Ns) of + false -> []; + {Val,Def} -> [Val] + end]; +def_values(_, Def) -> + [asn1_DEFAULT,Def]. + gen_enc_line_imm(Erule, TopType, Cname, Type, Element, DynamicEnc, Ext) -> Imm0 = gen_enc_line_imm_1(Erule, TopType, Cname, Type, Element, DynamicEnc), @@ -1207,7 +1242,8 @@ gen_dec_comp_call(Comp, Erule, TopType, Tpos, OptTable, DecInfObj, comp_call_pre_post(noext, mandatory, _, _, _, _, _, _) -> {[],[]}; -comp_call_pre_post(noext, Prop, _, _, TextPos, OptTable, NumOptionals, Ext) -> +comp_call_pre_post(noext, Prop, _, Type, TextPos, + OptTable, NumOptionals, Ext) -> %% OPTIONAL or DEFAULT OptPos = get_optionality_pos(TextPos, OptTable), Element = case NumOptionals - OptPos of @@ -1225,7 +1261,7 @@ comp_call_pre_post(noext, Prop, _, _, TextPos, OptTable, NumOptionals, Ext) -> emit([";",nl, "0 ->",nl, "{"]), - gen_dec_component_no_val(Ext, Prop), + gen_dec_component_no_val(Ext, Type, Prop), emit([",",{curr,bytes},"}",nl, "end"]), St @@ -1247,10 +1283,10 @@ comp_call_pre_post({ext,_,_}, Prop, Pos, Type, _, _, _, Ext) -> components=ExtGroupCompList2}} when is_integer(Number2)-> emit("{extAddGroup,"), - gen_dec_extaddGroup_no_val(Ext, ExtGroupCompList2), + gen_dec_extaddGroup_no_val(Ext, Type, ExtGroupCompList2), emit("}"); _ -> - gen_dec_component_no_val(Ext, Prop) + gen_dec_component_no_val(Ext, Type, Prop) end, emit([",",{curr,bytes},"}",nl, "end"]), @@ -1265,21 +1301,22 @@ is_mandatory_predef_tab_c(_, _, {"got objfun through args","ObjFun"}) -> is_mandatory_predef_tab_c(_,_,_) -> true. -gen_dec_extaddGroup_no_val(Ext,[#'ComponentType'{prop=Prop}])-> - gen_dec_component_no_val(Ext,Prop), +gen_dec_extaddGroup_no_val(Ext, Type, [#'ComponentType'{prop=Prop}])-> + gen_dec_component_no_val(Ext, Type, Prop), ok; -gen_dec_extaddGroup_no_val(Ext,[#'ComponentType'{prop=Prop}|Rest])-> - gen_dec_component_no_val(Ext,Prop), - emit({","}), - gen_dec_extaddGroup_no_val(Ext,Rest); -gen_dec_extaddGroup_no_val(_, []) -> +gen_dec_extaddGroup_no_val(Ext, Type, [#'ComponentType'{prop=Prop}|Rest])-> + gen_dec_component_no_val(Ext, Type, Prop), + emit(","), + gen_dec_extaddGroup_no_val(Ext, Type, Rest); +gen_dec_extaddGroup_no_val(_, _, []) -> ok. -gen_dec_component_no_val(_,{'DEFAULT',DefVal}) -> +gen_dec_component_no_val(_, Type, {'DEFAULT',DefVal0}) -> + DefVal = asn1ct_gen:conform_value(Type, DefVal0), emit([{asis,DefVal}]); -gen_dec_component_no_val(_,'OPTIONAL') -> +gen_dec_component_no_val(_, _, 'OPTIONAL') -> emit({"asn1_NOVALUE"}); -gen_dec_component_no_val({ext,_,_},mandatory) -> +gen_dec_component_no_val({ext,_,_}, _, mandatory) -> emit({"asn1_NOVALUE"}). diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index 3452d29085..30d337635b 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -33,7 +33,9 @@ insert_once/2, ct_gen_module/1, index2suffix/1, - get_record_name_prefix/0]). + get_record_name_prefix/0, + conform_value/2, + named_bitstring_value/2]). -export([pgen/5, mk_var/1, un_hyphen_var/1]). @@ -1485,8 +1487,14 @@ gen_prim_check_call(PrimType, Default, Element, Type) -> end, check_call(check_int, [Default,Element,{asis,NNL}]); 'BIT STRING' -> - {_,NBL} = Type#type.def, - check_call(check_bitstring, [Default,Element,{asis,NBL}]); + case Type#type.def of + {_,[]} -> + check_call(check_bitstring, + [Default,Element]); + {_,[_|_]=NBL} -> + check_call(check_named_bitstring, + [Default,Element,{asis,NBL}]) + end; 'OCTET STRING' -> check_call(check_octetstring, [Default,Element]); 'NULL' -> @@ -1640,9 +1648,33 @@ unify_if_string(PrimType) -> Other -> Other end. - - - +conform_value(#type{def={'BIT STRING',[]}}, Bs) -> + case asn1ct:get_bit_string_format() of + compact when is_binary(Bs) -> + {0,Bs}; + compact when is_bitstring(Bs) -> + Sz = bit_size(Bs), + Unused = 8 - bit_size(Bs), + {Unused,<<Bs:Sz/bits,0:Unused>>}; + legacy -> + [B || <<B:1>> <= Bs]; + bitstring when is_bitstring(Bs) -> + Bs + end; +conform_value(_, Value) -> Value. + +named_bitstring_value(List, Names) -> + Int = lists:foldl(fun(N, A) -> + {N,Pos} = lists:keyfind(N, 1, Names), + A bor (1 bsl Pos) + end, 0, List), + named_bitstring_value_1(<<>>, Int). + +named_bitstring_value_1(Bs, 0) -> + Bs; +named_bitstring_value_1(Bs, Int) -> + B = Int band 1, + named_bitstring_value_1(<<Bs/bitstring,B:1>>, Int bsr 1). get_inner(A) when is_atom(A) -> A; get_inner(Ext) when is_record(Ext,'Externaltypereference') -> Ext; diff --git a/lib/asn1/src/asn1ct_imm.erl b/lib/asn1/src/asn1ct_imm.erl index 892178f61b..20785cda8c 100644 --- a/lib/asn1/src/asn1ct_imm.erl +++ b/lib/asn1/src/asn1ct_imm.erl @@ -319,14 +319,22 @@ per_enc_extensions(Val0, Pos0, NumBits, Aligned) when NumBits > 0 -> {'cond',[[{eq,Bitmap,0}], ['_'|Length ++ PutBits]],{var,"Extensions"}}]. -per_enc_optional(Val0, {Pos,Def}, _Aligned) when is_integer(Pos) -> +per_enc_optional(Val0, {Pos,DefVals}, _Aligned) when is_integer(Pos), + is_list(DefVals) -> Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), {B,[Val]} = mk_vars(Val1, []), Zero = {put_bits,0,1,[1]}, One = {put_bits,1,1,[1]}, - B++[{'cond',[[{eq,Val,asn1_DEFAULT},Zero], - [{eq,Val,Def},Zero], - ['_',One]]}]; + B++[{'cond', + [[{eq,Val,DefVal},Zero] || DefVal <- DefVals] ++ [['_',One]]}]; +per_enc_optional(Val0, {Pos,{call,M,F,A}}, _Aligned) when is_integer(Pos) -> + Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), + {B,[Val,Tmp]} = mk_vars(Val1, [tmp]), + Zero = {put_bits,0,1,[1]}, + One = {put_bits,1,1,[1]}, + B++[{call,M,F,[Val|A],Tmp}, + {'cond', + [[{eq,Tmp,true},Zero],['_',One]]}]; per_enc_optional(Val0, Pos, _Aligned) when is_integer(Pos) -> Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), {B,[Val]} = mk_vars(Val1, []), @@ -352,7 +360,12 @@ per_enc_sof(Val0, Constraint, ElementVar, ElementImm, Aligned) -> PreBlock ++ EncLen ++ Lc end. -enc_absent(Val0, AbsVals, Body) -> +enc_absent(Val0, {call,M,F,A}, Body) -> + {B,[Var,Tmp]} = mk_vars(Val0, [tmp]), + B++[{call,M,F,[Var|A],Tmp}, + {'cond', + [[{eq,Tmp,true}],['_'|Body]]}]; +enc_absent(Val0, AbsVals, Body) when is_list(AbsVals) -> {B,[Var]} = mk_vars(Val0, []), Cs = [[{eq,Var,Aval}] || Aval <- AbsVals] ++ [['_'|Body]], B++build_cond(Cs). @@ -994,6 +1007,25 @@ mk_var(Base, V) -> per_enc_integer_1(Val, [], Aligned) -> [{'cond',[['_'|per_enc_unconstrained(Val, Aligned)]]}]; +per_enc_integer_1(Val, [{{'SingleValue',[_|_]=Svs}=Constr,[]}], Aligned) -> + %% An extensible constraint such as (1|17, ...). + %% + %% A subtle detail is that the extension root as described in the + %% ASN.1 spec should be used to determine whether a particular value + %% belongs to the extension root (as opposed to the effective + %% constraint, which will be used for the actual encoding). + %% + %% So for the example above, only the integers 1 and 17 should be + %% encoded as root values (extension bit = 0). + + [{'ValueRange',{Lb,Ub}}] = effective_constraint(integer, [Constr]), + Root = [begin + {[],_,Put} = per_enc_constrained(Sv, Lb, Ub, Aligned), + [{eq,Val,Sv},{put_bits,0,1,[1]}|Put] + end || Sv <- Svs], + Cs = Root ++ [['_',{put_bits,1,1,[1]}| + per_enc_unconstrained(Val, Aligned)]], + build_cond(Cs); per_enc_integer_1(Val0, [{{_,_}=Constr,[]}], Aligned) -> {Prefix,Check,Action} = per_enc_integer_2(Val0, Constr, Aligned), Prefix++build_cond([[Check,{put_bits,0,1,[1]}|Action], @@ -1004,7 +1036,7 @@ per_enc_integer_1(Val0, [Constr], Aligned) -> Prefix++build_cond([[Check|Action], ['_',{error,Val0}]]). -per_enc_integer_2(Val, {'SingleValue',Sv}, Aligned) -> +per_enc_integer_2(Val, {'SingleValue',Sv}, Aligned) when is_integer(Sv) -> per_enc_constrained(Val, Sv, Sv, Aligned); per_enc_integer_2(Val0, {'ValueRange',{Lb,'MAX'}}, Aligned) when is_integer(Lb) -> diff --git a/lib/asn1/src/asn1ct_value.erl b/lib/asn1/src/asn1ct_value.erl index 992210232f..862b3c4ea5 100644 --- a/lib/asn1/src/asn1ct_value.erl +++ b/lib/asn1/src/asn1ct_value.erl @@ -167,17 +167,16 @@ from_type_prim(M, D) -> case D#type.def of 'INTEGER' -> i_random(C); - {'INTEGER',NamedNumberList} -> - NN = [X||{X,_} <- NamedNumberList], - case NN of + {'INTEGER',[_|_]=NNL} -> + case C of [] -> - i_random(C); + {N,_} = lists:nth(random(length(NNL)), NNL), + N; _ -> - case C of - [] -> - lists:nth(random(length(NN)),NN); - _ -> - lists:nth((fun(0)->1;(X)->X end(i_random(C))),NN) + V = i_random(C), + case lists:keyfind(V, 2, NNL) of + false -> V; + {N,V} -> N end end; Enum when is_tuple(Enum),element(1,Enum)=='ENUMERATED' -> diff --git a/lib/asn1/src/asn1rtt_check.erl b/lib/asn1/src/asn1rtt_check.erl index e78b65a8fb..be4f9c8bff 100644 --- a/lib/asn1/src/asn1rtt_check.erl +++ b/lib/asn1/src/asn1rtt_check.erl @@ -20,7 +20,7 @@ -export([check_bool/2, check_int/3, - check_bitstring/3, + check_bitstring/2,check_named_bitstring/3, check_octetstring/2, check_null/2, check_objectidentifier/2, @@ -50,31 +50,54 @@ check_int(DefValue, Value, NNL) when is_atom(Value) -> check_int(DefaultValue, _Value, _) -> throw({error,DefaultValue}). -%% Two equal lists or integers -check_bitstring(_, asn1_DEFAULT, _) -> +%% check_bitstring(Default, UserBitstring) -> true|false +%% Default = bitstring() +%% UserBitstring = integeger() | list(0|1) | {Unused,binary()} | bitstring() +check_bitstring(_, asn1_DEFAULT) -> true; -check_bitstring(V, V, _) -> - true; -%% Default value as a list of 1 and 0 and user value as an integer -check_bitstring(L=[H|T], Int, _) when is_integer(Int), is_integer(H) -> - case bit_list_to_int(L, length(T)) of - Int -> true; - _ -> throw({error,L,Int}) +check_bitstring(DefVal, {Unused,Binary}) -> + %% User value in compact format. + Sz = bit_size(Binary) - Unused, + <<Val:Sz/bitstring,_:Unused>> = Binary, + check_bitstring(DefVal, Val); +check_bitstring(DefVal, Val) when is_bitstring(Val) -> + case Val =:= DefVal of + false -> throw(error); + true -> true end; -%% Default value as an integer, val as list -check_bitstring(Int, Val, NBL) when is_integer(Int), is_list(Val) -> - BL = int_to_bit_list(Int, [], length(Val)), - check_bitstring(BL, Val, NBL); +check_bitstring(Def, Val) when is_list(Val) -> + check_bitstring_list(Def, Val); +check_bitstring(Def, Val) when is_integer(Val) -> + check_bitstring_integer(Def, Val). + +check_bitstring_list(<<H:1,T1/bitstring>>, [H|T2]) -> + check_bitstring_list(T1, T2); +check_bitstring_list(<<>>, []) -> + true; +check_bitstring_list(_, _) -> + throw(error). + +check_bitstring_integer(<<H:1,T1/bitstring>>, Int) when H =:= Int band 1 -> + check_bitstring_integer(T1, Int bsr 1); +check_bitstring_integer(<<>>, 0) -> + true; +check_bitstring_integer(_, _) -> + throw(error). + +check_named_bitstring(_, asn1_DEFAULT, _) -> + true; +check_named_bitstring(V, V, _) -> + true; %% Default value and user value as lists of ones and zeros -check_bitstring(L1=[H1|_T1], L2=[H2|_T2], NBL=[_H|_T]) when is_integer(H1), is_integer(H2) -> +check_named_bitstring(L1=[H1|_T1], L2=[H2|_T2], NBL=[_H|_T]) when is_integer(H1), is_integer(H2) -> L2new = remove_trailing_zeros(L2), - check_bitstring(L1, L2new, NBL); + check_named_bitstring(L1, L2new, NBL); %% Default value as a list of 1 and 0 and user value as a list of atoms -check_bitstring(L1=[H1|_T1], L2=[H2|_T2], NBL) when is_integer(H1), is_atom(H2) -> +check_named_bitstring(L1=[H1|_T1], L2=[H2|_T2], NBL) when is_integer(H1), is_atom(H2) -> L3 = bit_list_to_nbl(L1, NBL, 0, []), - check_bitstring(L3, L2, NBL); + check_named_bitstring(L3, L2, NBL); %% Both default value and user value as a list of atoms -check_bitstring(L1=[H1|T1], L2=[H2|_T2], _) +check_named_bitstring(L1=[H1|T1], L2=[H2|_T2], _) when is_atom(H1), is_atom(H2), length(L1) =:= length(L2) -> case lists:member(H1, L2) of true -> @@ -82,27 +105,29 @@ check_bitstring(L1=[H1|T1], L2=[H2|_T2], _) false -> throw({error,L2}) end; %% Default value as a list of atoms and user value as a list of 1 and 0 -check_bitstring(L1=[H1|_T1], L2=[H2|_T2], NBL) when is_atom(H1), is_integer(H2) -> +check_named_bitstring(L1=[H1|_T1], L2=[H2|_T2], NBL) when is_atom(H1), is_integer(H2) -> L3 = bit_list_to_nbl(L2, NBL, 0, []), - check_bitstring(L1, L3, NBL); + check_named_bitstring(L1, L3, NBL); %% User value in compact format -check_bitstring(DefVal,CBS={_,_}, NBL) -> +check_named_bitstring(DefVal,CBS={_,_}, NBL) -> NewVal = cbs_to_bit_list(CBS), - check_bitstring(DefVal, NewVal, NBL); -check_bitstring(DV, V, _) -> + check_named_bitstring(DefVal, NewVal, NBL); +%% User value as a binary +check_named_bitstring(DefVal, CBS, NBL) when is_binary(CBS) -> + NewVal = cbs_to_bit_list({0,CBS}), + check_named_bitstring(DefVal, NewVal, NBL); +%% User value as a bitstring +check_named_bitstring(DefVal, CBS, NBL) when is_bitstring(CBS) -> + BitSize = bit_size(CBS), + Unused = 8 - (BitSize band 7), + NewVal = cbs_to_bit_list({Unused,<<CBS:BitSize/bits,0:Unused>>}), + check_named_bitstring(DefVal, NewVal, NBL); +check_named_bitstring(DV, V, _) -> throw({error,DV,V}). - -bit_list_to_int([0|Bs], ShL)-> - bit_list_to_int(Bs, ShL-1) + 0; -bit_list_to_int([1|Bs], ShL) -> - bit_list_to_int(Bs, ShL-1) + (1 bsl ShL); -bit_list_to_int([], _) -> - 0. - int_to_bit_list(0, Acc, 0) -> Acc; -int_to_bit_list(Int, Acc, Len) -> +int_to_bit_list(Int, Acc, Len) when Len > 0 -> int_to_bit_list(Int bsr 1, [Int band 1|Acc], Len - 1). bit_list_to_nbl([0|T], NBL, Pos, Acc) -> diff --git a/lib/asn1/src/asn1rtt_per_common.erl b/lib/asn1/src/asn1rtt_per_common.erl index 9e9fd87ec3..3309e6a4ca 100644 --- a/lib/asn1/src/asn1rtt_per_common.erl +++ b/lib/asn1/src/asn1rtt_per_common.erl @@ -37,6 +37,7 @@ bitstring_from_positions/1,bitstring_from_positions/2, to_bitstring/1,to_bitstring/2, to_named_bitstring/1,to_named_bitstring/2, + is_default_bitstring/5, extension_bitmap/3]). -define('16K',16384). @@ -271,6 +272,36 @@ to_named_bitstring(Val, Lb) -> %% for correctness, not speed. adjust_trailing_zeroes(to_bitstring(Val), Lb). +is_default_bitstring(asn1_DEFAULT, _, _, _, _) -> + true; +is_default_bitstring({Unused,Bin}, V0, V1, V2, V3) when is_integer(Unused) -> + %% Convert compact bitstring to a bitstring. + Sz = bit_size(Bin) - Unused, + <<Bs:Sz/bitstring,_:Unused>> = Bin, + is_default_bitstring(Bs, V0, V1, V2, V3); +is_default_bitstring(Named, Named, _, _, _) -> + true; +is_default_bitstring(Bs, _, Bs, _, _) -> + true; +is_default_bitstring(List, _, _, List, _) -> + true; +is_default_bitstring(Int, _, _, _, Int) -> + true; +is_default_bitstring(Val, _, Def, _, _) when is_bitstring(Val) -> + Sz = bit_size(Def), + case Val of + <<Def:Sz/bitstring,T/bitstring>> -> + NumZeroes = bit_size(T), + case T of + <<0:NumZeroes>> -> true; + _ -> false + end; + _ -> + false + end; +is_default_bitstring(Val, _, _, List, _) when is_list(Val) -> + is_default_bitstring_list(List, Val); +is_default_bitstring(_, _, _, _, _) -> false. extension_bitmap(Val, Pos, Limit) -> extension_bitmap(Val, Pos, Limit, 0). @@ -447,6 +478,16 @@ ntz(Byte) -> 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0}, element(Byte+1, T). +is_default_bitstring_list([H|Def], [H|Val]) -> + is_default_bitstring_list(Def, Val); +is_default_bitstring_list([], []) -> + true; +is_default_bitstring_list([], [_|_]=Val) -> + lists:all(fun(0) -> true; + (_) -> false + end, Val); +is_default_bitstring_list(_, _) -> false. + extension_bitmap(_Val, Pos, Limit, Acc) when Pos >= Limit -> Acc; extension_bitmap(Val, Pos, Limit, Acc) -> diff --git a/lib/asn1/src/prepare_templates.erl b/lib/asn1/src/prepare_templates.erl index 83155b2e52..ccd15548d8 100644 --- a/lib/asn1/src/prepare_templates.erl +++ b/lib/asn1/src/prepare_templates.erl @@ -21,69 +21,77 @@ -export([gen_asn1ct_rtt/1,gen_asn1ct_eval/1]). gen_asn1ct_rtt(Ms) -> - io:format("%% Generated by ~s. DO NOT EDIT THIS FILE.\n" + {ok,Fd} = file:open("asn1ct_rtt.erl", [write]), + io:format(Fd, + "%% Generated by ~s. DO NOT EDIT THIS FILE.\n" "%%\n" "%% Input files:\n", [?MODULE]), - [io:put_chars(["%% ",M,$\n]) || M <- Ms], - io:nl(), - io:put_chars("-module(asn1ct_rtt).\n" + [io:put_chars(Fd, ["%% ",M,$\n]) || M <- Ms], + io:nl(Fd), + io:put_chars(Fd, + "-module(asn1ct_rtt).\n" "-export([assert_defined/1,dependencies/1,code/0]).\n" "\n"), Forms = lists:sort(lists:append([abstract(M) || M <- Ms])), Exp = lists:sort(exports(Forms)), - defined(Exp), - io:nl(), + defined(Fd, Exp), + io:nl(Fd), Calls = calls(Forms), R = sofs:relation(Calls), Fam0 = sofs:relation_to_family(R), Fam = sofs:to_external(Fam0), - dependencies(Fam), - io:nl(), + dependencies(Fd, Fam), + io:nl(Fd), Funcs = [begin Bin = list_to_binary([$\n|erl_pp:function(Func)]), {{M,F,A},Bin} end || {M,{function,_,F,A,_}=Func} <- Forms], - io:format("code() ->\n~p.\n\n", [Funcs]), + io:format(Fd, "code() ->\n~p.\n\n", [Funcs]), + ok = file:close(Fd), halt(0). gen_asn1ct_eval([File]) -> + Output = filename:rootname(File, ".funcs") ++ ".erl", + {ok,Fd} = file:open(Output, [write]), {ok,Funcs} = file:consult(File), asn1ct_func:start_link(), [asn1ct_func:need(MFA) || MFA <- Funcs], - io:format("%% Generated by ~s. DO NOT EDIT THIS FILE.\n" + io:format(Fd, + "%% Generated by ~s. DO NOT EDIT THIS FILE.\n" "%%\n" "%% Input file: ~s\n\n", [?MODULE,File]), - io:format("-module(~s).\n", [filename:rootname(File)]), - gen_asn1ct_eval_exp(Funcs), - asn1ct_func:generate(group_leader()), + io:format(Fd, "-module(~s).\n", [filename:rootname(File)]), + gen_asn1ct_eval_exp(Fd, Funcs), + asn1ct_func:generate(Fd), + ok = file:close(Fd), halt(0). -gen_asn1ct_eval_exp(Funcs) -> - io:put_chars("-export(["), - gen_asn1ct_eval_exp_1(Funcs, ""), - io:put_chars("]).\n"). +gen_asn1ct_eval_exp(Fd, Funcs) -> + io:put_chars(Fd, "-export(["), + gen_asn1ct_eval_exp_1(Fd, Funcs, ""), + io:put_chars(Fd, "]).\n"). -gen_asn1ct_eval_exp_1([{_,F,A}|T], Sep) -> - io:put_chars(Sep), - io:format("~p/~p", [F,A]), - gen_asn1ct_eval_exp_1(T, ",\n"); -gen_asn1ct_eval_exp_1([], _) -> ok. +gen_asn1ct_eval_exp_1(Fd, [{_,F,A}|T], Sep) -> + io:put_chars(Fd, Sep), + io:format(Fd, "~p/~p", [F,A]), + gen_asn1ct_eval_exp_1(Fd, T, ",\n"); +gen_asn1ct_eval_exp_1(_, [], _) -> ok. -defined([H|T]) -> - io:format("assert_defined(~p) -> ok", [H]), +defined(Fd, [H|T]) -> + io:format(Fd, "assert_defined(~p) -> ok", [H]), case T of [] -> - io:put_chars(".\n"); + io:put_chars(Fd, ".\n"); [_|_] -> - io:put_chars(";\n"), - defined(T) + io:put_chars(Fd, ";\n"), + defined(Fd, T) end. -dependencies([{K,V}|T]) -> - io:format("dependencies(~p) ->\n~p;\n", [K,V]), - dependencies(T); -dependencies([]) -> - io:put_chars("dependencies(_) -> [].\n"). +dependencies(Fd, [{K,V}|T]) -> + io:format(Fd, "dependencies(~p) ->\n~p;\n", [K,V]), + dependencies(Fd, T); +dependencies(Fd, []) -> + io:put_chars(Fd, "dependencies(_) -> [].\n"). abstract(File) -> {ok,{M0,[{abstract_code,Abstract}]}} = diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index 61b360ddf2..83bd66a631 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -96,7 +96,6 @@ groups() -> testChoTypeRefSeq, testChoTypeRefSet, testMultipleLevels, - testDef, testOpt, testSeqDefault, % Uses 'External' @@ -141,9 +140,9 @@ groups() -> testDeepTConstr, testExport, testImport, - % Uses 'ParamBasic' - {group, [], [testParamBasic, - testDER]}, + testParamBasic, + testDER, + testDEFAULT, testMvrasn6, testContextSwitchingTypes, testOpenTypeImplicitTag, @@ -326,20 +325,21 @@ testCompactBitString(Config, Rule, Opts) -> [Rule, compact_bit_string|Opts]), testCompactBitString:otp_4869(Rule). -testPrimStrings(Config) -> test(Config, fun testPrimStrings/3). +testPrimStrings(Config) -> + test(Config, fun testPrimStrings/3, [ber,{ber,[der]},per,uper]). testPrimStrings(Config, Rule, Opts) -> asn1_test_lib:compile_all(["PrimStrings", "BitStr"], Config, [Rule|Opts]), - testPrimStrings_cases(Rule), + testPrimStrings_cases(Rule, Opts), asn1_test_lib:compile_all(["PrimStrings", "BitStr"], Config, [legacy_bit_string,Rule|Opts]), - testPrimStrings:bit_string(Rule), + testPrimStrings:bit_string(Rule, Opts), asn1_test_lib:compile_all(["PrimStrings", "BitStr"], Config, [compact_bit_string,Rule|Opts]), - testPrimStrings:bit_string(Rule), + testPrimStrings:bit_string(Rule, Opts), testPrimStrings:more_strings(Rule). -testPrimStrings_cases(Rule) -> - testPrimStrings:bit_string(Rule), +testPrimStrings_cases(Rule, Opts) -> + testPrimStrings:bit_string(Rule, Opts), testPrimStrings:octet_string(Rule), testPrimStrings:numeric_string(Rule), testPrimStrings:other_strings(Rule), @@ -429,6 +429,13 @@ testDef(Config, Rule, Opts) -> asn1_test_lib:compile("Def", Config, [Rule|Opts]), testDef:main(Rule). +testDEFAULT(Config) -> + test(Config, fun testDEFAULT/3, [ber,{ber,[der]},per,uper]). +testDEFAULT(Config, Rule, Opts) -> + asn1_test_lib:compile_all(["Def","Default"], Config, [Rule|Opts]), + testDef:main(Rule), + testSeqSetDefaultVal:main(Rule, Opts). + testOpt(Config) -> test(Config, fun testOpt/3). testOpt(Config, Rule, Opts) -> asn1_test_lib:compile("Opt", Config, [Rule|Opts]), @@ -516,7 +523,8 @@ testSetDefault(Config, Rule, Opts) -> asn1_test_lib:compile("SetDefault", Config, [Rule|Opts]), testSetDefault:main(Rule). -testParamBasic(Config) -> test(Config, fun testParamBasic/3). +testParamBasic(Config) -> + test(Config, fun testParamBasic/3, [ber,{ber,[der]},per,uper]). testParamBasic(Config, Rule, Opts) -> asn1_test_lib:compile("ParamBasic", Config, [Rule|Opts]), testParamBasic:main(Rule). @@ -873,11 +881,7 @@ testDER(Config) -> test(Config, fun testDER/3, [ber]). testDER(Config, Rule, Opts) -> asn1_test_lib:compile("DERSpec", Config, [Rule, der|Opts]), - testDER:test(), - asn1_test_lib:compile("ParamBasic", Config, [Rule, der|Opts]), - testParamBasic:main(der), - asn1_test_lib:compile("Default", Config, [Rule, der|Opts]), - testSeqSetDefaultVal:main(Rule). + testDER:test(). specialized_decodes(Config) -> test(Config, fun specialized_decodes/3, [ber]). diff --git a/lib/asn1/test/asn1_SUITE_data/Constraints.py b/lib/asn1/test/asn1_SUITE_data/Constraints.py index e4bc987e4c..581ec2f467 100644 --- a/lib/asn1/test/asn1_SUITE_data/Constraints.py +++ b/lib/asn1/test/asn1_SUITE_data/Constraints.py @@ -17,6 +17,11 @@ NegSemiConstrained ::= INTEGER (-128..MAX) SemiConstrainedExt ::= INTEGER (42..MAX, ...) NegSemiConstrainedExt ::= INTEGER (-128..MAX, ...) +-- Union of single values +Sv1 ::= INTEGER (2|3|17) +Sv2 ::= INTEGER (2|3|17, ...) +Sv3 ::= INTEGER {a(2),b(3),z(17)} (2|3|17, ...) + -- Other constraints FixedSize ::= OCTET STRING (SIZE(10)) FixedSize2 ::= OCTET STRING (SIZE(10|20)) diff --git a/lib/asn1/test/asn1_SUITE_data/Default.asn b/lib/asn1/test/asn1_SUITE_data/Default.asn index 6604953c1f..168ce50bb2 100644 --- a/lib/asn1/test/asn1_SUITE_data/Default.asn +++ b/lib/asn1/test/asn1_SUITE_data/Default.asn @@ -21,7 +21,8 @@ SeqBS ::= SEQUENCE { a BIT STRING DEFAULT '1010110'B, b BIT STRING DEFAULT 'A8A'H, c BIT STRING {first(0),second(1),third(2)} DEFAULT {second}, - d BIT STRING DEFAULT onelist + d BIT STRING DEFAULT onelist, + e BIT STRING DEFAULT '01011010'B } SetBS ::= SET { diff --git a/lib/asn1/test/asn1_SUITE_data/PrimStrings.asn1 b/lib/asn1/test/asn1_SUITE_data/PrimStrings.asn1 index 08e7f94ab6..a5b4c8a53d 100644 --- a/lib/asn1/test/asn1_SUITE_data/PrimStrings.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/PrimStrings.asn1 @@ -46,7 +46,13 @@ BS256 ::= BIT STRING (SIZE (256)) BS1024 ::= BIT STRING (SIZE (1024)) - + BsDef1 ::= SEQUENCE { + s BIT STRING DEFAULT '101111'B + } + + BsDef2 ::= SEQUENCE { + s BIT STRING DEFAULT 'DEADBEEF'H + } Os ::= OCTET STRING OsCon ::= [60] OCTET STRING diff --git a/lib/asn1/test/testConstraints.erl b/lib/asn1/test/testConstraints.erl index 9a1d62993d..34fbbcf6cc 100644 --- a/lib/asn1/test/testConstraints.erl +++ b/lib/asn1/test/testConstraints.erl @@ -122,6 +122,42 @@ int_constraints(Rules) -> range_error(Rules, 'X1', 21), %%========================================================== + %% Union of single values + %% Sv1 ::= INTEGER (2|3|17) + %% Sv2 ::= INTEGER (2|3|17, ...) + %% Sv3 ::= INTEGER {a(2),b(3),z(17)} (2|3|17, ...) + %%========================================================== + + range_error(Rules, 'Sv1', 1), + range_error(Rules, 'Sv1', 18), + roundtrip('Sv1', 2), + roundtrip('Sv1', 3), + roundtrip('Sv1', 7), + + %% Encoded as root + v_roundtrip(Rules, 'Sv2', 2), + v_roundtrip(Rules, 'Sv2', 3), + v_roundtrip(Rules, 'Sv2', 17), + + %% Encoded as extension + v_roundtrip(Rules, 'Sv2', 1), + v_roundtrip(Rules, 'Sv2', 4), + v_roundtrip(Rules, 'Sv2', 18), + + %% Encoded as root + v_roundtrip(Rules, 'Sv3', a), + v_roundtrip(Rules, 'Sv3', b), + v_roundtrip(Rules, 'Sv3', z), + v_roundtrip(Rules, 'Sv3', 2, a), + v_roundtrip(Rules, 'Sv3', 3, b), + v_roundtrip(Rules, 'Sv3', 17, z), + + %% Encoded as extension + v_roundtrip(Rules, 'Sv3', 1), + v_roundtrip(Rules, 'Sv3', 4), + v_roundtrip(Rules, 'Sv3', 18), + + %%========================================================== %% SemiConstrained %%========================================================== @@ -197,7 +233,29 @@ v(per, 'SemiConstrainedExt', 42+128) -> "000180"; v(uper, 'SemiConstrainedExt', 42+128) -> "00C000"; v(ber, 'NegSemiConstrainedExt', 0) -> "020100"; v(per, 'NegSemiConstrainedExt', 0) -> "000180"; -v(uper, 'NegSemiConstrainedExt', 0) -> "00C000". +v(uper, 'NegSemiConstrainedExt', 0) -> "00C000"; +v(ber, 'Sv2', 1) -> "020101"; +v(per, 'Sv2', 1) -> "800101"; +v(uper, 'Sv2', 1) -> "808080"; +v(ber, 'Sv2', 2) -> "020102"; +v(per, 'Sv2', 2) -> "00"; +v(uper, 'Sv2', 2) -> "00"; +v(ber, 'Sv2', 3) -> "020103"; +v(per, 'Sv2', 3) -> "08"; +v(uper, 'Sv2', 3) -> "08"; +v(ber, 'Sv2', 4) -> "020104"; +v(per, 'Sv2', 4) -> "800104"; +v(uper, 'Sv2', 4) -> "808200"; +v(ber, 'Sv2', 17) -> "020111"; +v(per, 'Sv2', 17) -> "78"; +v(uper, 'Sv2', 17) -> "78"; +v(ber, 'Sv2', 18) -> "020112"; +v(per, 'Sv2', 18) -> "800112"; +v(uper, 'Sv2', 18) -> "808900"; +v(Rule, 'Sv3', a) -> v(Rule, 'Sv2', 2); +v(Rule, 'Sv3', b) -> v(Rule, 'Sv2', 3); +v(Rule, 'Sv3', z) -> v(Rule, 'Sv2', 17); +v(Rule, 'Sv3', Val) when is_integer(Val) -> v(Rule, 'Sv2', Val). shorter_ext(per, "a") -> <<16#80,16#01,16#61>>; shorter_ext(uper, "a") -> <<16#80,16#E1>>; @@ -211,6 +269,10 @@ v_roundtrip(Erule, Type, Value) -> Encoded = asn1_test_lib:hex_to_bin(v(Erule, Type, Value)), Encoded = roundtrip('Constraints', Type, Value). +v_roundtrip(Erule, Type, Value, Expected) -> + Encoded = asn1_test_lib:hex_to_bin(v(Erule, Type, Value)), + Encoded = asn1_test_lib:roundtrip_enc('Constraints', Type, Value, Expected). + roundtrip(Type, Value) -> roundtrip('Constraints', Type, Value). diff --git a/lib/asn1/test/testParamBasic.erl b/lib/asn1/test/testParamBasic.erl index 3a55408e94..3db89ca174 100644 --- a/lib/asn1/test/testParamBasic.erl +++ b/lib/asn1/test/testParamBasic.erl @@ -38,7 +38,9 @@ main(Rules) -> <<48,3,128,1,11>> = roundtrip_enc('T11', #'T11'{number=11,string="hej"}), <<48,3,128,1,11>> = - roundtrip_enc('T12', #'T12'{number=11,string=[1,0,1,0]}); + roundtrip_enc('T12', + #'T12'{number=11,string=[1,0,1,0]}, + #'T12'{number=11,string = <<10:4>>}); _ -> ok end, ok. @@ -48,3 +50,6 @@ roundtrip(Type, Value) -> roundtrip_enc(Type, Value) -> asn1_test_lib:roundtrip_enc('ParamBasic', Type, Value). + +roundtrip_enc(Type, Value, Expected) -> + asn1_test_lib:roundtrip_enc('ParamBasic', Type, Value, Expected). diff --git a/lib/asn1/test/testPrimStrings.erl b/lib/asn1/test/testPrimStrings.erl index be5409aa92..2fe0780701 100644 --- a/lib/asn1/test/testPrimStrings.erl +++ b/lib/asn1/test/testPrimStrings.erl @@ -19,7 +19,7 @@ %% -module(testPrimStrings). --export([bit_string/1]). +-export([bit_string/2]). -export([octet_string/1]). -export([numeric_string/1]). -export([other_strings/1]). @@ -68,7 +68,7 @@ fragmented_lengths() -> K64-1,K64,K64+1,K64+(1 bsl 7)-1,K64+(1 bsl 7),K64+(1 bsl 7)+1, K64+K16-1,K64+K16,K64+K16+1]. -bit_string(Rules) -> +bit_string(Rules, Opts) -> %%========================================================== %% Bs1 ::= BIT STRING @@ -90,9 +90,10 @@ bit_string(Rules) -> bs_roundtrip('Bs1', [0,1,0,0,1,0]), bs_roundtrip('Bs1', [1,0,0,0,0,0,0,0,0]), bs_roundtrip('Bs1', [0,1,0,0,1,0,1,1,1,1,1,0,0,0,1,0,0,1,1]), - - case Rules of - ber -> + + + case {Rules,Opts} of + {ber,[]} -> bs_decode('Bs1', <<35,8,3,2,0,73,3,2,4,32>>, [0,1,0,0,1,0,0,1,0,0,1,0]), bs_decode('Bs1', <<35,9,3,2,0,234,3,3,7,156,0>>, @@ -100,7 +101,17 @@ bit_string(Rules) -> bs_decode('Bs1', <<35,128,3,2,0,234,3,3,7,156,0,0,0>>, [1,1,1,0,1,0,1,0,1,0,0,1,1,1,0,0,0]); _ -> - ok + %% DER, PER, UPER + consistent_def_enc('BsDef1', + [2#111101, + [1,0,1,1,1,1], + {2,<<2#101111:6,0:2>>}, + <<2#101111:6>>]), + consistent_def_enc('BsDef2', + [[1,1,0,1, 1,1,1,0, 1,0,1,0, 1,1,0,1, + 1,0,1,1, 1,1,1,0, 1,1,1,0, 1,1,1,1], + {0,<<16#DEADBEEF:4/unit:8>>}, + <<16#DEADBEEF:4/unit:8>>]) end, @@ -217,6 +228,24 @@ bit_string(Rules) -> _ -> per_bs_strings() end. +consistent_def_enc(Type, Vs) -> + M = 'PrimStrings', + {ok,Enc} = M:encode(Type, {Type,asn1_DEFAULT}), + {ok,Val} = M:decode(Type, Enc), + + %% Ensure that the value has the correct format. + case {M:bit_string_format(),Val} of + {bitstring,{_,Bs}} when is_bitstring(Bs) -> ok; + {compact,{_,{Unused,Bin}}} when is_integer(Unused), + is_binary(Bin) -> ok; + {legacy,{_,Bs}} when is_list(Bs) -> ok + end, + + %% All values should be recognized and encoded as the + %% the default value (i.e. not encoded at all). + _ = [{ok,Enc} = M:encode(Type, {Type,V}) || V <- Vs], + ok. + %% The PER encoding rules requires that a BIT STRING with %% named positions should never have any trailing zeroes %% (except to reach the minimum number of bits as given by diff --git a/lib/asn1/test/testSeqSetDefaultVal.erl b/lib/asn1/test/testSeqSetDefaultVal.erl index fb61bf1647..044099199f 100644 --- a/lib/asn1/test/testSeqSetDefaultVal.erl +++ b/lib/asn1/test/testSeqSetDefaultVal.erl @@ -18,7 +18,7 @@ %% %% -module(testSeqSetDefaultVal). --export([main/1]). +-export([main/2]). -include("External.hrl"). -include_lib("test_server/include/test_server.hrl"). @@ -34,7 +34,8 @@ -record('SeqBS',{a = asn1_DEFAULT, b = asn1_DEFAULT, c = asn1_DEFAULT, - d = asn1_DEFAULT}). + d = asn1_DEFAULT, + e = asn1_DEFAULT}). -record('SetBS',{a = asn1_DEFAULT, b = asn1_DEFAULT, c = asn1_DEFAULT, @@ -93,7 +94,119 @@ -record('S4_b',{ba = asn1_DEFAULT, bb = asn1_DEFAULT}). -main(_Rules) -> +main(ber, []) -> + %% Nothing to test because plain BER will only use + %% default values when explicitly told to do so by + %% asn1_DEFAULT. + ok; +main(Rule, Opts) -> + %% DER, PER, UPER. These encodings should not encode + %% values that are equal to the default value. + + case {Rule,Opts} of + {ber,[der]} -> + der(); + {_,_} -> + ok + end, + + Ts = [{#'SeqInts'{}, + [{#'SeqInts'.c, + [asn1_DEFAULT, + three, + 3]}]}, + + {#'SeqBS'{}, + [{#'SeqBS'.a, + [asn1_DEFAULT, + 2#0110101, + [1,0,1,0,1,1,0], + {1,<<16#AC>>}, + <<1:1,0:1,1:1,0:1,1:1,1:1,0:1>>]}, + {#'SeqBS'.b, + [asn1_DEFAULT, + 2#10100010101, + [1,0,1,0,1,0,0,0,1,0,1,0], + {4,<<16#A8,16#A0>>}, + <<16#A8:8,16#A:4>>]}, + {#'SeqBS'.c, + [asn1_DEFAULT, + [second], + [0,1], + {6,<<0:1,1:1,0:6>>}, + <<1:2>>]}, + {#'SeqBS'.c, %Zeroes on the right + [asn1_DEFAULT, + [second], + [0,1,0,0,0], + {4,<<0:1,1:1,0:6>>}, + <<1:2,0:17>>]}, + {#'SeqBS'.d, + [asn1_DEFAULT, + 2#1001, + [1,0,0,1], + {4,<<2#1001:4,0:4>>}, + <<2#1001:4>>]}, + {#'SeqBS'.e, + [asn1_DEFAULT, + [0,1,0,1,1,0,1,0], + {0,<<2#01011010:8>>}, + <<2#01011010:8>>]}, + %% Not EQUAL to DEFAULT. + {#'SeqBS'.b, + [[1,1,0], %Not equal to DEFAULT + {5,<<6:3,0:5>>}, + <<6:3>>]} + ]}, + + {#'SeqOS'{}, + [{#'SeqOS'.a, + [asn1_DEFAULT, + [172]]}]}, + + {#'SeqOI'{}, + [{#'SeqOI'.a, + [asn1_DEFAULT, + {1,2,14,15}]}, + {#'SeqOI'.b, + [asn1_DEFAULT, +%% {iso,'member-body',250,3,4}, + {1,2,250,3,4}]}, + {#'SeqOI'.c, + [asn1_DEFAULT, +%% {iso,standard,8571,2,250,4}, + {1,0,8571,2,250,4}]}]} + ], + io:format("~p\n", [Ts]), + R0 = [[consistency(Rec, Pos, Vs) || {Pos,Vs} <- Fs] || {Rec,Fs} <- Ts], + case lists:flatten(R0) of + [] -> + ok; + [_|_]=R -> + io:format("~p\n", [R]), + ?t:fail() + end. + +consistency(Rec0, Pos, [V|Vs]) -> + T = element(1, Rec0), + Rec = setelement(Pos, Rec0, V), + {ok,Enc} = 'Default':encode(T, Rec), + {ok,_SmokeTest} = 'Default':decode(T, Enc), + consistency_1(Vs, Rec0, Pos, Enc). + +consistency_1([V|Vs], Rec0, Pos, Enc) -> + Rec = setelement(Pos, Rec0, V), + case 'Default':encode(element(1, Rec), Rec) of + {ok,Enc} -> + consistency_1(Vs, Rec0, Pos, Enc); + {ok,WrongEnc} -> + [{Rec,{wrong,WrongEnc},{should_be,Enc}}| + consistency_1(Vs, Rec0, Pos, Enc)] + end; +consistency_1([], _, _, _) -> []. + +der() -> + io:put_chars("Peforming DER-specific tests..."), roundtrip(<<48,0>>, 'SeqInts', #'SeqInts'{a=asn1_DEFAULT,b=asn1_DEFAULT, @@ -117,50 +230,88 @@ main(_Rules) -> roundtrip(<<48,0>>, 'SeqBS', - #'SeqBS'{a=2#1010110,b=16#A8A,c=[second],d=[1,0,0,1]}, - #'SeqBS'{a=[1,0,1,0,1,1,0],b=16#A8A,c=[second],d=[1,0,0,1]}), + #'SeqBS'{a=2#0110101, + b=2#010100010101, + c=[second], + d=[1,0,0,1]}, + #'SeqBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<2#1001:4>>, + e = <<2#01011010:8>>}), roundtrip(<<48,0>>, 'SeqBS', #'SeqBS'{a=[1,0,1,0,1,1,0], b=[1,0,1,0,1,0,0,0,1,0,1,0], c={5,<<64>>}, d=2#1001}, - #'SeqBS'{a=[1,0,1,0,1,1,0],b=16#A8A,c=[second],d=[1,0,0,1]}), + #'SeqBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<2#1001:4>>, + e = <<2#01011010:8>>}), roundtrip(<<48,3,131,1,0>>, 'SeqBS', #'SeqBS'{a=[1,0,1,0,1,1,0], b=[1,0,1,0,1,0,0,0,1,0,1,0], c={5,<<64>>}, d=0}, - #'SeqBS'{a=[1,0,1,0,1,1,0], - b=16#A8A, - c=[second], - d = <<>>}), + #'SeqBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<>>, + e = <<2#01011010:8>>}), + roundtrip(<<48,3,131,1,0>>, + 'SeqBS', + #'SeqBS'{a = <<1:1,0:1,1:1,0:1,1:1,1:1,0:1>>, + b = <<1:1,0:1,1:1,0:1,1:1,0:1,0:1,0:1,1:1,0:1,1:1,0:1>>, + c = <<2:3>>, + d=0, + e = <<16#5A:8>>}, + #'SeqBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<>>, + e = <<2#01011010:8>>}), + + %% None of the default values are used. + roundtrip(<<48,19,128,2,7,128,129,2,5,64,130,2,5,32,131,1,0,132,2,5,224>>, + 'SeqBS', + #'SeqBS'{a = <<1:1>>, + b = {5,<<64>>}, + c = [third], + d = 0, + e = <<7:3>>}, + #'SeqBS'{a = <<1:1>>, + b = <<2:3>>, + c = [third], + d = <<>>, + e = <<7:3>>}), roundtrip(<<49,0>>, 'SetBS', - #'SetBS'{a=2#1010110,b=16#A8A,c=[second],d=[1,0,0,1]}, - #'SetBS'{a=[1,0,1,0,1,1,0],b=16#A8A,c=[second],d=[1,0,0,1]}), + #'SetBS'{a=2#0110101, + b=2#010100010101, + c=[second], + d=[1,0,0,1]}, + #'SetBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<2#1001:4>>}), roundtrip(<<49,0>>, 'SetBS', #'SetBS'{a=[1,0,1,0,1,1,0], b=[1,0,1,0,1,0,0,0,1,0,1,0], c={5,<<64>>}, d=9}, - #'SetBS'{a=[1,0,1,0,1,1,0], - b=16#A8A, - c=[second], - d=[1,0,0,1]}), + #'SetBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<2#1001:4>>}), roundtrip(<<49,3,131,1,0>>, 'SetBS', #'SetBS'{a=[1,0,1,0,1,1,0], b=[1,0,1,0,1,0,0,0,1,0,1,0], c={5,<<64>>}, d=0}, - #'SetBS'{a=[1,0,1,0,1,1,0], - b=16#A8A, - c=[second], - d = <<>>}), + #'SetBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<>>}), + roundtrip(<<49,3,131,1,0>>, + 'SetBS', + #'SetBS'{a = <<1:1,0:1,1:1,0:1,1:1,1:1,0:1>>, + b = <<1:1,0:1,1:1,0:1,1:1,0:1,0:1,0:1,1:1,0:1,1:1,0:1>>, + c = <<2:3>>, + d=0}, + #'SetBS'{a = <<2#1010110:7>>, b = <<16#A8A:12>>, + c=[second], d = <<>>}), roundtrip(<<48,0>>, 'SeqOS', #'SeqOS'{a=[172],b=[16#A8,16#A0],c='NULL'}), diff --git a/lib/common_test/src/cth_log_redirect.erl b/lib/common_test/src/cth_log_redirect.erl index 4ee7e48a67..8fed341600 100644 --- a/lib/common_test/src/cth_log_redirect.erl +++ b/lib/common_test/src/cth_log_redirect.erl @@ -34,13 +34,15 @@ %% Event handler Callbacks -export([init/1, handle_event/2, handle_call/2, handle_info/2, - terminate/1]). + terminate/1, terminate/2, code_change/3]). %% Other -export([handle_remote_events/1]). -include("ct.hrl"). +-behaviour(gen_event). + -record(eh_state, {log_func, curr_suite, curr_group, @@ -184,10 +186,13 @@ handle_call({handle_remote_events,Bool}, State) -> handle_call(_Query, _State) -> {error, bad_query}. -terminate(_State) -> +terminate(_) -> error_logger:delete_report_handler(?MODULE), []. +terminate(_Arg, _State) -> + ok. + tag_event(Event) -> {calendar:local_time(), Event}. @@ -236,3 +241,6 @@ format_header(#eh_state{curr_suite = Suite, curr_func = TC}) -> io_lib:format("System report during ~w:~w/1 in ~w", [Suite,TC,Group]). + +code_change(_OldVsn, State, _Extra) -> + {ok, State}. diff --git a/lib/common_test/test/common_test.cover b/lib/common_test/test/common_test.cover index 3aa49623e7..87d00c420f 100644 --- a/lib/common_test/test/common_test.cover +++ b/lib/common_test/test/common_test.cover @@ -4,7 +4,6 @@ test_server, test_server_ctrl, test_server_gl, - test_server_h, test_server_io, test_server_node, test_server_sup]}]}. diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl index 84341a0b99..5de1ecc2bd 100644 --- a/lib/common_test/test/ct_pre_post_test_io_SUITE.erl +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl @@ -89,28 +89,31 @@ pre_post_io(Config) -> %%!-------------------------------------------------------------------- spawn(fun() -> + ct:pal("CONTROLLER: Started!", []), %% --- test run 1 --- - ct:sleep(3000), - ct_test_support:ct_rpc({cth_log_redirect, - handle_remote_events, - [true]}, Config), - ct:sleep(2000), - io:format(user, "Starting test run!~n", []), - ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), - ct:sleep(6000), - io:format(user, "Finishing off!~n", []), - ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + timer:sleep(3000), + ct:pal("CONTROLLER: Handle remote events = true", []), + ok = ct_test_support:ct_rpc({cth_log_redirect, + handle_remote_events, + [true]}, Config), + timer:sleep(2000), + ct:pal("CONTROLLER: Proceeding with test run #1!", []), + ok = ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + timer:sleep(6000), + ct:pal("CONTROLLER: Proceeding with shutdown #1!", []), + ok = ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), %% --- test run 2 --- - ct:sleep(3000), - ct_test_support:ct_rpc({cth_log_redirect, - handle_remote_events, - [true]}, Config), - ct:sleep(2000), - io:format(user, "Starting test run!~n", []), - ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), - ct:sleep(6000), - io:format(user, "Finishing off!~n", []), - ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config) + timer:sleep(3000), + ct:pal("CONTROLLER: Handle remote events = true", []), + ok = ct_test_support:ct_rpc({cth_log_redirect, + handle_remote_events, + [true]}, Config), + timer:sleep(2000), + ct:pal("CONTROLLER: Proceeding with test run #2!", []), + ok = ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + timer:sleep(6000), + ct:pal("CONTROLLER: Proceeding with shutdown #2!", []), + ok = ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config) end), ct_test_support:run(Opts, Config), Events = ct_test_support:get_events(ERPid, Config), diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl index c8c08a5735..2ba991fc61 100644 --- a/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl @@ -28,7 +28,8 @@ %%%=================================================================== proceed() -> - ?MODULE ! proceed. + ?MODULE ! proceed, + ok. %%-------------------------------------------------------------------- %% Hook functions diff --git a/lib/compiler/src/beam_clean.erl b/lib/compiler/src/beam_clean.erl index e208ffec1f..9d89e21a4e 100644 --- a/lib/compiler/src/beam_clean.erl +++ b/lib/compiler/src/beam_clean.erl @@ -86,7 +86,7 @@ add_to_work_list(F, {Fs,Used}=Sets) -> false -> {[F|Fs],sets:add_element(F, Used)} end. - + %%% %%% Coalesce adjacent labels. Renumber all labels to eliminate gaps. %%% This cleanup will slightly reduce file size and slightly speed up loading. diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl index 3b51216a6c..3ec57a67da 100644 --- a/lib/compiler/src/beam_type.erl +++ b/lib/compiler/src/beam_type.erl @@ -600,7 +600,7 @@ checkerror_1([], OrigIs) -> OrigIs. checkerror_2(OrigIs) -> [{set,[],[],fcheckerror}|OrigIs]. - + %%% Routines for maintaining a type database. The type database %%% associates type information with registers. %%% diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index 70279ab658..48f5135aca 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -530,7 +530,7 @@ valfun_2(I, #vst{current=#st{ct=[[Fail]|_]}}=Vst) when is_integer(Fail) -> %% Update branched state valfun_3(I, branch_state(Fail, Vst)); valfun_2(_, _) -> - error(ambigous_catch_try_state). + error(ambiguous_catch_try_state). %% Handle the remaining floating point instructions here. %% Floating point. diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 802e3dfa2f..47d446273b 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -1556,7 +1556,7 @@ restore_expand_module([F|Fs]) -> [F|restore_expand_module(Fs)]; restore_expand_module([]) -> []. - + -spec options() -> 'ok'. options() -> @@ -1593,7 +1593,7 @@ help([_|T]) -> help(_) -> ok. - + %% compile(AbsFileName, Outfilename, Options) %% Compile entry point for erl_compile. diff --git a/lib/compiler/src/core_scan.erl b/lib/compiler/src/core_scan.erl index 0ca2f57dde..c0dfecd1dc 100644 --- a/lib/compiler/src/core_scan.erl +++ b/lib/compiler/src/core_scan.erl @@ -96,7 +96,7 @@ format_error(Other) -> io_lib:write(Other). string_thing($') -> "atom"; %' stupid emacs string_thing($") -> "string". %" stupid emacs - + %% Re-entrant pre-scanner. %% %% If the input list of characters is insufficient to build a term the @@ -214,7 +214,7 @@ pre_comment(eof, Sofar, Pos) -> pre_error(E, Epos, Pos) -> {error,{Epos,core_scan,E}, Pos}. - + %% scan(CharList, StartPos) %% This takes a list of characters and tries to tokenise them. %% diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index 1195937d91..01bb8635cd 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -1912,7 +1912,7 @@ new_in_all([Le|Les]) -> foldl(fun (L, Ns) -> intersection((get_anno(L))#a.ns, Ns) end, (get_anno(Le))#a.ns, Les); new_in_all([]) -> []. - + %% The AfterVars are the variables which are used afterwards. We need %% this to work out which variables are actually exported and used %% from case/receive. In subblocks/clauses the AfterVars of the block diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl index 2b2b8bf550..65f1251099 100644 --- a/lib/compiler/src/v3_kernel.erl +++ b/lib/compiler/src/v3_kernel.erl @@ -160,8 +160,8 @@ function({#c_var{name={F,Arity}=FA},Body}, St0) -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end. - - + + %% body(Cexpr, Sub, State) -> {Kexpr,[PreKepxr],State}. %% Do the main sequence of a body. A body ends in an atomic value or %% values. Must check if vector first so do expr. @@ -834,7 +834,7 @@ last([_|T]) -> last(T). first([_]) -> []; first([H|T]) -> [H|first(T)]. - + %% This code implements the algorithm for an optimizing compiler for %% pattern matching given "The Implementation of Functional %% Programming Languages" by Simon Peyton Jones. The code is much @@ -1428,7 +1428,7 @@ arg_val(Arg, C) -> {set_kanno(S, []),U,T,Fs} end end. - + %% ubody_used_vars(Expr, State) -> [UsedVar] %% Return all used variables for the body sequence. Much more %% efficient than using ubody/3 if the body contains nested letrecs. diff --git a/lib/debugger/test/dbg_ui_SUITE_data/manual_data/src/lists1.erl b/lib/debugger/test/dbg_ui_SUITE_data/manual_data/src/lists1.erl index 0214983c11..db84ee5fc8 100644 --- a/lib/debugger/test/dbg_ui_SUITE_data/manual_data/src/lists1.erl +++ b/lib/debugger/test/dbg_ui_SUITE_data/manual_data/src/lists1.erl @@ -236,7 +236,7 @@ flatlength([H|T], L) when list(H) -> flatlength([H|T], L) -> flatlength(T, L + 1); flatlength([], L) -> L. - + %% keymember(Key, Index, [Tuple]) %% keysearch(Key, Index, [Tuple]) %% keydelete(Key, Index, [Tuple]) @@ -298,7 +298,7 @@ keymap(Fun, ExtraArgs, Index, [Tup|Tail]) -> [setelement(Index, Tup, apply(Fun, [element(Index, Tup)|ExtraArgs]))| keymap(Fun, ExtraArgs, Index, Tail)]; keymap( _, _ , _, []) -> []. - + %% all(Predicate, List) %% any(Predicate, List) %% map(Function, List) diff --git a/lib/debugger/test/int_SUITE_data/lists1.erl b/lib/debugger/test/int_SUITE_data/lists1.erl index 0214983c11..db84ee5fc8 100644 --- a/lib/debugger/test/int_SUITE_data/lists1.erl +++ b/lib/debugger/test/int_SUITE_data/lists1.erl @@ -236,7 +236,7 @@ flatlength([H|T], L) when list(H) -> flatlength([H|T], L) -> flatlength(T, L + 1); flatlength([], L) -> L. - + %% keymember(Key, Index, [Tuple]) %% keysearch(Key, Index, [Tuple]) %% keydelete(Key, Index, [Tuple]) @@ -298,7 +298,7 @@ keymap(Fun, ExtraArgs, Index, [Tup|Tail]) -> [setelement(Index, Tup, apply(Fun, [element(Index, Tup)|ExtraArgs]))| keymap(Fun, ExtraArgs, Index, Tail)]; keymap( _, _ , _, []) -> []. - + %% all(Predicate, List) %% any(Predicate, List) %% map(Function, List) diff --git a/lib/debugger/test/int_SUITE_data/my_lists.erl b/lib/debugger/test/int_SUITE_data/my_lists.erl index 98eb4396e3..f9399b1085 100644 --- a/lib/debugger/test/int_SUITE_data/my_lists.erl +++ b/lib/debugger/test/int_SUITE_data/my_lists.erl @@ -237,7 +237,7 @@ flatlength([H|T], L) when list(H) -> flatlength([H|T], L) -> flatlength(T, L + 1); flatlength([], L) -> L. - + %% keymember(Key, Index, [Tuple]) %% keysearch(Key, Index, [Tuple]) %% keydelete(Key, Index, [Tuple]) @@ -299,7 +299,7 @@ keymap(Fun, ExtraArgs, Index, [Tup|Tail]) -> [setelement(Index, Tup, apply(Fun, [element(Index, Tup)|ExtraArgs]))| keymap(Fun, ExtraArgs, Index, Tail)]; keymap( _, _ , _, []) -> []. - + %% all(Predicate, List) %% any(Predicate, List) %% map(Function, List) @@ -698,7 +698,7 @@ flatlength_1([H|T], L) when list(H) -> flatlength_1([H|T], L) -> flatlength_1(T, L + 1); flatlength_1([], L) -> L. - + %% keymember(Key, Index, [Tuple]) %% keysearch(Key, Index, [Tuple]) %% keydelete(Key, Index, [Tuple]) @@ -760,7 +760,7 @@ keymap_1(Fun, ExtraArgs, Index, [Tup|Tail]) -> [setelement(Index, Tup, apply(Fun, [element(Index, Tup)|ExtraArgs]))| keymap_1(Fun, ExtraArgs, Index, Tail)]; keymap_1( _, _ , _, []) -> []. - + %% all(Predicate, List) %% any(Predicate, List) %% map(Function, List) @@ -1162,7 +1162,7 @@ flatlength_2([H|T], L) when list(H) -> flatlength_2([H|T], L) -> flatlength_2(T, L + 1); flatlength_2([], L) -> L. - + %% keymember_2(Key, Index, [Tuple]) %% keysearch_2(Key, Index, [Tuple]) %% keydelete_2(Key, Index, [Tuple]) @@ -1224,7 +1224,7 @@ keymap_2(Fun, ExtraArgs, Index, [Tup|Tail]) -> [setelement(Index, Tup, apply(Fun, [element(Index, Tup)|ExtraArgs]))| keymap_2(Fun, ExtraArgs, Index, Tail)]; keymap_2( _, _ , _, []) -> []. - + %% all_2(Predicate, List) %% any_2(Predicate, List) %% map_2(Function, List) @@ -1624,7 +1624,7 @@ flatlength_3([H|T], L) when list(H) -> flatlength_3([H|T], L) -> flatlength_3(T, L + 1); flatlength_3([], L) -> L. - + %% keymember_3(Key, Index, [Tuple]) %% keysearch_3(Key, Index, [Tuple]) %% keydelete_3(Key, Index, [Tuple]) @@ -1686,7 +1686,7 @@ keymap_3(Fun, ExtraArgs, Index, [Tup|Tail]) -> [setelement(Index, Tup, apply(Fun, [element(Index, Tup)|ExtraArgs]))| keymap_3(Fun, ExtraArgs, Index, Tail)]; keymap_3( _, _ , _, []) -> []. - + %% all_3(Predicate, List) %% any_3(Predicate, List) %% map_3(Function, List) diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_clean.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_clean.erl index 04225e9bd0..4fc4e89ce9 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_clean.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_clean.erl @@ -80,7 +80,7 @@ add_to_work_list(F, {Fs,Used}=Sets) -> false -> {[F|Fs],sets:add_element(F, Used)} end. - + %%% %%% Coalesce adjacent labels. Renumber all labels to eliminate gaps. %%% This cleanup will slightly reduce file size and slightly speed up loading. diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_type.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_type.erl index d2ac3fcd99..f59cc897d6 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_type.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_type.erl @@ -456,7 +456,7 @@ are_live_regs_determinable([{'%live',_}|_]) -> true; are_live_regs_determinable([_|Is]) -> are_live_regs_determinable(Is); are_live_regs_determinable([]) -> false. - + %%% Routines for maintaining a type database. The type database %%% associates type information with registers. %%% diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/compile.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/compile.erl index 2b6d14e300..9b56d384ab 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/compile.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/compile.erl @@ -990,7 +990,7 @@ listing(LFun, Ext, St) -> Es = [{Lfile,[{none,compile,write_error}]}], {error,St#compile{errors=St#compile.errors ++ Es}} end. - + options() -> help(standard_passes()). @@ -1022,7 +1022,7 @@ help([_|T]) -> help(_) -> ok. - + %% compile(AbsFileName, Outfilename, Options) %% Compile entry point for erl_compile. diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/core_scan.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/core_scan.erl index f4e609bf5b..879af3efea 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/core_scan.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/core_scan.erl @@ -123,7 +123,7 @@ format_error(Other) -> io_lib:write(Other). string_thing($') -> "atom"; string_thing($") -> "string". - + %% Re-entrant pre-scanner. %% %% If the input list of characters is insufficient to build a term the @@ -241,7 +241,7 @@ pre_comment(eof, Sofar, Pos) -> pre_error(E, Epos, Pos) -> {error,{Epos,core_scan,E}, Pos}. - + %% scan(CharList, StartPos) %% This takes a list of characters and tries to tokenise them. %% diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl index 41b7cb248d..590cc682c9 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_pre_expand.erl @@ -647,7 +647,7 @@ new_fun_name(#expand{func=F,arity=A,fcount=I}=St) -> ++ "-fun-" ++ integer_to_list(I) ++ "-", {list_to_atom(Name),St#expand{fcount=I+1}}. - + %% normalise_fields([RecDef]) -> [Field]. %% Normalise the field definitions to always have a default value. If %% none has been given then use 'undefined'. @@ -881,7 +881,7 @@ bin_expand_strings(Es) -> end, Es1, S); (E, Es1) -> [E|Es1] end, [], Es). - + %% new_var_name(State) -> {VarName,State}. new_var_name(St) -> diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_core.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_core.erl index c96837ab5e..45a8bc4ad9 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_core.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_core.erl @@ -1127,7 +1127,7 @@ new_in_all([Le|Les]) -> foldl(fun (L, Ns) -> intersection((core_lib:get_anno(L))#a.ns, Ns) end, (core_lib:get_anno(Le))#a.ns, Les); new_in_all([]) -> []. - + %% The AfterVars are the variables which are used afterwards. We need %% this to work out which variables are actually exported and used %% from case/receive. In subblocks/clauses the AfterVars of the block diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_kernel.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_kernel.erl index d7c3e1add9..ecba19b1d1 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_kernel.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/v3_kernel.erl @@ -129,7 +129,7 @@ function(#c_def{anno=Af,name=#c_fname{id=F,arity=Arity},val=Body}, St0) -> %%B1 = B0, St3 = St2, %Null second pass {#k_fdef{anno=#k{us=[],ns=[],a=Af ++ Ab}, func=F,arity=Arity,vars=Kvs,body=B1},St3}. - + %% body(Cexpr, Sub, State) -> {Kexpr,[PreKepxr],State}. %% Do the main sequence of a body. A body ends in an atomic value or %% values. Must check if vector first so do expr. @@ -719,7 +719,7 @@ last([_|T]) -> last(T). first([_]) -> []; first([H|T]) -> [H|first(T)]. - + %% This code implements the algorithm for an optimizing compiler for %% pattern matching given "The Implementation of Functional %% Programming Languages" by Simon Peyton Jones. The code is much @@ -1143,7 +1143,7 @@ arg_val(Arg) -> #k_bin_end{} -> 0; #k_binary{} -> 0 end. - + %% ubody(Expr, Break, State) -> {Expr,[UsedVar],State}. %% Tag the body sequence with its used variables. These bodies %% either end with a #k_break{}, or with #k_return{} or an expression diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl index d3f67eb77a..8c91b6f430 100644 --- a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl @@ -338,7 +338,7 @@ exec_script(false,Info,Script,_AfterScript,_RequestURI) -> %% proxy(#mod{config_db = ConfigDb} = Info, Port) -> - Timeout = httpd_util:lookup(ConfigDb, cgi_timeout, ?DEFAULT_CGI_TIMEOUT), + Timeout = httpd_util:lookup(ConfigDb, script_timeout, ?DEFAULT_CGI_TIMEOUT), proxy(Info, Port, 0, undefined,[], Timeout). proxy(Info, Port, Size, StatusCode, AccResponse, Timeout) -> diff --git a/lib/dialyzer/test/small_SUITE_data/results/trec b/lib/dialyzer/test/small_SUITE_data/results/trec index 01ccc63761..b95df1e6ef 100644 --- a/lib/dialyzer/test/small_SUITE_data/results/trec +++ b/lib/dialyzer/test/small_SUITE_data/results/trec @@ -1,7 +1,7 @@ -trec.erl:26: Function test/0 has no local return -trec.erl:27: The call trec:mk_foo_loc(42,any()) will never return since it differs in the 1st argument from the success typing arguments: ('undefined',atom()) -trec.erl:29: Function mk_foo_loc/2 has no local return -trec.erl:30: Record construction violates the declared type for #foo{} since variable A cannot be of type atom() -trec.erl:36: Function mk_foo_exp/2 has no local return -trec.erl:37: Record construction violates the declared type for #foo{} since variable A cannot be of type atom() +trec.erl:28: Function test/0 has no local return +trec.erl:29: The call trec:mk_foo_loc(42,any()) will never return since it differs in the 1st argument from the success typing arguments: ('undefined',atom()) +trec.erl:31: Function mk_foo_loc/2 has no local return +trec.erl:32: Record construction violates the declared type for #foo{} since variable A cannot be of type atom() +trec.erl:38: Function mk_foo_exp/2 has no local return +trec.erl:39: Record construction violates the declared type for #foo{} since variable A cannot be of type atom() diff --git a/lib/dialyzer/test/small_SUITE_data/src/appmon_place.erl b/lib/dialyzer/test/small_SUITE_data/src/appmon_place.erl index 60ffbe818f..ddb97796fb 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/appmon_place.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/appmon_place.erl @@ -1,6 +1,6 @@ %%--------------------------------------------------------------------- %% This is added as a test because it was giving a false positive -%% (function move/4 will nevr be called) due to the strange use of +%% (function move/4 will never be called) due to the strange use of %% self-recursive fun construction in placex/3. %% %% The analysis was getting confused that the foldl call will never diff --git a/lib/dialyzer/test/small_SUITE_data/src/contract3.erl b/lib/dialyzer/test/small_SUITE_data/src/contract3.erl index 5b0bee9694..a6ce91882e 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/contract3.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/contract3.erl @@ -18,16 +18,23 @@ t(X, Y, Z) -> (atom()|list()) -> atom(). t1(X) -> - foo:bar(X). + f(X). -spec t2(atom(), integer()) -> integer(); (atom(), list()) -> atom(). t2(X, Y) -> - foo:bar(X, Y). + g(X, Y). -spec t3(atom(), integer(), list()) -> integer(); (X, integer(), list()) -> X. t3(X, Y, Z) -> X. + +%% dummy functions below + +f(X) -> X. + +g(X, Y) when is_atom(X), is_integer(Y) -> Y; +g(X, Y) when is_atom(X), is_list(Y) -> X. diff --git a/lib/dialyzer/test/small_SUITE_data/src/empty_list_infimum.erl b/lib/dialyzer/test/small_SUITE_data/src/empty_list_infimum.erl index b58fa732cb..3acc5ca065 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/empty_list_infimum.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/empty_list_infimum.erl @@ -1,6 +1,6 @@ %% -%% The Original Code is RabbitMQ. -%% +%% This is stripped down code from RabbitMQ. It is used to report an +%% invalid type specification for function list_vhost_permissions/1. %% The Initial Developer of the Original Code is VMware, Inc. %% @@ -38,7 +38,7 @@ vhost_perms_info_keys() -> -spec list_vhost_permissions(vhost()) -> infos(). list_vhost_permissions(VHostPath) -> - list_permissions(vhost_perms_info_keys(), rabbit_foo:some_list()). + list_permissions(vhost_perms_info_keys(), some_mod:some_function()). filter_props(Keys, Props) -> [T || T = {K, _} <- Props, lists:member(K, Keys)]. diff --git a/lib/dialyzer/test/small_SUITE_data/src/gencall.erl b/lib/dialyzer/test/small_SUITE_data/src/gencall.erl index d2875c9df1..762be55007 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/gencall.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/gencall.erl @@ -7,6 +7,6 @@ f() -> gen_server:call(1,2,3), ets:lookup(1,2,3), - gencall2:foo(), + some_mod:some_function(), gencall:foo(), gen_server:handle_cast(1,2). diff --git a/lib/dialyzer/test/small_SUITE_data/src/maybe_improper.erl b/lib/dialyzer/test/small_SUITE_data/src/maybe_improper.erl index 1743d81493..6d2a35b7c8 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/maybe_improper.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/maybe_improper.erl @@ -1,7 +1,18 @@ +%%%======================================================================== +%%% Tests handling of maybe improper lists +%%%======================================================================== -module(maybe_improper). --export([s/1]). +-export([s/1, t/0]). -spec s(maybe_improper_list(X,Y)) -> {[X], maybe_improper_list(X,Y)}. -s(A) -> - lists:split(2,A). +s(L) -> + lists:split(2, L). + +%% Having a remote type in the 'tail' of the list crashed dialyzer. +%% The problem was fixed for R16B03. +-type t_mil() :: maybe_improper_list(integer(), orddict:orddict()). + +-spec t() -> t_mil(). +t() -> + [42 | []]. diff --git a/lib/dialyzer/test/small_SUITE_data/src/overloaded1.erl b/lib/dialyzer/test/small_SUITE_data/src/overloaded1.erl index 0af4f7446f..074a93e2fe 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/overloaded1.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/overloaded1.erl @@ -1,5 +1,5 @@ %%----------------------------------------------------------------------------- -%% Test that tests overloaded contratcs. +%% Test that tests overloaded contracts. %% In December 2008 it works as far as intersection types are concerned (test1) %% However, it does NOT work as far as type variables are concerned (test2) %%----------------------------------------------------------------------------- @@ -16,13 +16,13 @@ test2() -> -type mod() :: atom(). --spec foo(ATM, list()) -> {'ok', ATM} | {'error', _} when is_subtype(ATM, mod()) - ; (MFA, list()) -> {'ok', MFA} | {'error', _} when is_subtype(MFA, mfa()). +-spec foo(ATM, list()) -> {'ok', ATM} | {'error', _} when ATM :: mod() + ; (MFA, list()) -> {'ok', MFA} | {'error', _} when MFA :: mfa(). foo(F, _) when is_atom(F) -> case atom_to_list(F) of - [42|_] -> {ok, F}; - _Other -> {error, mod:bar(F)} + [42|_] -> {ok, F}; + _Other -> {error, some_mod:some_function()} end; foo({M,F,A}, _) -> case A =:= 0 of diff --git a/lib/dialyzer/test/small_SUITE_data/src/trec.erl b/lib/dialyzer/test/small_SUITE_data/src/trec.erl index ba50c3b401..06706162c1 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/trec.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/trec.erl @@ -18,20 +18,22 @@ %% ('undefined',atom()) %% 3. Function mk_foo_loc/2 has no local return %% -%% Arguably, the second warning is not what most users have in mind -%% when they wrote the type declarations in the 'foo' record, so no -%% doubt they'll find it confusing. But note that it is also inconsistent! -%% How come there is a success typing for a function that has no local return? +%% Arguably, the second warning is not what most users have in mind when +%% they wrote the type declarations in the 'foo' record, so no doubt +%% they'll find it confusing. But note that it is also quite confusing! +%% Many users may be wondering: How come there is a success typing for a +%% function that has no local return? Running typer on this module +%% reveals a success typing for this function that is interesting indeed. %% test() -> - mk_foo_loc(42, bar:f()). + mk_foo_loc(42, some_mod:some_function()). mk_foo_loc(A, B) -> #foo{a = A, b = [A,B]}. %% -%% For this function we currently get "has no local return" but we get -%% no reason; I want us to get a reason. +%% For this function we used to get a "has no local return" warning +%% but we got no reason. This has now been fixed. %% mk_foo_exp(A, B) when is_integer(A) -> #foo{a = A, b = [A,B]}. diff --git a/lib/eldap/doc/src/eldap.xml b/lib/eldap/doc/src/eldap.xml index 30767abd7e..5b81716543 100644 --- a/lib/eldap/doc/src/eldap.xml +++ b/lib/eldap/doc/src/eldap.xml @@ -35,6 +35,7 @@ <p>References:</p> <list type="bulleted"> <item> <p>RFC 4510 - RFC 4519</p> </item> + <item> <p>RFC 2830</p> </item> </list> <p>The above publications can be found at <url href="http://www.ietf.org">IETF</url>. </p> @@ -87,6 +88,38 @@ filter() See present/1, substrings/2, </desc> </func> <func> + <name>start_tls(Handle, Options) -> ok | {error,Error}</name> + <fsummary>Upgrade a connection to TLS.</fsummary> + <desc> + <p>Same as start_tls(Handle, Options, infinity)</p> + </desc> + </func> + <func> + <name>start_tls(Handle, Options, Timeout) -> ok | {error,Error}</name> + <fsummary>Upgrade a connection to TLS.</fsummary> + <type> + <v>Handle = handle()</v> + <v>Options = ssl:ssl_options()</v> + <v>Timeout = inifinity | positive_integer()</v> + </type> + <desc> + <p>Upgrade the connection associated with <c>Handle</c> to a tls connection if possible.</p> + <p>The upgrade is done in two phases: first the server is asked for permission to upgrade. Second, if the request is acknowledged, the upgrade is performed.</p> + <p>Error responese from phase one will not affect the current encryption state of the connection. Those responses are:</p> + <taglist> + <tag><c>tls_already_started</c></tag> + <item>The connection is already encrypted. The connection is not affected.</item> + <tag><c>{response,ResponseFromServer}</c></tag> + <item>The upgrade was refused by the LDAP server. The <c>ResponseFromServer</c> is an atom delivered byt the LDAP server explained in section 2.3 of rfc 2830. The connection is not affected, so it is still un-encrypted.</item> + </taglist> + <p>Errors in the seconde phase will however end the connection:</p> + <taglist> + <tag><c>Error</c></tag> + <item>Any error responded from ssl:connect/3</item> + </taglist> + </desc> + </func> + <func> <name>simple_bind(Handle, Dn, Password) -> ok | {error, Reason}</name> <fsummary>Authenticate the connection.</fsummary> <type> diff --git a/lib/eldap/src/eldap.erl b/lib/eldap/src/eldap.erl index d11f904996..af5bf94c97 100644 --- a/lib/eldap/src/eldap.erl +++ b/lib/eldap/src/eldap.erl @@ -6,10 +6,12 @@ %%% draft-ietf-asid-ldap-c-api-00.txt %%% %%% Copyright (c) 2010 Torbjorn Tornkvist +%%% Copyright Ericsson AB 2011-2013. All Rights Reserved. %%% See MIT-LICENSE at the top dir for licensing information. %%% -------------------------------------------------------------------- -vc('$Id$ '). -export([open/1,open/2,simple_bind/3,controlling_process/2, + start_tls/2, start_tls/3, baseObject/0,singleLevel/0,wholeSubtree/0,close/1, equalityMatch/2,greaterOrEqual/2,lessOrEqual/2, approxMatch/2,search/2,substrings/2,present/1, @@ -36,14 +38,16 @@ host, % Host running LDAP server port = ?LDAP_PORT, % The LDAP server port fd, % Socket filedescriptor. + prev_fd, % Socket that was upgraded by start_tls binddn = "", % Name of the entry to bind as passwd, % Password for (above) entry id = 0, % LDAP Request ID log, % User provided log function timeout = infinity, % Request timeout anon_auth = false, % Allow anonymous authentication - use_tls = false, % LDAP/LDAPS - tls_opts = [] % ssl:ssloptsion() + ldaps = false, % LDAP/LDAPS + using_tls = false, % true if LDAPS or START_TLS executed + tls_opts = [] % ssl:ssloption() }). %%% For debug purposes @@ -77,6 +81,16 @@ open(Hosts, Opts) when is_list(Hosts), is_list(Opts) -> recv(Pid). %%% -------------------------------------------------------------------- +%%% Upgrade an existing connection to tls +%%% -------------------------------------------------------------------- +start_tls(Handle, TlsOptions) -> + start_tls(Handle, TlsOptions, infinity). + +start_tls(Handle, TlsOptions, Timeout) -> + send(Handle, {start_tls,TlsOptions,Timeout}), + recv(Handle). + +%%% -------------------------------------------------------------------- %%% Shutdown connection (and process) asynchronous. %%% -------------------------------------------------------------------- @@ -351,11 +365,11 @@ parse_args([{anon_auth, true}|T], Cpid, Data) -> parse_args([{anon_auth, _}|T], Cpid, Data) -> parse_args(T, Cpid, Data); parse_args([{ssl, true}|T], Cpid, Data) -> - parse_args(T, Cpid, Data#eldap{use_tls = true}); + parse_args(T, Cpid, Data#eldap{ldaps = true, using_tls=true}); parse_args([{ssl, _}|T], Cpid, Data) -> parse_args(T, Cpid, Data); parse_args([{sslopts, Opts}|T], Cpid, Data) when is_list(Opts) -> - parse_args(T, Cpid, Data#eldap{use_tls = true, tls_opts = Opts ++ Data#eldap.tls_opts}); + parse_args(T, Cpid, Data#eldap{ldaps = true, using_tls=true, tls_opts = Opts ++ Data#eldap.tls_opts}); parse_args([{sslopts, _}|T], Cpid, Data) -> parse_args(T, Cpid, Data); parse_args([{log, F}|T], Cpid, Data) when is_function(F) -> @@ -386,11 +400,10 @@ try_connect([Host|Hosts], Data) -> try_connect([],_) -> {error,"connect failed"}. -do_connect(Host, Data, Opts) when Data#eldap.use_tls == false -> +do_connect(Host, Data, Opts) when Data#eldap.ldaps == false -> gen_tcp:connect(Host, Data#eldap.port, Opts, Data#eldap.timeout); -do_connect(Host, Data, Opts) when Data#eldap.use_tls == true -> - SslOpts = [{verify,0} | Opts ++ Data#eldap.tls_opts], - ssl:connect(Host, Data#eldap.port, SslOpts). +do_connect(Host, Data, Opts) when Data#eldap.ldaps == true -> + ssl:connect(Host, Data#eldap.port, Opts++Data#eldap.tls_opts). loop(Cpid, Data) -> receive @@ -431,6 +444,11 @@ loop(Cpid, Data) -> ?PRINT("New Cpid is: ~p~n",[NewCpid]), ?MODULE:loop(NewCpid, Data); + {From, {start_tls,TlsOptions,Timeout}} -> + {Res,NewData} = do_start_tls(Data, TlsOptions, Timeout), + send(From,Res), + ?MODULE:loop(Cpid, NewData); + {_From, close} -> unlink(Cpid), exit(closed); @@ -445,6 +463,51 @@ loop(Cpid, Data) -> end. + +%%% -------------------------------------------------------------------- +%%% startTLS Request +%%% -------------------------------------------------------------------- + +do_start_tls(Data=#eldap{using_tls=true}, _, _) -> + {{error,tls_already_started}, Data}; +do_start_tls(Data=#eldap{fd=FD} , TlsOptions, Timeout) -> + case catch exec_start_tls(Data) of + {ok,NewData} -> + case ssl:connect(FD,TlsOptions,Timeout) of + {ok, SslSocket} -> + {ok, NewData#eldap{prev_fd = FD, + fd = SslSocket, + using_tls = true + }}; + {error,Error} -> + {{error,Error}, Data} + end; + {error,Error} -> {{error,Error},Data}; + Else -> {{error,Else},Data} + end. + +-define(START_TLS_OID, "1.3.6.1.4.1.1466.20037"). + +exec_start_tls(Data) -> + Req = #'ExtendedRequest'{requestName = ?START_TLS_OID}, + Reply = request(Data#eldap.fd, Data, Data#eldap.id, {extendedReq, Req}), + exec_extended_req_reply(Data, Reply). + +exec_extended_req_reply(Data, {ok,Msg}) when + Msg#'LDAPMessage'.messageID == Data#eldap.id -> + case Msg#'LDAPMessage'.protocolOp of + {extendedResp, Result} -> + case Result#'ExtendedResponse'.resultCode of + success -> + {ok,Data}; + Error -> + {error, {response,Error}} + end; + Other -> {error, Other} + end; +exec_extended_req_reply(_, Error) -> + {error, Error}. + %%% -------------------------------------------------------------------- %%% bindRequest %%% -------------------------------------------------------------------- @@ -686,14 +749,14 @@ send_request(S, Data, ID, Request) -> Else -> Else end. -do_send(S, Data, Bytes) when Data#eldap.use_tls == false -> +do_send(S, Data, Bytes) when Data#eldap.using_tls == false -> gen_tcp:send(S, Bytes); -do_send(S, Data, Bytes) when Data#eldap.use_tls == true -> +do_send(S, Data, Bytes) when Data#eldap.using_tls == true -> ssl:send(S, Bytes). -do_recv(S, #eldap{use_tls=false, timeout=Timeout}, Len) -> +do_recv(S, #eldap{using_tls=false, timeout=Timeout}, Len) -> gen_tcp:recv(S, Len, Timeout); -do_recv(S, #eldap{use_tls=true, timeout=Timeout}, Len) -> +do_recv(S, #eldap{using_tls=true, timeout=Timeout}, Len) -> ssl:recv(S, Len, Timeout). recv_response(S, Data) -> @@ -801,7 +864,7 @@ recv(From) -> {error, {internal_error, Reason}} end. -ldap_closed_p(Data, Emsg) when Data#eldap.use_tls == true -> +ldap_closed_p(Data, Emsg) when Data#eldap.using_tls == true -> %% Check if the SSL socket seems to be alive or not case catch ssl:sockname(Data#eldap.fd) of {error, _} -> diff --git a/lib/eldap/test/README b/lib/eldap/test/README new file mode 100644 index 0000000000..8774db1504 --- /dev/null +++ b/lib/eldap/test/README @@ -0,0 +1,36 @@ + +This works for me on Ubuntu. + +To run thoose test you need + 1) some certificates + 2) a running ldap server, for example OpenLDAPs slapd. See http://www.openldap.org/doc/admin24 + +1)------- +To generate certificates: +erl +> make_certs:all("/dev/null", "eldap_basic_SUITE_data/certs"). + +2)------- +To start slapd: + sudo slapd -f $ERL_TOP/lib/eldap/test/ldap_server/slapd.conf -F /tmp/slapd/slapd.d -h "ldap://localhost:9876 ldaps://localhost:9877" + +This will however not work, since slapd is guarded by apparmor that checks that slapd does not access other than allowed files... + +To make a local extension of alowed operations: + sudo emacs /etc/apparmor.d/local/usr.sbin.slapd + +and, after the change (yes, at least on Ubuntu it is right to edit ../local/.. but run with an other file) : + + sudo apparmor_parser -r /etc/apparmor.d/usr.sbin.slapd + + +The local file looks like this for me: + +# Site-specific additions and overrides for usr.sbin.slapd. +# For more details, please see /etc/apparmor.d/local/README. + +/etc/pkcs11/** r, +/usr/lib/x86_64-linux-gnu/** rm, + +/ldisk/hans_otp/otp/lib/eldap/test/** rw, +/tmp/slapd/** rwk, diff --git a/lib/eldap/test/eldap.cfg b/lib/eldap/test/eldap.cfg new file mode 100644 index 0000000000..3a24afa067 --- /dev/null +++ b/lib/eldap/test/eldap.cfg @@ -0,0 +1 @@ +{eldap_server,{"localhost",389}}. diff --git a/lib/eldap/test/eldap_basic_SUITE.erl b/lib/eldap/test/eldap_basic_SUITE.erl index c7e3052b29..127d753b92 100644 --- a/lib/eldap/test/eldap_basic_SUITE.erl +++ b/lib/eldap/test/eldap_basic_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2012. All Rights Reserved. +%% Copyright Ericsson AB 2012-2013. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -27,39 +27,36 @@ -define(TIMEOUT, 120000). % 2 min -init_per_suite(Config0) -> - {{EldapHost,Port}, Config1} = - case catch ct:get_config(eldap_server, undefined) of - undefined -> %% Dev test only - Server = {"localhost", 9876}, - {Server, [{eldap_server, {"localhost", 9876}}|Config0]}; - {'EXIT', _} -> %% Dev test only - Server = {"localhost", 9876}, - {Server, [{eldap_server, {"localhost", 9876}}|Config0]}; - Server -> - {Server, [{eldap_server, Server}|Config0]} - end, - %% Add path for this test run +init_per_suite(Config) -> + ssl:start(), + chk_config(ldap_server, {"localhost",9876}, + chk_config(ldaps_server, {"localhost",9877}, + Config)). + +end_per_suite(_Config) -> + ok. + +init_per_testcase(_TestCase, Config0) -> + {EldapHost,Port} = proplists:get_value(ldap_server,Config0), try - {ok, Handle} = eldap:open([EldapHost], [{port, Port}]), + {ok, Handle} = eldap:open([EldapHost], [{port,Port}]), ok = eldap:simple_bind(Handle, "cn=Manager,dc=ericsson,dc=se", "hejsan"), {ok, MyHost} = inet:gethostname(), Path = "dc="++MyHost++",dc=ericsson,dc=se", - Config = [{eldap_path,Path}|Config1], eldap:add(Handle,"dc=ericsson,dc=se", [{"objectclass", ["dcObject", "organization"]}, {"dc", ["ericsson"]}, {"o", ["Testing"]}]), eldap:add(Handle,Path, [{"objectclass", ["dcObject", "organization"]}, {"dc", [MyHost]}, {"o", ["Test machine"]}]), - Config + [{eldap_path,Path}|Config0] catch error:{badmatch,Error} -> io:format("Eldap init error ~p~n ~p~n",[Error, erlang:get_stacktrace()]), - {skip, lists:flatten(io_lib:format("Ldap init failed with host ~p", [EldapHost]))} + {skip, lists:flatten(io_lib:format("Ldap init failed with host ~p:~p. Error=~p", [EldapHost,Port,Error]))} end. -end_per_suite(Config) -> - %% Cleanup everything - {EHost, Port} = proplists:get_value(eldap_server, Config), + +end_per_testcase(_TestCase, Config) -> + {EHost, Port} = proplists:get_value(ldap_server, Config), Path = proplists:get_value(eldap_path, Config), {ok, H} = eldap:open([EHost], [{port, Port}]), ok = eldap:simple_bind(H, "cn=Manager,dc=ericsson,dc=se", "hejsan"), @@ -71,16 +68,20 @@ end_per_suite(Config) -> [ok = eldap:delete(H, Entry) || {eldap_entry, Entry, _} <- Entries]; _ -> ignore end, - ok. -init_per_testcase(_TestCase, Config) -> Config. -end_per_testcase(_TestCase, _Config) -> ok. + ok. %% suite() -> all() -> [app, - api]. + api, + ssl_api, + start_tls, + tls_operations, + start_tls_twice, + start_tls_on_ssl + ]. app(doc) -> "Test that the eldap app file is ok"; app(suite) -> []; @@ -90,21 +91,89 @@ app(Config) when is_list(Config) -> api(doc) -> "Basic test that all api functions works as expected"; api(suite) -> []; api(Config) -> - {Host,Port} = proplists:get_value(eldap_server, Config), + {Host,Port} = proplists:get_value(ldap_server, Config), {ok, H} = eldap:open([Host], [{port,Port}]), %% {ok, H} = eldap:open([Host], [{port,Port+1}, {ssl, true}]), + do_api_checks(H, Config), + eldap:close(H), + ok. + + +ssl_api(doc) -> "Basic test that all api functions works as expected"; +ssl_api(suite) -> []; +ssl_api(Config) -> + {Host,Port} = proplists:get_value(ldaps_server, Config), + {ok, H} = eldap:open([Host], [{port,Port}, {ssl,true}]), + do_api_checks(H, Config), + eldap:close(H), + ok. + + +start_tls(doc) -> "Test that an existing (tcp) connection can be upgraded to tls"; +start_tls(suite) -> []; +start_tls(Config) -> + {Host,Port} = proplists:get_value(ldap_server, Config), + {ok, H} = eldap:open([Host], [{port,Port}]), + ok = eldap:start_tls(H, [ + {keyfile, filename:join([proplists:get_value(data_dir,Config), + "certs/client/key.pem"])} + ]), + eldap:close(H). + + +tls_operations(doc) -> "Test that an upgraded connection is usable for ldap stuff"; +tls_operations(suite) -> []; +tls_operations(Config) -> + {Host,Port} = proplists:get_value(ldap_server, Config), + {ok, H} = eldap:open([Host], [{port,Port}]), + ok = eldap:start_tls(H, [ + {keyfile, filename:join([proplists:get_value(data_dir,Config), + "certs/client/key.pem"])} + ]), + do_api_checks(H, Config), + eldap:close(H). + +start_tls_twice(doc) -> "Test that start_tls on an already upgraded connection fails"; +start_tls_twice(suite) -> []; +start_tls_twice(Config) -> + {Host,Port} = proplists:get_value(ldap_server, Config), + {ok, H} = eldap:open([Host], [{port,Port}]), + ok = eldap:start_tls(H, []), + {error,tls_already_started} = eldap:start_tls(H, []), + do_api_checks(H, Config), + eldap:close(H). + + +start_tls_on_ssl(doc) -> "Test that start_tls on an ldaps connection fails"; +start_tls_on_ssl(suite) -> []; +start_tls_on_ssl(Config) -> + {Host,Port} = proplists:get_value(ldaps_server, Config), + {ok, H} = eldap:open([Host], [{port,Port}, {ssl,true}]), + {error,tls_already_started} = eldap:start_tls(H, []), + do_api_checks(H, Config), + eldap:close(H). + + +%%%-------------------------------------------------------------------------------- +chk_config(Key, Default, Config) -> + case catch ct:get_config(ldap_server, undefined) of + undefined -> [{Key,Default} | Config ]; + {'EXIT',_} -> [{Key,Default} | Config ]; + Value -> [{Key,Value} | Config] + end. + + + +do_api_checks(H, Config) -> BasePath = proplists:get_value(eldap_path, Config), + All = fun(Where) -> eldap:search(H, #eldap_search{base=Where, filter=eldap:present("objectclass"), scope= eldap:wholeSubtree()}) end, - Search = fun(Filter) -> - eldap:search(H, #eldap_search{base=BasePath, - filter=Filter, - scope=eldap:singleLevel()}) - end, - {ok, #eldap_search_result{entries=[_]}} = All(BasePath), + {ok, #eldap_search_result{entries=[_XYZ]}} = All(BasePath), +%% ct:log("XYZ=~p",[_XYZ]), {error, noSuchObject} = All("cn=Bar,"++BasePath), {error, _} = eldap:add(H, "cn=Jonas Jonsson," ++ BasePath, @@ -112,52 +181,67 @@ api(Config) -> {"cn", ["Jonas Jonsson"]}, {"sn", ["Jonsson"]}]), eldap:simple_bind(H, "cn=Manager,dc=ericsson,dc=se", "hejsan"), - %% Add + chk_add(H, BasePath), + {ok,FB} = chk_search(H, BasePath), + chk_modify(H, FB), + chk_delete(H, BasePath), + chk_modify_dn(H, FB). + + +chk_add(H, BasePath) -> ok = eldap:add(H, "cn=Jonas Jonsson," ++ BasePath, [{"objectclass", ["person"]}, {"cn", ["Jonas Jonsson"]}, {"sn", ["Jonsson"]}]), + {error, entryAlreadyExists} = eldap:add(H, "cn=Jonas Jonsson," ++ BasePath, + [{"objectclass", ["person"]}, + {"cn", ["Jonas Jonsson"]}, {"sn", ["Jonsson"]}]), ok = eldap:add(H, "cn=Foo Bar," ++ BasePath, [{"objectclass", ["person"]}, {"cn", ["Foo Bar"]}, {"sn", ["Bar"]}, {"telephoneNumber", ["555-1232", "555-5432"]}]), ok = eldap:add(H, "ou=Team," ++ BasePath, [{"objectclass", ["organizationalUnit"]}, - {"ou", ["Team"]}]), + {"ou", ["Team"]}]). - %% Search +chk_search(H, BasePath) -> + Search = fun(Filter) -> + eldap:search(H, #eldap_search{base=BasePath, + filter=Filter, + scope=eldap:singleLevel()}) + end, JJSR = {ok, #eldap_search_result{entries=[#eldap_entry{}]}} = Search(eldap:equalityMatch("sn", "Jonsson")), JJSR = Search(eldap:substrings("sn", [{any, "ss"}])), FBSR = {ok, #eldap_search_result{entries=[#eldap_entry{object_name=FB}]}} = Search(eldap:substrings("sn", [{any, "a"}])), FBSR = Search(eldap:substrings("sn", [{initial, "B"}])), FBSR = Search(eldap:substrings("sn", [{final, "r"}])), - F_AND = eldap:'and'([eldap:present("objectclass"), eldap:present("ou")]), {ok, #eldap_search_result{entries=[#eldap_entry{}]}} = Search(F_AND), F_NOT = eldap:'and'([eldap:present("objectclass"), eldap:'not'(eldap:present("ou"))]), {ok, #eldap_search_result{entries=[#eldap_entry{}, #eldap_entry{}]}} = Search(F_NOT), + {ok,FB}. %% FIXME - %% MODIFY +chk_modify(H, FB) -> Mod = [eldap:mod_replace("telephoneNumber", ["555-12345"]), eldap:mod_add("description", ["Nice guy"])], %% io:format("MOD ~p ~p ~n",[FB, Mod]), ok = eldap:modify(H, FB, Mod), %% DELETE ATTR - ok = eldap:modify(H, FB, [eldap:mod_delete("telephoneNumber", [])]), + ok = eldap:modify(H, FB, [eldap:mod_delete("telephoneNumber", [])]). - %% DELETE + +chk_delete(H, BasePath) -> {error, entryAlreadyExists} = eldap:add(H, "cn=Jonas Jonsson," ++ BasePath, [{"objectclass", ["person"]}, {"cn", ["Jonas Jonsson"]}, {"sn", ["Jonsson"]}]), ok = eldap:delete(H, "cn=Jonas Jonsson," ++ BasePath), - {error, noSuchObject} = eldap:delete(H, "cn=Jonas Jonsson," ++ BasePath), + {error, noSuchObject} = eldap:delete(H, "cn=Jonas Jonsson," ++ BasePath). - %% MODIFY_DN - ok = eldap:modify_dn(H, FB, "cn=Niclas Andre", true, ""), - %%io:format("Res ~p~n ~p~n",[R, All(BasePath)]), +chk_modify_dn(H, FB) -> + ok = eldap:modify_dn(H, FB, "cn=Niclas Andre", true, ""). + %%io:format("Res ~p~n ~p~n",[R, All(BasePath)]). - eldap:close(H), - ok. +%%%---------------- add(H, Attr, Value, Path0, Attrs, Class) -> Path = case Path0 of [] -> Attr ++ "=" ++ Value; diff --git a/lib/eldap/test/eldap_basic_SUITE_data/certs/README b/lib/eldap/test/eldap_basic_SUITE_data/certs/README new file mode 100644 index 0000000000..a7c8e9dc2e --- /dev/null +++ b/lib/eldap/test/eldap_basic_SUITE_data/certs/README @@ -0,0 +1 @@ +See ../../README diff --git a/lib/eldap/test/ldap_server/slapd.conf b/lib/eldap/test/ldap_server/slapd.conf index 87be676d9f..eca298c866 100644 --- a/lib/eldap/test/ldap_server/slapd.conf +++ b/lib/eldap/test/ldap_server/slapd.conf @@ -1,14 +1,32 @@ -include /etc/ldap/schema/core.schema -pidfile /tmp/openldap-data/slapd.pid -argsfile /tmp/openldap-data/slapd.args +modulepath /usr/lib/ldap +moduleload back_bdb.la + +# example config file - global configuration section +include /etc/ldap/schema/core.schema +referral ldap://root.openldap.org +access to * by * read + +TLSCACertificateFile /ldisk/hans_otp/otp/lib/eldap/test/eldap_basic_SUITE_data/certs/server/cacerts.pem +TLSCertificateFile /ldisk/hans_otp/otp/lib/eldap/test/eldap_basic_SUITE_data/certs/server/cert.pem +TLSCertificateKeyFile /ldisk/hans_otp/otp/lib/eldap/test/eldap_basic_SUITE_data/certs/server/keycert.pem + database bdb suffix "dc=ericsson,dc=se" rootdn "cn=Manager,dc=ericsson,dc=se" rootpw hejsan + # The database must exist before running slapd -directory /tmp/openldap-data +directory /tmp/slapd/openldap-data-ericsson.se + # Indices to maintain index objectClass eq -# URI "ldap://0.0.0.0:9876 ldaps://0.0.0.0:9870" -# servers/slapd/slapd -d 255 -h "ldap://0.0.0.0:9876 ldaps://0.0.0.0:9870" -f /ldisk/dgud/src/otp/lib/eldap/test/ldap_server/slapd.conf
\ No newline at end of file +access to attrs=userPassword + by self write + by anonymous auth + by dn.base="cn=Manager,dc=ericsson,dc=se" write + by * none +access to * + by self write + by dn.base="cn=Manager,dc=ericsson,dc=se" write + by * read diff --git a/lib/eldap/test/make_certs.erl b/lib/eldap/test/make_certs.erl new file mode 100644 index 0000000000..f963af180d --- /dev/null +++ b/lib/eldap/test/make_certs.erl @@ -0,0 +1,313 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2007-2013. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +-module(make_certs). + +-export([all/2]). + +-record(dn, {commonName, + organizationalUnitName = "Erlang OTP", + organizationName = "Ericsson AB", + localityName = "Stockholm", + countryName = "SE", + emailAddress = "[email protected]"}). + +all(DataDir, PrivDir) -> + OpenSSLCmd = "openssl", + create_rnd(DataDir, PrivDir), % For all requests + rootCA(PrivDir, OpenSSLCmd, "erlangCA"), + intermediateCA(PrivDir, OpenSSLCmd, "otpCA", "erlangCA"), + endusers(PrivDir, OpenSSLCmd, "otpCA", ["client", "server"]), + collect_certs(PrivDir, ["erlangCA", "otpCA"], ["client", "server"]), + %% Create keycert files + SDir = filename:join([PrivDir, "server"]), + SC = filename:join([SDir, "cert.pem"]), + SK = filename:join([SDir, "key.pem"]), + SKC = filename:join([SDir, "keycert.pem"]), + append_files([SK, SC], SKC), + CDir = filename:join([PrivDir, "client"]), + CC = filename:join([CDir, "cert.pem"]), + CK = filename:join([CDir, "key.pem"]), + CKC = filename:join([CDir, "keycert.pem"]), + append_files([CK, CC], CKC), + remove_rnd(PrivDir). + +append_files(FileNames, ResultFileName) -> + {ok, ResultFile} = file:open(ResultFileName, [write]), + do_append_files(FileNames, ResultFile). + +do_append_files([], RF) -> + ok = file:close(RF); +do_append_files([F|Fs], RF) -> + {ok, Data} = file:read_file(F), + ok = file:write(RF, Data), + do_append_files(Fs, RF). + +rootCA(Root, OpenSSLCmd, Name) -> + create_ca_dir(Root, Name, ca_cnf(Name)), + DN = #dn{commonName = Name}, + create_self_signed_cert(Root, OpenSSLCmd, Name, req_cnf(DN)), + ok. + +intermediateCA(Root, OpenSSLCmd, CA, ParentCA) -> + CA = "otpCA", + create_ca_dir(Root, CA, ca_cnf(CA)), + CARoot = filename:join([Root, CA]), + DN = #dn{commonName = CA}, + CnfFile = filename:join([CARoot, "req.cnf"]), + file:write_file(CnfFile, req_cnf(DN)), + KeyFile = filename:join([CARoot, "private", "key.pem"]), + ReqFile = filename:join([CARoot, "req.pem"]), + create_req(Root, OpenSSLCmd, CnfFile, KeyFile, ReqFile), + CertFile = filename:join([CARoot, "cert.pem"]), + sign_req(Root, OpenSSLCmd, ParentCA, "ca_cert", ReqFile, CertFile). + +endusers(Root, OpenSSLCmd, CA, Users) -> + lists:foreach(fun(User) -> enduser(Root, OpenSSLCmd, CA, User) end, Users). + +enduser(Root, OpenSSLCmd, CA, User) -> + UsrRoot = filename:join([Root, User]), + file:make_dir(UsrRoot), + CnfFile = filename:join([UsrRoot, "req.cnf"]), + DN = #dn{commonName = User}, + file:write_file(CnfFile, req_cnf(DN)), + KeyFile = filename:join([UsrRoot, "key.pem"]), + ReqFile = filename:join([UsrRoot, "req.pem"]), + create_req(Root, OpenSSLCmd, CnfFile, KeyFile, ReqFile), + CertFileAllUsage = filename:join([UsrRoot, "cert.pem"]), + sign_req(Root, OpenSSLCmd, CA, "user_cert", ReqFile, CertFileAllUsage), + CertFileDigitalSigOnly = filename:join([UsrRoot, "digital_signature_only_cert.pem"]), + sign_req(Root, OpenSSLCmd, CA, "user_cert_digital_signature_only", ReqFile, CertFileDigitalSigOnly). + +collect_certs(Root, CAs, Users) -> + Bins = lists:foldr( + fun(CA, Acc) -> + File = filename:join([Root, CA, "cert.pem"]), + {ok, Bin} = file:read_file(File), + [Bin, "\n" | Acc] + end, [], CAs), + lists:foreach( + fun(User) -> + File = filename:join([Root, User, "cacerts.pem"]), + file:write_file(File, Bins) + end, Users). + +create_self_signed_cert(Root, OpenSSLCmd, CAName, Cnf) -> + CARoot = filename:join([Root, CAName]), + CnfFile = filename:join([CARoot, "req.cnf"]), + file:write_file(CnfFile, Cnf), + KeyFile = filename:join([CARoot, "private", "key.pem"]), + CertFile = filename:join([CARoot, "cert.pem"]), + Cmd = [OpenSSLCmd, " req" + " -new" + " -x509" + " -config ", CnfFile, + " -keyout ", KeyFile, + " -out ", CertFile], + Env = [{"ROOTDIR", Root}], + cmd(Cmd, Env), + fix_key_file(OpenSSLCmd, KeyFile). + +% openssl 1.0 generates key files in pkcs8 format by default and we don't handle this format +fix_key_file(OpenSSLCmd, KeyFile) -> + KeyFileTmp = KeyFile ++ ".tmp", + Cmd = [OpenSSLCmd, " rsa", + " -in ", + KeyFile, + " -out ", + KeyFileTmp], + cmd(Cmd, []), + ok = file:rename(KeyFileTmp, KeyFile). + +create_ca_dir(Root, CAName, Cnf) -> + CARoot = filename:join([Root, CAName]), + file:make_dir(CARoot), + create_dirs(CARoot, ["certs", "crl", "newcerts", "private"]), + create_rnd(Root, filename:join([CAName, "private"])), + create_files(CARoot, [{"serial", "01\n"}, + {"index.txt", ""}, + {"ca.cnf", Cnf}]). + +create_req(Root, OpenSSLCmd, CnfFile, KeyFile, ReqFile) -> + Cmd = [OpenSSLCmd, " req" + " -new" + " -config ", CnfFile, + " -keyout ", KeyFile, + " -out ", ReqFile], + Env = [{"ROOTDIR", Root}], + cmd(Cmd, Env), + fix_key_file(OpenSSLCmd, KeyFile). + +sign_req(Root, OpenSSLCmd, CA, CertType, ReqFile, CertFile) -> + CACnfFile = filename:join([Root, CA, "ca.cnf"]), + Cmd = [OpenSSLCmd, " ca" + " -batch" + " -notext" + " -config ", CACnfFile, + " -extensions ", CertType, + " -in ", ReqFile, + " -out ", CertFile], + Env = [{"ROOTDIR", Root}], + cmd(Cmd, Env). + +%% +%% Misc +%% + +create_dirs(Root, Dirs) -> + lists:foreach(fun(Dir) -> + file:make_dir(filename:join([Root, Dir])) end, + Dirs). + +create_files(Root, NameContents) -> + lists:foreach( + fun({Name, Contents}) -> + file:write_file(filename:join([Root, Name]), Contents) end, + NameContents). + +create_rnd(FromDir, ToDir) -> + From = filename:join([FromDir, "RAND"]), + To = filename:join([ToDir, "RAND"]), + file:copy(From, To). + +remove_rnd(Dir) -> + File = filename:join([Dir, "RAND"]), + file:delete(File). + +cmd(Cmd, Env) -> + FCmd = lists:flatten(Cmd), + Port = open_port({spawn, FCmd}, [stream, eof, exit_status, stderr_to_stdout, + {env, Env}]), + eval_cmd(Port). + +eval_cmd(Port) -> + receive + {Port, {data, _}} -> + eval_cmd(Port); + {Port, eof} -> + ok + end, + receive + {Port, {exit_status, Status}} when Status /= 0 -> + %% io:fwrite("exit status: ~w~n", [Status]), + exit({eval_cmd, Status}) + after 0 -> + ok + end. + +%% +%% Contents of configuration files +%% + +req_cnf(DN) -> + ["# Purpose: Configuration for requests (end users and CAs)." + "\n" + "ROOTDIR = $ENV::ROOTDIR\n" + "\n" + + "[req]\n" + "input_password = secret\n" + "output_password = secret\n" + "default_bits = 1024\n" + "RANDFILE = $ROOTDIR/RAND\n" + "encrypt_key = no\n" + "default_md = sha1\n" + "#string_mask = pkix\n" + "x509_extensions = ca_ext\n" + "prompt = no\n" + "distinguished_name= name\n" + "\n" + + "[name]\n" + "commonName = ", DN#dn.commonName, "\n" + "organizationalUnitName = ", DN#dn.organizationalUnitName, "\n" + "organizationName = ", DN#dn.organizationName, "\n" + "localityName = ", DN#dn.localityName, "\n" + "countryName = ", DN#dn.countryName, "\n" + "emailAddress = ", DN#dn.emailAddress, "\n" + "\n" + + "[ca_ext]\n" + "basicConstraints = critical, CA:true\n" + "keyUsage = cRLSign, keyCertSign\n" + "subjectKeyIdentifier = hash\n" + "subjectAltName = email:copy\n"]. + + +ca_cnf(CA) -> + ["# Purpose: Configuration for CAs.\n" + "\n" + "ROOTDIR = $ENV::ROOTDIR\n" + "default_ca = ca\n" + "\n" + + "[ca]\n" + "dir = $ROOTDIR/", CA, "\n" + "certs = $dir/certs\n" + "crl_dir = $dir/crl\n" + "database = $dir/index.txt\n" + "new_certs_dir = $dir/newcerts\n" + "certificate = $dir/cert.pem\n" + "serial = $dir/serial\n" + "crl = $dir/crl.pem\n" + "private_key = $dir/private/key.pem\n" + "RANDFILE = $dir/private/RAND\n" + "\n" + "x509_extensions = user_cert\n" + "unique_subject = no\n" + "default_days = 3600\n" + "default_md = sha1\n" + "preserve = no\n" + "policy = policy_match\n" + "\n" + + "[policy_match]\n" + "commonName = supplied\n" + "organizationalUnitName = optional\n" + "organizationName = match\n" + "countryName = match\n" + "localityName = match\n" + "emailAddress = supplied\n" + "\n" + + "[user_cert]\n" + "basicConstraints = CA:false\n" + "keyUsage = nonRepudiation, digitalSignature, keyEncipherment\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + "\n" + + "[user_cert_digital_signature_only]\n" + "basicConstraints = CA:false\n" + "keyUsage = digitalSignature\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + "\n" + + "[ca_cert]\n" + "basicConstraints = critical,CA:true\n" + "keyUsage = cRLSign, keyCertSign\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid:always,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n"]. diff --git a/lib/erl_interface/src/legacy/erl_eterm.c b/lib/erl_interface/src/legacy/erl_eterm.c index 7ca4f430de..636d26b24b 100644 --- a/lib/erl_interface/src/legacy/erl_eterm.c +++ b/lib/erl_interface/src/legacy/erl_eterm.c @@ -686,7 +686,7 @@ int erl_length(const ETERM *ep) return n; } - + /*********************************************************************** * I o l i s t f u n c t i o n s * diff --git a/lib/erl_interface/test/all_SUITE_data/ei_runner.c b/lib/erl_interface/test/all_SUITE_data/ei_runner.c index 205f911e38..cdf32b48c4 100644 --- a/lib/erl_interface/test/all_SUITE_data/ei_runner.c +++ b/lib/erl_interface/test/all_SUITE_data/ei_runner.c @@ -77,7 +77,7 @@ run_tests(char* argv0, TestCase test_cases[], unsigned number) } } - + /*********************************************************************** * * R e a d i n g p a c k e t s @@ -182,7 +182,7 @@ char *read_packet(int *len) return io_buf; } - + /*********************************************************************** * S e n d i n g r e p l i e s * diff --git a/lib/erl_interface/test/all_SUITE_data/runner.c b/lib/erl_interface/test/all_SUITE_data/runner.c index a474c17722..038d651275 100644 --- a/lib/erl_interface/test/all_SUITE_data/runner.c +++ b/lib/erl_interface/test/all_SUITE_data/runner.c @@ -78,7 +78,7 @@ run_tests(char* argv0, TestCase test_cases[], unsigned number) } } - + /*********************************************************************** * * R e a d i n g p a c k e t s @@ -188,7 +188,7 @@ char *read_packet(int *len) return io_buf; } - + /*********************************************************************** * S e n d i n g r e p l i e s * diff --git a/lib/erl_interface/test/ei_accept_SUITE.erl b/lib/erl_interface/test/ei_accept_SUITE.erl index 48469e68dc..642809ea7a 100644 --- a/lib/erl_interface/test/ei_accept_SUITE.erl +++ b/lib/erl_interface/test/ei_accept_SUITE.erl @@ -155,7 +155,7 @@ start_einode(Einode, N, Host, Port) -> ok. - + %%% Interface functions for ei (erl_interface) functions. ei_connect_init(P, Num, Cookie, Creation) -> diff --git a/lib/erl_interface/test/erl_connect_SUITE.erl b/lib/erl_interface/test/erl_connect_SUITE.erl index bd54013402..c8becc760c 100644 --- a/lib/erl_interface/test/erl_connect_SUITE.erl +++ b/lib/erl_interface/test/erl_connect_SUITE.erl @@ -106,7 +106,7 @@ erl_reg_send(Config) when is_list(Config) -> ?line runner:recv_eot(P), ok. - + %%% Interface functions for erl_interface functions. erl_connect_init(P, Num, Cookie, Creation) -> diff --git a/lib/erl_interface/test/erl_eterm_SUITE.erl b/lib/erl_interface/test/erl_eterm_SUITE.erl index 10a27e48e3..100e9b6f68 100644 --- a/lib/erl_interface/test/erl_eterm_SUITE.erl +++ b/lib/erl_interface/test/erl_eterm_SUITE.erl @@ -108,7 +108,7 @@ end_per_group(_GroupName, Config) -> Config. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% 1. B a s i c t e s t s @@ -196,7 +196,7 @@ t_erl_free_compound(Config) when is_list(Config) -> ?line runner:test(?t_erl_free_compound), ok. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% 2. C o n s t r u c t i n g t e r m s @@ -521,7 +521,7 @@ t_erl_cons(Config) when is_list(Config) -> - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% 3. E x t r a c t i n g & i n f o f u n c t i o n s @@ -669,7 +669,7 @@ t_erl_element(Config) when is_list(Config) -> ok. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% 4. I / O l i s t f u n c t i o n s @@ -894,7 +894,7 @@ iolist_to_string(Port, Term) -> 'NULL' -> 'NULL' end. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% 5. M i s c e l l a n o u s T e s t s diff --git a/lib/erl_interface/test/erl_eterm_SUITE_data/eterm_test.c b/lib/erl_interface/test/erl_eterm_SUITE_data/eterm_test.c index 80d7f69520..94959187b9 100644 --- a/lib/erl_interface/test/erl_eterm_SUITE_data/eterm_test.c +++ b/lib/erl_interface/test/erl_eterm_SUITE_data/eterm_test.c @@ -269,7 +269,7 @@ TESTCASE(t_erl_free_compound) report(1); } - + /*********************************************************************** * * 2. C o n s t r u c t i n g t e r m s @@ -1047,7 +1047,7 @@ TESTCASE(t_erl_cons) - + /*********************************************************************** * * 3. E x t r a c t i n g & i n f o f u n c t i o n s @@ -1296,7 +1296,7 @@ TESTCASE(extractor_macros) } - + /*********************************************************************** * * 4. I / O l i s t f u n c t i o n s @@ -1393,7 +1393,7 @@ TESTCASE(t_erl_iolist_to_string) } } - + /*********************************************************************** * * 5. M i s c e l l a n o u s T e s t s diff --git a/lib/eunit/src/eunit_proc.erl b/lib/eunit/src/eunit_proc.erl index ec7d93fd48..03d1a18321 100644 --- a/lib/eunit/src/eunit_proc.erl +++ b/lib/eunit/src/eunit_proc.erl @@ -643,11 +643,11 @@ io_request({get_until, _Prompt, _M, _F, _As}, Buf) -> io_request({setopts, _Opts}, Buf) -> {ok, Buf}; io_request(getopts, Buf) -> - {error, {error, enotsup}, Buf}; + {{error, enotsup}, Buf}; io_request({get_geometry,columns}, Buf) -> - {error, {error, enotsup}, Buf}; + {{error, enotsup}, Buf}; io_request({get_geometry,rows}, Buf) -> - {error, {error, enotsup}, Buf}; + {{error, enotsup}, Buf}; io_request({requests, Reqs}, Buf) -> io_requests(Reqs, {ok, Buf}); io_request(_, Buf) -> @@ -657,3 +657,10 @@ io_requests([R | Rs], {ok, Buf}) -> io_requests(Rs, io_request(R, Buf)); io_requests(_, Result) -> Result. + +-ifdef(TEST). +io_error_test_() -> + [?_assertMatch({error, enotsup}, io:getopts()), + ?_assertMatch({error, enotsup}, io:columns()), + ?_assertMatch({error, enotsup}, io:rows())]. +-endif. diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index d1243b2325..d7d8a878c5 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -671,8 +671,9 @@ t_solve_remote(?function(Domain, Range), ET, R, C) -> {RT2, RR2} = t_solve_remote(Range, ET, R, C), {?function(RT1, RT2), RR1 ++ RR2}; t_solve_remote(?list(Types, Term, Size), ET, R, C) -> - {RT, RR} = t_solve_remote(Types, ET, R, C), - {?list(RT, Term, Size), RR}; + {RT1, RR1} = t_solve_remote(Types, ET, R, C), + {RT2, RR2} = t_solve_remote(Term, ET, R, C), + {?list(RT1, RT2, Size), RR1 ++ RR2}; t_solve_remote(?product(Types), ET, R, C) -> {RL, RR} = list_solve_remote(Types, ET, R, C), {?product(RL), RR}; @@ -1349,8 +1350,8 @@ t_maybe_improper_list() -> t_maybe_improper_list(_Content, ?unit) -> ?none; t_maybe_improper_list(?unit, _Termination) -> ?none; t_maybe_improper_list(Content, Termination) -> - %% Safety check - true = t_is_subtype(t_nil(), Termination), + %% Safety check: would be nice to have but does not work with remote types + %% true = t_is_subtype(t_nil(), Termination), ?list(Content, Termination, ?unknown_qual). -spec t_is_maybe_improper_list(erl_type()) -> boolean(). @@ -1365,8 +1366,8 @@ t_is_maybe_improper_list(_) -> false. %% t_improper_list(?unit, _Termination) -> ?none; %% t_improper_list(_Content, ?unit) -> ?none; %% t_improper_list(Content, Termination) -> -%% %% Safety check -%% false = t_is_subtype(t_nil(), Termination), +%% %% Safety check: would be nice to have but does not work with remote types +%% %% false = t_is_subtype(t_nil(), Termination), %% ?list(Content, Termination, ?any). -spec lift_list_to_pos_empty(erl_type()) -> erl_type(). diff --git a/lib/ic/c_src/Makefile.in b/lib/ic/c_src/Makefile.in index 6e65f06114..ed860ab73b 100644 --- a/lib/ic/c_src/Makefile.in +++ b/lib/ic/c_src/Makefile.in @@ -132,10 +132,8 @@ docs: _create_dirs := $(shell mkdir -p $(OBJDIR) $(LIBDIR)) $(LIBRARY): $(OBJ_FILES) - $(ar_verbose) - -$(AR) $(AR_OUT) $@ $(OBJ_FILES) - $(ranlib_verbose) - -$(RANLIB) $@ + -$(V_AR) $(AR_OUT) $@ $(OBJ_FILES) + -$(V_RANLIB) $@ $(OBJDIR)/%.o: %.c $(V_CC) $(CC_FLAGS) -c -o $@ $(ALL_CFLAGS) $< diff --git a/lib/inets/doc/src/httpc.xml b/lib/inets/doc/src/httpc.xml index d9a27e7d1e..db68cc3116 100644 --- a/lib/inets/doc/src/httpc.xml +++ b/lib/inets/doc/src/httpc.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2004</year><year>2012</year> + <year>2004</year><year>2013</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -440,7 +440,10 @@ apply(Module, Function, [ReplyInfo | Args]) <v>Profile = profile() | pid() (when started <c>stand_alone</c>)</v> </type> <desc> - <p>Cancels an asynchronous HTTP-request. </p> + <p>Cancels an asynchronous HTTP-request. Note this does not guarantee + that the request response will not be delivered, as it is asynchronous the + the request may already have been completed when the cancellation arrives. + </p> <marker id="set_options"></marker> </desc> diff --git a/lib/inets/src/http_client/httpc.erl b/lib/inets/src/http_client/httpc.erl index 4d7023a8e9..da9bbdd1ec 100644 --- a/lib/inets/src/http_client/httpc.erl +++ b/lib/inets/src/http_client/httpc.erl @@ -208,16 +208,8 @@ cancel_request(RequestId) -> cancel_request(RequestId, Profile) when is_atom(Profile) orelse is_pid(Profile) -> ?hcrt("cancel request", [{request_id, RequestId}, {profile, Profile}]), - ok = httpc_manager:cancel_request(RequestId, profile_name(Profile)), - receive - %% If the request was already fulfilled throw away the - %% answer as the request has been canceled. - {http, {RequestId, _}} -> - ok - after 0 -> - ok - end. - + httpc_manager:cancel_request(RequestId, profile_name(Profile)). + %%-------------------------------------------------------------------------- %% set_options(Options) -> ok | {error, Reason} @@ -241,14 +233,7 @@ set_options(Options, Profile) when is_atom(Profile) orelse is_pid(Profile) -> ?hcrt("set options", [{options, Options}, {profile, Profile}]), case validate_options(Options) of {ok, Opts} -> - try - begin - httpc_manager:set_options(Opts, profile_name(Profile)) - end - catch - exit:{noproc, _} -> - {error, inets_not_started} - end; + httpc_manager:set_options(Opts, profile_name(Profile)); {error, Reason} -> {error, Reason} end. @@ -343,8 +328,6 @@ store_cookies(SetCookieHeaders, Url, Profile) ok end catch - exit:{noproc, _} -> - {error, {not_started, Profile}}; error:{badmatch, Bad} -> {error, {parse_failed, Bad}} end. diff --git a/lib/inets/src/http_client/httpc_handler.erl b/lib/inets/src/http_client/httpc_handler.erl index 55794f57dc..80c8b2439e 100644 --- a/lib/inets/src/http_client/httpc_handler.erl +++ b/lib/inets/src/http_client/httpc_handler.erl @@ -32,7 +32,7 @@ start_link/4, %% connect_and_send/2, send/2, - cancel/3, + cancel/2, stream_next/1, info/1 ]). @@ -117,8 +117,8 @@ send(Request, Pid) -> %% Description: Cancels a request. Intended to be called by the httpc %% manager process. %%-------------------------------------------------------------------- -cancel(RequestId, Pid, From) -> - cast({cancel, RequestId, From}, Pid). +cancel(RequestId, Pid) -> + cast({cancel, RequestId}, Pid). %%-------------------------------------------------------------------- @@ -400,19 +400,17 @@ handle_call(info, _, State) -> %% handle_keep_alive_queue/2 on the other hand will just skip the %% request as if it was never issued as in this case the request will %% not have been sent. -handle_cast({cancel, RequestId, From}, +handle_cast({cancel, RequestId}, #state{request = #request{id = RequestId} = Request, profile_name = ProfileName, canceled = Canceled} = State) -> ?hcrv("cancel current request", [{request_id, RequestId}, {profile, ProfileName}, {canceled, Canceled}]), - httpc_manager:request_canceled(RequestId, ProfileName, From), - ?hcrv("canceled", []), {stop, normal, State#state{canceled = [RequestId | Canceled], request = Request#request{from = answer_sent}}}; -handle_cast({cancel, RequestId, From}, +handle_cast({cancel, RequestId}, #state{profile_name = ProfileName, request = #request{id = CurrId}, canceled = Canceled} = State) -> @@ -420,8 +418,6 @@ handle_cast({cancel, RequestId, From}, {curr_req_id, CurrId}, {profile, ProfileName}, {canceled, Canceled}]), - httpc_manager:request_canceled(RequestId, ProfileName, From), - ?hcrv("canceled", []), {noreply, State#state{canceled = [RequestId | Canceled]}}; handle_cast(stream_next, #state{session = Session} = State) -> @@ -521,19 +517,12 @@ handle_info({Proto, _Socket, Data}, activate_once(Session), {noreply, State#state{mfa = NewMFA}} catch - exit:_Exit -> - ?hcrd("data processing exit", [{exit, _Exit}]), + _:_Reason -> + ?hcrd("data processing exit", [{exit, _Reason}]), ClientReason = {could_not_parse_as_http, Data}, ClientErrMsg = httpc_response:error(Request, ClientReason), NewState = answer_request(Request, ClientErrMsg, State), - {stop, normal, NewState}; - error:_Error -> - ?hcrd("data processing error", [{error, _Error}]), - ClientReason = {could_not_parse_as_http, Data}, - ClientErrMsg = httpc_response:error(Request, ClientReason), - NewState = answer_request(Request, ClientErrMsg, State), {stop, normal, NewState} - end, ?hcri("data processed", [{final_result, FinalResult}]), FinalResult; @@ -1165,7 +1154,7 @@ handle_http_body(Body, #state{headers = Headers, handle_response(#state{status = new} = State) -> ?hcrd("handle response - status = new", []), - handle_response(try_to_enable_pipeline_or_keep_alive(State)); + handle_response(check_persistent(State)); handle_response(#state{request = Request, status = Status, @@ -1440,39 +1429,22 @@ is_keep_alive_enabled_server(_,_) -> is_keep_alive_connection(Headers, #session{client_close = ClientClose}) -> (not ((ClientClose) orelse httpc_response:is_server_closing(Headers))). -try_to_enable_pipeline_or_keep_alive( - #state{session = Session, - request = #request{method = Method}, +check_persistent( + #state{session = #session{type = Type} = Session, status_line = {Version, _, _}, headers = Headers, - profile_name = ProfileName} = State) -> - ?hcrd("try to enable pipeline or keep-alive", - [{version, Version}, - {headers, Headers}, - {session, Session}]), + profile_name = ProfileName} = State) -> case is_keep_alive_enabled_server(Version, Headers) andalso - is_keep_alive_connection(Headers, Session) of + is_keep_alive_connection(Headers, Session) of true -> - case (is_pipeline_enabled_client(Session) andalso - httpc_request:is_idempotent(Method)) of - true -> - insert_session(Session, ProfileName), - State#state{status = pipeline}; - false -> - insert_session(Session, ProfileName), - %% Make sure type is keep_alive in session - %% as it in this case might be pipeline - NewSession = Session#session{type = keep_alive}, - State#state{status = keep_alive, - session = NewSession} - end; + mark_persistent(ProfileName, Session), + State#state{status = Type}; false -> State#state{status = close} end. answer_request(#request{id = RequestId, from = From} = Request, Msg, - #state{session = Session, - timers = Timers, + #state{timers = Timers, profile_name = ProfileName} = State) -> ?hcrt("answer request", [{request, Request}, {msg, Msg}]), httpc_response:send(From, Msg), @@ -1482,19 +1454,14 @@ answer_request(#request{id = RequestId, from = From} = Request, Msg, Timer = {RequestId, TimerRef}, cancel_timer(TimerRef, {timeout, Request#request.id}), httpc_manager:request_done(RequestId, ProfileName), - NewSession = maybe_make_session_available(ProfileName, Session), Timers2 = Timers#timers{request_timers = lists:delete(Timer, RequestTimers)}, State#state{request = Request#request{from = answer_sent}, - session = NewSession, timers = Timers2}. -maybe_make_session_available(ProfileName, - #session{available = false} = Session) -> - update_session(ProfileName, Session, #session.available, true), - Session#session{available = true}; -maybe_make_session_available(_ProfileName, Session) -> - Session. +mark_persistent(ProfileName, Session) -> + update_session(ProfileName, Session, #session.persistent, true), + Session#session{persistent = true}. cancel_timers(#timers{request_timers = ReqTmrs, queue_timer = QTmr}) -> cancel_timer(QTmr, timeout_queue), diff --git a/lib/inets/src/http_client/httpc_internal.hrl b/lib/inets/src/http_client/httpc_internal.hrl index 30e2742e9d..d5b3dd2a2a 100644 --- a/lib/inets/src/http_client/httpc_internal.hrl +++ b/lib/inets/src/http_client/httpc_internal.hrl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2012. All Rights Reserved. +%% Copyright Ericsson AB 2005-2013. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -143,8 +143,8 @@ %% true | false %% This will be true, when a response has been received for - %% the first request. See type above. - available = false + %% the first request and the server has not closed the connection + persistent = false }). diff --git a/lib/inets/src/http_client/httpc_manager.erl b/lib/inets/src/http_client/httpc_manager.erl index c45dcab802..a3ed371e61 100644 --- a/lib/inets/src/http_client/httpc_manager.erl +++ b/lib/inets/src/http_client/httpc_manager.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2002-2012. All Rights Reserved. +%% Copyright Ericsson AB 2002-2013. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -29,7 +29,6 @@ start_link/3, request/2, cancel_request/2, - request_canceled/3, request_done/2, retry_request/2, redirect_request/2, @@ -144,22 +143,7 @@ redirect_request(Request, ProfileName) -> %%-------------------------------------------------------------------- cancel_request(RequestId, ProfileName) -> - call(ProfileName, {cancel_request, RequestId}). - - -%%-------------------------------------------------------------------- -%% Function: request_canceled(RequestId, ProfileName) -> ok -%% RequestId - ref() -%% ProfileName = atom() -%% -%% Description: Confirms that a request has been canceld. Intended to -%% be called by the httpc handler process. -%%-------------------------------------------------------------------- - -request_canceled(RequestId, ProfileName, From) -> - gen_server:reply(From, ok), - cast(ProfileName, {request_canceled, RequestId}). - + cast(ProfileName, {cancel_request, RequestId}). %%-------------------------------------------------------------------- %% Function: request_done(RequestId, ProfileName) -> ok @@ -467,33 +451,13 @@ do_init(ProfileName, CookiesDir) -> %%-------------------------------------------------------------------- handle_call({request, Request}, _, State) -> ?hcri("request", [{request, Request}]), - case (catch handle_request(Request, State)) of + case (catch handle_request(Request, State, false)) of {reply, Msg, NewState} -> {reply, Msg, NewState}; Error -> {stop, Error, httpc_response:error(Request, Error), State} end; -handle_call({cancel_request, RequestId}, From, - #state{handler_db = HandlerDb} = State) -> - ?hcri("cancel_request", [{request_id, RequestId}]), - case ets:lookup(HandlerDb, RequestId) of - [] -> - %% The request has allready compleated make sure - %% it is deliverd to the client process queue so - %% it can be thrown away by httpc:cancel_request - %% This delay is hopfully a temporary workaround. - %% Note that it will not not delay the manager, - %% only the client that called httpc:cancel_request - timer:apply_after(?DELAY, gen_server, reply, [From, ok]), - {noreply, State}; - [{_, Pid, _}] -> - httpc_handler:cancel(RequestId, Pid, From), - {noreply, - State#state{cancel = - [{RequestId, Pid, From} | State#state.cancel]}} - end; - handle_call(reset_cookies, _, #state{cookie_db = CookieDb} = State) -> ?hcrv("reset cookies", []), httpc_cookie:reset_db(CookieDb), @@ -547,7 +511,7 @@ handle_cast({retry_or_redirect_request, {Time, Request}}, {noreply, State}; handle_cast({retry_or_redirect_request, Request}, State) -> - case (catch handle_request(Request, State)) of + case (catch handle_request(Request, State, true)) of {reply, {ok, _}, NewState} -> {noreply, NewState}; Error -> @@ -555,19 +519,19 @@ handle_cast({retry_or_redirect_request, Request}, State) -> {stop, Error, State} end; -handle_cast({request_canceled, RequestId}, State) -> - ?hcrv("request canceled", [{request_id, RequestId}]), - ets:delete(State#state.handler_db, RequestId), - case lists:keysearch(RequestId, 1, State#state.cancel) of - {value, Entry = {RequestId, _, From}} -> - ?hcrt("found in cancel", [{from, From}]), - {noreply, - State#state{cancel = lists:delete(Entry, State#state.cancel)}}; - Else -> - ?hcrt("not found in cancel", [{else, Else}]), - {noreply, State} +handle_cast({cancel_request, RequestId}, + #state{handler_db = HandlerDb} = State) -> + case ets:lookup(HandlerDb, RequestId) of + [] -> + %% Request already compleated nothing to + %% cancel + {noreply, State}; + [{_, Pid, _}] -> + httpc_handler:cancel(RequestId, Pid), + ets:delete(State#state.handler_db, RequestId), + {noreply, State} end; - + handle_cast({request_done, RequestId}, State) -> ?hcrv("request done", [{request_id, RequestId}]), ets:delete(State#state.handler_db, RequestId), @@ -629,22 +593,8 @@ handle_info({'EXIT', _, _}, State) -> %% Handled in DOWN {noreply, State}; handle_info({'DOWN', _, _, Pid, _}, State) -> - ets:match_delete(State#state.handler_db, {'_', Pid, '_'}), - - %% If there where any canceled request, handled by the - %% the process that now has terminated, the - %% cancelation can be viewed as sucessfull! - NewCanceldList = - lists:foldl(fun(Entry = {_, HandlerPid, From}, Acc) -> - case HandlerPid of - Pid -> - gen_server:reply(From, ok), - lists:delete(Entry, Acc); - _ -> - Acc - end - end, State#state.cancel, State#state.cancel), - {noreply, State#state{cancel = NewCanceldList}}; + ets:match_delete(State#state.handler_db, {'_', Pid, '_'}), + {noreply, State}; handle_info(Info, State) -> Report = io_lib:format("Unknown message in " "httpc_manager:handle_info ~p~n", [Info]), @@ -774,7 +724,7 @@ get_handler_info(Tab) -> handle_request(#request{settings = #http_options{version = "HTTP/0.9"}} = Request, - State) -> + State, _) -> %% Act as an HTTP/0.9 client that does not know anything %% about persistent connections @@ -787,7 +737,7 @@ handle_request(#request{settings = handle_request(#request{settings = #http_options{version = "HTTP/1.0"}} = Request, - State) -> + State, _) -> %% Act as an HTTP/1.0 client that does not %% use persistent connections @@ -798,13 +748,13 @@ handle_request(#request{settings = start_handler(NewRequest#request{headers = NewHeaders}, State), {reply, {ok, NewRequest#request.id}, State}; -handle_request(Request, State = #state{options = Options}) -> +handle_request(Request, State = #state{options = Options}, Retry) -> NewRequest = handle_cookies(generate_request_id(Request), State), SessionType = session_type(Options), case select_session(Request#request.method, Request#request.address, - Request#request.scheme, SessionType, State) of + Request#request.scheme, SessionType, State, Retry) of {ok, HandlerPid} -> pipeline_or_keep_alive(NewRequest, HandlerPid, State); no_connection -> @@ -828,6 +778,7 @@ start_handler(#request{id = Id, #state{profile_name = ProfileName, handler_db = HandlerDb, options = Options}) -> + ClientClose = httpc_request:is_client_closing(Request#request.headers), {ok, Pid} = case is_inets_manager() of true -> @@ -838,13 +789,18 @@ start_handler(#request{id = Id, end, HandlerInfo = {Id, Pid, From}, ets:insert(HandlerDb, HandlerInfo), + insert_session(#session{id = {Request#request.address, Pid}, + scheme = Request#request.scheme, + client_close = ClientClose, + type = session_type(Options) + }, ProfileName), erlang:monitor(process, Pid). select_session(Method, HostPort, Scheme, SessionType, #state{options = #options{max_pipeline_length = MaxPipe, max_keep_alive_length = MaxKeepAlive}, - session_db = SessionDb}) -> + session_db = SessionDb}, Retry) -> ?hcrd("select session", [{session_type, SessionType}, {max_pipeline_length, MaxPipe}, {max_keep_alive_length, MaxKeepAlive}]), @@ -857,19 +813,29 @@ select_session(Method, HostPort, Scheme, SessionType, %% client_close, scheme and type specified. %% The fields id (part of: HandlerPid) and queue_length %% specified. - Pattern = #session{id = {HostPort, '$1'}, - client_close = false, - scheme = Scheme, - queue_length = '$2', - type = SessionType, - available = true, - _ = '_'}, + Pattern = case (Retry andalso SessionType == pipeline) of + true -> + #session{id = {HostPort, '$1'}, + client_close = false, + scheme = Scheme, + queue_length = '$2', + type = SessionType, + persistent = true, + _ = '_'}; + false -> + #session{id = {HostPort, '$1'}, + client_close = false, + scheme = Scheme, + queue_length = '$2', + type = SessionType, + _ = '_'} + end, %% {'_', {HostPort, '$1'}, false, Scheme, '_', '$2', SessionTyp}, Candidates = ets:match(SessionDb, Pattern), ?hcrd("select session", [{host_port, HostPort}, {scheme, Scheme}, {type, SessionType}, - {candidates, Candidates}]), + {candidates, Candidates}]), select_session(Candidates, MaxKeepAlive, MaxPipe, SessionType); false -> no_connection diff --git a/lib/inets/src/http_server/httpd_conf.erl b/lib/inets/src/http_server/httpd_conf.erl index b3ca13e2fe..27446ca7fe 100644 --- a/lib/inets/src/http_server/httpd_conf.erl +++ b/lib/inets/src/http_server/httpd_conf.erl @@ -798,6 +798,8 @@ store({log_format, LogFormat}, _ConfigList) store({server_tokens, ServerTokens} = Entry, _ConfigList) -> Server = server(ServerTokens), {ok, [Entry, {server, Server}]}; +store({keep_alive_timeout, KeepAliveTimeout}, _ConfigList) -> + {ok, {keep_alive_timeout, KeepAliveTimeout * 1000}}; store(ConfigListEntry, _ConfigList) -> {ok, ConfigListEntry}. diff --git a/lib/inets/src/http_server/mod_cgi.erl b/lib/inets/src/http_server/mod_cgi.erl index f1b73810e6..d933b0a4ba 100644 --- a/lib/inets/src/http_server/mod_cgi.erl +++ b/lib/inets/src/http_server/mod_cgi.erl @@ -131,9 +131,9 @@ store({script_nocache, Value} = Conf, _) {ok, Conf}; store({script_nocache, Value}, _) -> {error, {wrong_type, {script_nocache, Value}}}; -store({script_timeout, Value} = Conf, _) +store({script_timeout, Value}, _) when is_integer(Value), Value >= 0 -> - {ok, Conf}; + {ok, {script_timeout, Value * 1000}}; store({script_timeout, Value}, _) -> {error, {wrong_type, {script_timeout, Value}}}. @@ -238,7 +238,7 @@ send_request_body_to_script(ModData, Port) -> end. deliver_webpage(#mod{config_db = Db} = ModData, Port) -> - Timeout = cgi_timeout(Db), + Timeout = script_timeout(Db), case receive_headers(Port, httpd_cgi, parse_headers, [<<>>, [], []], Timeout) of {Headers, Body} -> @@ -341,8 +341,8 @@ script_elements(#mod{method = "PUT", entity_body = Body}, _) -> script_elements(_, _) -> []. -cgi_timeout(Db) -> - httpd_util:lookup(Db, cgi_timeout, ?DEFAULT_CGI_TIMEOUT). +script_timeout(Db) -> + httpd_util:lookup(Db, script_timeout, ?DEFAULT_CGI_TIMEOUT). %% Convert error to printable string %% diff --git a/lib/inets/test/httpc_SUITE.erl b/lib/inets/test/httpc_SUITE.erl index 0c35f284f7..818edc12ac 100644 --- a/lib/inets/test/httpc_SUITE.erl +++ b/lib/inets/test/httpc_SUITE.erl @@ -277,9 +277,6 @@ trace(Config) when is_list(Config) -> pipeline(Config) when is_list(Config) -> Request = {url(group_name(Config), "/dummy.html", Config), []}, {ok, _} = httpc:request(get, Request, [], [], pipeline), - - %% Make sure pipeline session is registerd - test_server:sleep(4000), keep_alive_requests(Request, pipeline). %%-------------------------------------------------------------------- @@ -287,9 +284,6 @@ pipeline(Config) when is_list(Config) -> persistent_connection(Config) when is_list(Config) -> Request = {url(group_name(Config), "/dummy.html", Config), []}, {ok, _} = httpc:request(get, Request, [], [], persistent), - - %% Make sure pipeline session is registerd - test_server:sleep(4000), keep_alive_requests(Request, persistent). %%------------------------------------------------------------------------- @@ -311,13 +305,8 @@ async(Config) when is_list(Config) -> {ok, NewRequestId} = httpc:request(get, Request, [], [{sync, false}]), - ok = httpc:cancel_request(NewRequestId), - receive - {http, {NewRequestId, _}} -> - ct:fail(http_cancel_request_failed) - after 3000 -> - ok - end. + ok = httpc:cancel_request(NewRequestId). + %%------------------------------------------------------------------------- save_to_file() -> [{doc, "Test to save the http body to a file"}]. @@ -1149,7 +1138,7 @@ receive_replys([ID|IDs]) -> {http, {ID, {{_, 200, _}, [_|_], _}}} -> receive_replys(IDs); {http, {Other, {{_, 200, _}, [_|_], _}}} -> - ct:fail({recived_canceld_id, Other}) + ct:pal({recived_canceld_id, Other}) end. %% Perform a synchronous stop diff --git a/lib/inets/test/httpd_basic_SUITE.erl b/lib/inets/test/httpd_basic_SUITE.erl index b1fe373cff..2d06f3e70c 100644 --- a/lib/inets/test/httpd_basic_SUITE.erl +++ b/lib/inets/test/httpd_basic_SUITE.erl @@ -38,7 +38,9 @@ all() -> erl_script_nocache_opt, script_nocache, escaped_url_in_error_body, - slowdose + script_timeout, + slowdose, + keep_alive_timeout ]. groups() -> @@ -80,16 +82,19 @@ DUMMY DummyFile = filename:join([PrivDir,"dummy.html"]), CgiDir = filename:join(PrivDir, "cgi-bin"), ok = file:make_dir(CgiDir), - Cgi = case test_server:os_type() of - {win32, _} -> - "printenv.bat"; - _ -> - "printenv.sh" - end, - inets_test_lib:copy_file(Cgi, DataDir, CgiDir), - AbsCgi = filename:join([CgiDir, Cgi]), - {ok, FileInfo} = file:read_file_info(AbsCgi), - ok = file:write_file_info(AbsCgi, FileInfo#file_info{mode = 8#00755}), + {CgiPrintEnv, CgiSleep} = case test_server:os_type() of + {win32, _} -> + {"printenv.bat", "cgi_sleep.exe"}; + _ -> + {"printenv.sh", "cgi_sleep"} + end, + lists:foreach( + fun(Cgi) -> + inets_test_lib:copy_file(Cgi, DataDir, CgiDir), + AbsCgi = filename:join([CgiDir, Cgi]), + {ok, FileInfo} = file:read_file_info(AbsCgi), + ok = file:write_file_info(AbsCgi, FileInfo#file_info{mode = 8#00755}) + end, [CgiPrintEnv, CgiSleep]), {ok, Fd} = file:open(DummyFile, [write]), ok = file:write(Fd, Dummy), ok = file:close(Fd), @@ -100,7 +105,8 @@ DUMMY {document_root, PrivDir}, {bind_address, "localhost"}], - [{httpd_conf, HttpdConf}, {cgi_dir, CgiDir}, {cgi_script, Cgi} | Config]. + [{httpd_conf, HttpdConf}, {cgi_dir, CgiDir}, + {cgi_printenv, CgiPrintEnv}, {cgi_sleep, CgiSleep} | Config]. %%-------------------------------------------------------------------- %% Function: end_per_suite(Config) -> _ @@ -235,7 +241,7 @@ script_nocache(Config) when is_list(Config) -> verify_script_nocache(Config, CgiNoCache, EsiNoCache, CgiOption, EsiOption) -> HttpdConf = ?config(httpd_conf, Config), - CgiScript = ?config(cgi_script, Config), + CgiScript = ?config(cgi_printenv, Config), CgiDir = ?config(cgi_dir, Config), {ok, Pid} = inets:start(httpd, [{port, 0}, {script_alias, @@ -363,6 +369,63 @@ escaped_url_in_error_body(Config) when is_list(Config) -> inets:stop(httpd, Pid), tsp("escaped_url_in_error_body -> done"), ok. + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- + +keep_alive_timeout(doc) -> + ["Test the keep_alive_timeout option"]; +keep_alive_timeout(suite) -> + []; +keep_alive_timeout(Config) when is_list(Config) -> + HttpdConf = ?config(httpd_conf, Config), + {ok, Pid} = inets:start(httpd, [{port, 0}, {keep_alive, true}, {keep_alive_timeout, 2} | HttpdConf]), + Info = httpd:info(Pid), + Port = proplists:get_value(port, Info), + _Address = proplists:get_value(bind_address, Info), + {ok, S} = gen_tcp:connect("localhost", Port, []), + receive + after 3000 -> + {error, closed} = gen_tcp:send(S, "hey") + end, + inets:stop(httpd, Pid). + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- + +script_timeout(doc) -> + ["Test the httpd script_timeout option"]; +script_timeout(suite) -> + []; +script_timeout(Config) when is_list(Config) -> + verify_script_timeout(Config, 20, 200), + verify_script_timeout(Config, 5, 403), + ok. + +verify_script_timeout(Config, ScriptTimeout, StatusCode) -> + HttpdConf = ?config(httpd_conf, Config), + CgiScript = ?config(cgi_sleep, Config), + CgiDir = ?config(cgi_dir, Config), + {ok, Pid} = inets:start(httpd, [{port, 0}, + {script_alias, + {"/cgi-bin/", CgiDir ++ "/"}}, + {script_timeout, ScriptTimeout} + | HttpdConf]), + Info = httpd:info(Pid), + Port = proplists:get_value(port, Info), + Address = proplists:get_value(bind_address, Info), + ok = httpd_test_lib:verify_request(ip_comm, Address, Port, node(), + "GET /cgi-bin/" ++ CgiScript ++ + " HTTP/1.0\r\n\r\n", + [{statuscode, StatusCode}, + {version, "HTTP/1.0"}]), + inets:stop(httpd, Pid). + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- + slowdose(doc) -> ["Testing minimum bytes per second option"]; slowdose(Config) when is_list(Config) -> diff --git a/lib/inets/test/httpd_basic_SUITE_data/Makefile.src b/lib/inets/test/httpd_basic_SUITE_data/Makefile.src new file mode 100644 index 0000000000..9da2ed583f --- /dev/null +++ b/lib/inets/test/httpd_basic_SUITE_data/Makefile.src @@ -0,0 +1,14 @@ +CC = @CC@ +LD = @LD@ +CFLAGS = @CFLAGS@ -I@erl_include@ @DEFS@ +CROSSLDFLAGS = @CROSSLDFLAGS@ + +PROGS = cgi_sleep@exe@ + +all: $(PROGS) + +cgi_sleep@exe@: cgi_sleep@obj@ + $(LD) $(CROSSLDFLAGS) -o cgi_sleep cgi_sleep@obj@ @LIBS@ + +cgi_sleep@obj@: cgi_sleep.c + $(CC) -c -o cgi_sleep@obj@ $(CFLAGS) cgi_sleep.c diff --git a/lib/inets/test/httpd_basic_SUITE_data/cgi_sleep.c b/lib/inets/test/httpd_basic_SUITE_data/cgi_sleep.c new file mode 100644 index 0000000000..126bb23987 --- /dev/null +++ b/lib/inets/test/httpd_basic_SUITE_data/cgi_sleep.c @@ -0,0 +1,26 @@ +#include <stdlib.h> +#include <stdio.h> + +#ifdef __WIN32__ +#include <windows.h> +#include <fcntl.h> +#include <io.h> +#else +#include <unistd.h> +#endif + +int main(void) +{ + unsigned int seconds = 10; + +#ifdef __WIN32__ + Sleep(seconds * 1000); + _setmode(_fileno(stdout), _O_BINARY); +#else + sleep(seconds); +#endif + + printf("Content-type: text/plain\r\n\r\n"); + printf("Slept for %u seconds.\r\n", seconds); + exit(EXIT_SUCCESS); +} diff --git a/lib/kernel/doc/src/gen_sctp.xml b/lib/kernel/doc/src/gen_sctp.xml index 7ea58fffff..33f1c20608 100644 --- a/lib/kernel/doc/src/gen_sctp.xml +++ b/lib/kernel/doc/src/gen_sctp.xml @@ -322,7 +322,7 @@ <p> Branch off an existing association <anno>Assoc</anno> in a socket <anno>Socket</anno> of type <c>seqpacket</c> - (one-to-may style) into + (one-to-many style) into a new socket <anno>NewSocket</anno> of type <c>stream</c> (one-to-one style). </p> diff --git a/lib/kernel/src/gen_sctp.erl b/lib/kernel/src/gen_sctp.erl index 58d84ae924..067e07304d 100644 --- a/lib/kernel/src/gen_sctp.erl +++ b/lib/kernel/src/gen_sctp.erl @@ -423,7 +423,11 @@ error_string(9) -> error_string(10) -> "Cookie Received While Shutting Down"; error_string(11) -> + "Restart of an Association with New Addresses"; +error_string(12) -> "User Initiated Abort"; +error_string(13) -> + "Protocol Violation"; %% For more info on principal SCTP error codes: phone +44 7981131933 error_string(N) when is_integer(N) -> unknown_error; diff --git a/lib/kernel/src/inet.erl b/lib/kernel/src/inet.erl index 27f085c3aa..d4c78505da 100644 --- a/lib/kernel/src/inet.erl +++ b/lib/kernel/src/inet.erl @@ -120,6 +120,17 @@ 'addr' | 'broadaddr' | 'dstaddr' | 'mtu' | 'netmask' | 'flags' |'hwaddr'. +-type if_getopt_result() :: + {'addr', ip_address()} | + {'broadaddr', ip_address()} | + {'dstaddr', ip_address()} | + {'mtu', non_neg_integer()} | + {'netmask', ip_address()} | + {'flags', ['up' | 'down' | 'broadcast' | 'no_broadcast' | + 'pointtopoint' | 'no_pointtopoint' | + 'running' | 'multicast' | 'loopback']} | + {'hwaddr', ether_address()}. + -type address_family() :: 'inet' | 'inet6'. -type socket_protocol() :: 'tcp' | 'udp' | 'sctp'. -type socket_type() :: 'stream' | 'dgram' | 'seqpacket'. @@ -266,13 +277,13 @@ getiflist() -> -spec ifget(Socket :: socket(), Name :: string() | atom(), Opts :: [if_getopt()]) -> - {'ok', [if_setopt()]} | {'error', posix()}. + {'ok', [if_getopt_result()]} | {'error', posix()}. ifget(Socket, Name, Opts) -> prim_inet:ifget(Socket, Name, Opts). -spec ifget(Name :: string() | atom(), Opts :: [if_getopt()]) -> - {'ok', [if_setopt()]} | {'error', posix()}. + {'ok', [if_getopt_result()]} | {'error', posix()}. ifget(Name, Opts) -> withsocket(fun(S) -> prim_inet:ifget(S, Name, Opts) end). diff --git a/lib/observer/doc/src/ttb.xml b/lib/observer/doc/src/ttb.xml index 4e63aecbf2..1453bbdf10 100644 --- a/lib/observer/doc/src/ttb.xml +++ b/lib/observer/doc/src/ttb.xml @@ -105,8 +105,9 @@ ttb:p(all, call)</code> <v>Nodes = atom() | [atom()] | all | existing | new</v> <v>Opts = Opt | [Opt]</v> <v>Opt = {file,Client} | {handler, FormatHandler} | {process_info,PI} | - shell | {shell, ShellSpec} | {timer, TimerSpec} | {overload, {MSec, Module, Function}} - | {flush, MSec} | resume | {resume, FetchTimeout}</v> + shell | {shell, ShellSpec} | {timer, TimerSpec} | + {overload_check, {MSec, Module, Function}} | + {flush, MSec} | resume | {resume, FetchTimeout}</v> <v>TimerSpec = MSec | {MSec, StopOpts}</v> <v>MSec = FetchTimeout = integer()</v> <v>Module = Function = atom() </v> @@ -158,7 +159,7 @@ ttb:p(all, call)</code> network communication are always present. The timer starts after <c>ttb:p/2</c> is issued, so you can set up your trace patterns before. </p> - <p>The <c>overload</c> option allows to enable overload + <p>The <c>overload_check</c> option allows to enable overload checking on the nodes under trace. <c>Module:Function(check)</c> is performed each <c>MSec</c> milliseconds. If the check returns <c>true</c>, the tracing is disabled on a given node.<br/> diff --git a/lib/orber/test/multi_ORB_SUITE.erl b/lib/orber/test/multi_ORB_SUITE.erl index 3c1ffd59d3..41a309ff16 100644 --- a/lib/orber/test/multi_ORB_SUITE.erl +++ b/lib/orber/test/multi_ORB_SUITE.erl @@ -75,8 +75,6 @@ close_connections_local_interface_ctx_override_api/1, ssl_1_multi_orber_generation_3_api/1, ssl_2_multi_orber_generation_3_api/1, ssl_reconfigure_generation_3_api/1, - ssl_1_multi_orber_generation_3_api_old/1, ssl_2_multi_orber_generation_3_api_old/1, - ssl_reconfigure_generation_3_api_old/1, close_connections_alt_iiop_addr_api/1, close_connections_multiple_profiles_api/1]). @@ -137,13 +135,10 @@ cases() -> setup_multi_connection_timeout_attempts_api, setup_multi_connection_timeout_random_api, ssl_1_multi_orber_api, - ssl_1_multi_orber_generation_3_api_old, ssl_1_multi_orber_generation_3_api, ssl_2_multi_orber_api, - ssl_2_multi_orber_generation_3_api_old, ssl_2_multi_orber_generation_3_api, ssl_reconfigure_api, - ssl_reconfigure_generation_3_api_old, ssl_reconfigure_generation_3_api]. %%----------------------------------------------------------------- @@ -155,10 +150,7 @@ init_per_testcase(TC,Config) TC =:= ssl_reconfigure_api -> init_ssl(Config); init_per_testcase(TC,Config) - when TC =:= ssl_1_multi_orber_generation_3_api_old; - TC =:= ssl_2_multi_orber_generation_3_api_old; - TC =:= ssl_reconfigure_generation_3_api_old; - TC =:= ssl_1_multi_orber_generation_3_api; + when TC =:= ssl_1_multi_orber_generation_3_api; TC =:= ssl_2_multi_orber_generation_3_api; TC =:= ssl_reconfigure_generation_3_api -> init_ssl_3(Config); @@ -1632,22 +1624,6 @@ ssl_1_multi_orber_api(_Config) -> ssl_suite(ServerOptions, ClientOptions). -ssl_1_multi_orber_generation_3_api_old(doc) -> ["SECURE MULTI ORB API tests (SSL depth 1)", - "This case set up two secure orbs and test if they can", - "communicate. The case also test to access one of the", - "secure orbs which must raise a NO_PERMISSION exception."]; -ssl_1_multi_orber_generation_3_api_old(suite) -> []; -ssl_1_multi_orber_generation_3_api_old(_Config) -> - - ServerOptions = orber_test_lib:get_options_old(iiop_ssl, server, - 1, [{ssl_generation, 3}, - {iiop_ssl_port, 0}]), - ClientOptions = orber_test_lib:get_options_old(iiop_ssl, client, - 1, [{ssl_generation, 3}, - {iiop_ssl_port, 0}]), - ssl_suite(ServerOptions, ClientOptions). - - ssl_1_multi_orber_generation_3_api(doc) -> ["SECURE MULTI ORB API tests (SSL depth 1)", "This case set up two secure orbs and test if they can", "communicate. The case also test to access one of the", @@ -1681,22 +1657,6 @@ ssl_2_multi_orber_api(_Config) -> ssl_suite(ServerOptions, ClientOptions). -ssl_2_multi_orber_generation_3_api_old(doc) -> ["SECURE MULTI ORB API tests (SSL depth 2)", - "This case set up two secure orbs and test if they can", - "communicate. The case also test to access one of the", - "secure orbs which must raise a NO_PERMISSION exception."]; -ssl_2_multi_orber_generation_3_api_old(suite) -> []; -ssl_2_multi_orber_generation_3_api_old(_Config) -> - - ServerOptions = orber_test_lib:get_options_old(iiop_ssl, server, - 2, [{ssl_generation, 3}, - {iiop_ssl_port, 0}]), - ClientOptions = orber_test_lib:get_options_old(iiop_ssl, client, - 2, [{ssl_generation, 3}, - {iiop_ssl_port, 0}]), - ssl_suite(ServerOptions, ClientOptions). - - ssl_2_multi_orber_generation_3_api(doc) -> ["SECURE MULTI ORB API tests (SSL depth 2)", "This case set up two secure orbs and test if they can", "communicate. The case also test to access one of the", @@ -1724,11 +1684,6 @@ ssl_reconfigure_api(_Config) -> ssl_reconfigure_old([]). -ssl_reconfigure_generation_3_api_old(doc) -> ["SECURE MULTI ORB API tests (SSL depth 2)", - "This case set up two secure orbs and test if they can", - "communicate. The case also test to access one of the", - "secure orbs which must raise a NO_PERMISSION exception."]; -ssl_reconfigure_generation_3_api_old(suite) -> []; ssl_reconfigure_generation_3_api_old(_Config) -> ssl_reconfigure_old([{ssl_generation, 3}]). diff --git a/lib/orber/test/orber_nat_SUITE.erl b/lib/orber/test/orber_nat_SUITE.erl index ee31b162c2..a21bd4d499 100644 --- a/lib/orber/test/orber_nat_SUITE.erl +++ b/lib/orber/test/orber_nat_SUITE.erl @@ -57,7 +57,6 @@ nat_ip_address_local/1, nat_ip_address_local_local/1, nat_iiop_port/1, nat_iiop_port_local/1, nat_iiop_port_local_local/1, - nat_iiop_ssl_port_old/1, nat_iiop_ssl_port_local_old/1, nat_iiop_ssl_port/1, nat_iiop_ssl_port_local/1]). @@ -93,8 +92,6 @@ cases() -> nat_iiop_port_local, nat_ip_address_local_local, nat_iiop_port_local_local, - nat_iiop_ssl_port_old, - nat_iiop_ssl_port_local_old, nat_iiop_ssl_port, nat_iiop_ssl_port_local]. @@ -103,9 +100,7 @@ cases() -> %%----------------------------------------------------------------- init_per_testcase(TC, Config) when TC =:= nat_iiop_ssl_port; - TC =:= nat_iiop_ssl_port_local; - TC =:= nat_iiop_ssl_port_old; - TC =:= nat_iiop_ssl_port_local_old -> + TC =:= nat_iiop_ssl_port_local -> case ?config(crypto_started, Config) of true -> case orber_test_lib:ssl_version() of @@ -291,106 +286,6 @@ nat_iiop_port_local_local(_Config) -> %% API tests for ORB to ORB, ssl security depth 1 %%----------------------------------------------------------------- -nat_iiop_ssl_port_old(doc) -> ["SECURE MULTI ORB API tests (SSL depth 1)", - "Make sure NAT works for SSL"]; -nat_iiop_ssl_port_old(suite) -> []; -nat_iiop_ssl_port_old(_Config) -> - - IP = orber_test_lib:get_host(), - ServerOptions = orber_test_lib:get_options_old(iiop_ssl, server, - 1, [{iiop_ssl_port, 0}, - {flags, ?ORB_ENV_ENABLE_NAT}, - {ip_address, IP}]), - ClientOptions = orber_test_lib:get_options_old(iiop_ssl, client, - 1, [{iiop_ssl_port, 0}]), - {ok, ServerNode, _ServerHost} = - ?match({ok,_,_}, orber_test_lib:js_node(ServerOptions)), - ServerPort = orber_test_lib:remote_apply(ServerNode, orber, iiop_port, []), - SSLServerPort = orber_test_lib:remote_apply(ServerNode, orber, iiop_ssl_port, []), - NATSSLServerPort = SSLServerPort+1, - {ok, Ref} = ?match({ok, _}, - orber_test_lib:remote_apply(ServerNode, orber, - add_listen_interface, - [IP, ssl, NATSSLServerPort])), - orber_test_lib:remote_apply(ServerNode, orber_env, configure_override, - [nat_iiop_ssl_port, - {local, NATSSLServerPort, [{4001, 43}]}]), - - {ok, ClientNode, _ClientHost} = - ?match({ok,_,_}, orber_test_lib:js_node(ClientOptions)), - ?match(ok, orber_test_lib:remote_apply(ServerNode, orber_test_lib, - install_test_data, - [ssl])), - - IOR1 = ?match(#'IOP_IOR'{}, - orber_test_lib:remote_apply(ClientNode, corba, - string_to_object, - ["corbaname::1.2@"++IP++":"++ - integer_to_list(ServerPort)++"/NameService#mamba"])), - - ?match({'external', {_IP, _Port, _ObjectKey, _Counter, _TP, - #host_data{protocol = ssl, - ssl_data = #'SSLIOP_SSL'{port = NATSSLServerPort}}}}, - iop_ior:get_key(IOR1)), - ?match(ok, orber_test_lib:remote_apply(ServerNode, orber_test_lib, - uninstall_test_data, - [ssl])), - ?match(ok, - orber_test_lib:remote_apply(ServerNode, orber, - remove_listen_interface, [Ref])), - ok. - -nat_iiop_ssl_port_local_old(doc) -> ["SECURE MULTI ORB API tests (SSL depth 1)", - "Make sure NAT works for SSL"]; -nat_iiop_ssl_port_local_old(suite) -> []; -nat_iiop_ssl_port_local_old(_Config) -> - - IP = orber_test_lib:get_host(), - ServerOptions = orber_test_lib:get_options_old(iiop_ssl, server, - 1, [{iiop_ssl_port, 0}, - {flags, - (?ORB_ENV_LOCAL_INTERFACE bor - ?ORB_ENV_ENABLE_NAT)}, - {ip_address, IP}]), - ClientOptions = orber_test_lib:get_options_old(iiop_ssl, client, - 1, [{iiop_ssl_port, 0}]), - {ok, ServerNode, _ServerHost} = - ?match({ok,_,_}, orber_test_lib:js_node(ServerOptions)), - ServerPort = orber_test_lib:remote_apply(ServerNode, orber, iiop_port, []), - SSLServerPort = orber_test_lib:remote_apply(ServerNode, orber, iiop_ssl_port, []), - NATSSLServerPort = SSLServerPort+1, - {ok, Ref} = ?match({ok, _}, - orber_test_lib:remote_apply(ServerNode, orber, - add_listen_interface, - [IP, ssl, NATSSLServerPort])), - orber_test_lib:remote_apply(ServerNode, orber_env, configure_override, - [nat_iiop_ssl_port, - {local, NATSSLServerPort, [{NATSSLServerPort, NATSSLServerPort}]}]), - - {ok, ClientNode, _ClientHost} = - ?match({ok,_,_}, orber_test_lib:js_node(ClientOptions)), - ?match(ok, orber_test_lib:remote_apply(ServerNode, orber_test_lib, - install_test_data, - [ssl])), - - IOR1 = ?match(#'IOP_IOR'{}, - orber_test_lib:remote_apply(ClientNode, corba, - string_to_object, - ["corbaname::1.2@"++IP++":"++ - integer_to_list(ServerPort)++"/NameService#mamba"])), - - ?match({'external', {_IP, _Port, _ObjectKey, _Counter, _TP, - #host_data{protocol = ssl, - ssl_data = #'SSLIOP_SSL'{port = NATSSLServerPort}}}}, - iop_ior:get_key(IOR1)), - ?match(ok, orber_test_lib:remote_apply(ServerNode, orber_test_lib, - uninstall_test_data, - [ssl])), - ?match(ok, - orber_test_lib:remote_apply(ServerNode, orber, - remove_listen_interface, [Ref])), - ok. - nat_iiop_ssl_port(doc) -> ["SECURE MULTI ORB API tests (SSL depth 1)", "Make sure NAT works for SSL"]; diff --git a/lib/os_mon/src/memsup.erl b/lib/os_mon/src/memsup.erl index a1b8591c8c..b178732fae 100644 --- a/lib/os_mon/src/memsup.erl +++ b/lib/os_mon/src/memsup.erl @@ -721,20 +721,19 @@ reply(Pending, MemUsage, SysMemUsage) -> %% get_memory_usage(OS) -> {Alloc, Total} %% Darwin: -%% Uses vm_stat command. This appears to lie about the page size in -%% Mac OS X 10.2.2 - the pages given are based on 4000 bytes, but -%% the vm_stat command tells us that it is 4096... +%% Uses vm_stat command. get_memory_usage({unix,darwin}) -> Str1 = os:cmd("/usr/bin/vm_stat"), - - {[Free], Str2} = fread_value("Pages free:~d.", Str1), - {[Active], Str3} = fread_value("Pages active:~d.", Str2), - {[Inactive], Str4} = fread_value("Pages inactive:~d.", Str3), - {[_], Str5} = fread_value("Pages speculative:~d.", Str4), + PageSize = 4096, + + {[Free], Str2} = fread_value("Pages free:~d.", Str1), + {[Active], Str3} = fread_value("Pages active:~d.", Str2), + {[Inactive], Str4} = fread_value("Pages inactive:~d.", Str3), + {[Speculative], Str5} = fread_value("Pages speculative:~d.", Str4), {[Wired], _} = fread_value("Pages wired down:~d.", Str5), - NMemUsed = (Wired + Active + Inactive) * 4000, - NMemTotal = NMemUsed + Free * 4000, + NMemUsed = (Wired + Active + Inactive) * PageSize, + NMemTotal = NMemUsed + (Free + Speculative) * PageSize, {NMemUsed,NMemTotal}; %% FreeBSD: Look in /usr/include/sys/vmmeter.h for the format of struct diff --git a/lib/public_key/doc/src/using_public_key.xml b/lib/public_key/doc/src/using_public_key.xml index 5d9f1536d9..450bd7e35f 100644 --- a/lib/public_key/doc/src/using_public_key.xml +++ b/lib/public_key/doc/src/using_public_key.xml @@ -1,4 +1,4 @@ -<?xml version="1.0" encoding="iso-8859-1" ?> +<?xml version="1.0" encoding="utf-8" ?> <!DOCTYPE chapter SYSTEM "chapter.dtd"> <chapter> @@ -90,7 +90,7 @@ [{'RSAPrivateKey',<<224,108,117,203,152,40,15,77,128,126, 221,195,154,249,85,208,202,251,109, 119,120,57,29,89,19,9,...>>, - {"DES-EDE3-CBC",<<"k�e��p�L">>}}] + {"DES-EDE3-CBC",<<"kÙeø¼pµL">>}}] </code> @@ -350,7 +350,7 @@ ok</code> <p> or </p> - <code>1> PemBin = public_key:pem_entry_encode('SubjectPublicKeyInfo', RSAPubKey). + <code>1> PemEntry = public_key:pem_entry_encode('SubjectPublicKeyInfo', RSAPubKey). {'SubjectPublicKeyInfo', <<48,92...>>, not_encrypted} 2> PemBin = public_key:pem_encode([PemEntry]). diff --git a/lib/snmp/doc/src/notes.xml b/lib/snmp/doc/src/notes.xml index 97e7a4db1d..d213b67052 100644 --- a/lib/snmp/doc/src/notes.xml +++ b/lib/snmp/doc/src/notes.xml @@ -75,8 +75,8 @@ <p>Add (atl) log conversion block option. </p> <p>It is now possible to request that the Audit Trail Log should be blocked during conversion (<c>log_to_txt</c> or <c>log_to_io</c>). - This could be usefull when coverting a large log (when there is - a chance it may otherwise wrap during conversion). </p> + This could be usefull when coverting an entire large log (when + there is a chance it may otherwise wrap during conversion). </p> <p>See agent <seealso marker="snmpa#log_to_txt">log_to_txt</seealso> and @@ -89,6 +89,17 @@ <p>Own Id: seq12433</p> </item> + <item> + <p>When converting an Audit Trail Log to text, a corrupt + log entry could cause the entire conversion to fail. </p> + <p>Also, for a log with sequence numbers, failing to + decode a log entry would cause the conversion to fail + (not because of the failed decode, but because of the + failure to write the error message). </p> + <p>Own Id: OTP-111453</p> + <p>Aux Id: Seq 12459</p> + </item> + </list> </section> diff --git a/lib/snmp/src/app/snmp.appup.src b/lib/snmp/src/app/snmp.appup.src index e1bf7692b3..fa4b72ab68 100644 --- a/lib/snmp/src/app/snmp.appup.src +++ b/lib/snmp/src/app/snmp.appup.src @@ -27,7 +27,6 @@ %% {load_module, snmp_pdus, soft_purge, soft_purge, []} %% {update, snmpa_local_db, soft, soft_purge, soft_purge, []} %% {add_module, snmpm_net_if_mt} - [ {"4.24.2", [{restart_application, snmp}]}, {"4.24.1", [{restart_application, snmp}]}, diff --git a/lib/snmp/src/misc/snmp_log.erl b/lib/snmp/src/misc/snmp_log.erl index de03c97281..862c1c7c0c 100644 --- a/lib/snmp/src/misc/snmp_log.erl +++ b/lib/snmp/src/misc/snmp_log.erl @@ -16,6 +16,7 @@ %% %% %CopyrightEnd% %% +%% -module(snmp_log). @@ -434,6 +435,8 @@ log_to_txt(Log, Block, FileName, Dir, Mibs, TextFile, Start, Stop) [Log, Block, FileName, Dir, Mibs, TextFile, Start, Stop]), File = filename:join(Dir, FileName), Converter = fun(L) -> + ?vtrace("log_to_txt:fun -> entry with" + "~n L: ~p", [L]), do_log_to_file(L, TextFile, Mibs, Start, Stop) end, log_convert(Log, Block, File, Converter). @@ -475,6 +478,8 @@ log_to_io(Log, Block, FileName, Dir, Mibs, Start, Stop) [Log, Block, FileName, Dir, Mibs, Start, Stop]), File = filename:join(Dir, FileName), Converter = fun(L) -> + ?vtrace("log_to_io:fun -> entry with" + "~n L: ~p", [L]), do_log_to_io(L, Mibs, Start, Stop) end, log_convert(Log, Block, File, Converter). @@ -504,15 +509,15 @@ do_log_convert(Log, Block, File, Converter) -> fun() -> put(sname, lc), put(verbosity, Verbosity), + ?vlog("begin converting", []), Result = do_log_convert2(Log, Block, File, Converter), + ?vlog("convert result: ~p", [Result]), exit(Result) end), receive {'DOWN', Ref, process, Pid, Result} -> %% ?vtrace("do_log_converter -> received result" - %% "~n Result: ~p" - %% "~n disk_log:info(Log): ~p", - %% [Result, disk_log:info(Log)]), + %% "~n Result: ~p", [Result]), Result end. @@ -529,6 +534,7 @@ do_log_convert2(Log, Block, File, Converter) -> %% log, because if we close an already open log we will cause %% a runtime error. + ?vtrace("do_log_convert2 -> entry - check if owner", []), case is_owner(Log) of true -> ?vtrace("do_log_converter2 -> convert an already owned log", []), @@ -541,19 +547,22 @@ do_log_convert2(Log, Block, File, Converter) -> ?vtrace("do_log_converter2 -> convert log", []), case log_open(Log, File) of {ok, _} -> - ?vtrace("do_log_converter2 -> " - "convert (the now opened) log", []), + ?vdebug("do_log_convert2 -> opened - now convert", []), maybe_block(Log, Block), Res = Converter(Log), maybe_unblock(Log, Block), disk_log:close(Log), + ?vdebug("do_log_convert2 -> converted - done: " + "~n Result: ~p", [Res]), Res; {error, {name_already_open, _}} -> - ?vtrace("do_log_converter2 -> " - "convert (an already opened) log", []), + ?vdebug("do_log_convert2 -> " + "already opened - now convert", []), maybe_block(Log, Block), Res = Converter(Log), maybe_unblock(Log, Block), + ?vdebug("do_log_convert2 -> converted - done: " + "~n Result: ~p", [Res]), Res; {error, Reason} -> ?vinfo("do_log_converter2 -> " @@ -601,50 +610,93 @@ maybe_unblock(Log, true = _Block) -> %% -- do_log_to_text --- do_log_to_file(Log, TextFile, Mibs, Start, Stop) -> + ?vtrace("do_log_to_txt -> entry with" + "~n Log: ~p" + "~n TextFile: ~p" + "~n Start: ~p" + "~n Stop: ~p", [Log, TextFile, Start, Stop]), case file:open(TextFile, [write]) of {ok, Fd} -> + ?vtrace("do_log_to_txt -> outfile created - create mini MIB", []), MiniMib = snmp_mini_mib:create(Mibs), + ?vtrace("do_log_to_txt -> mini-MIB created - begin conversion", []), Write = fun(X) -> + ?vtrace("do_log_to_txt:fun -> " + "entry - try format", []), case format_msg(X, MiniMib, Start, Stop) of {ok, S} -> + ?vtrace("do_log_to_txt:fun -> " + "formated - now write", []), io:format(Fd, "~s", [S]); _ -> + ?vdebug("do_log_to_txt:fun -> " + "format failed", []), ok end end, Res = (catch loop(disk_log:chunk(Log, start), Log, Write)), + ?vtrace("do_log_to_txt -> converted - now delete mini-MIB", []), snmp_mini_mib:delete(MiniMib), + ?vtrace("do_log_to_txt -> " + "mini-MIB closed - now close output file", []), file:close(Fd), + ?vtrace("do_log_to_txt -> done", []), Res; {error, Reason} -> + ?vinfo("failed opening output file: " + "~n TestFile: ~p" + "~n Reason: ~p", [TextFile, Reason]), {error, {TextFile, Reason}} end. do_log_to_io(Log, Mibs, Start, Stop) -> + ?vtrace("do_log_to_io -> entry with" + "~n Log: ~p" + "~n Mibs: ~p" + "~n Start: ~p" + "~n Stop: ~p", [Log, Mibs, Start, Stop]), MiniMib = snmp_mini_mib:create(Mibs), + ?vtrace("do_log_to_io -> mini-MIB created - begin conversion", []), Write = fun(X) -> + ?vtrace("do_log_to_io:fun -> entry", []), case format_msg(X, MiniMib, Start, Stop) of {ok, S} -> + ?vtrace("do_log_to_io:fun -> " + "formated - now write", []), io:format("~s", [S]); _ -> + ?vdebug("do_log_to_io:fun -> " + "format failed", []), ok end end, (catch loop(disk_log:chunk(Log, start), Log, Write)), + ?vtrace("do_log_to_io -> converted - now delete mini-MIB", []), snmp_mini_mib:delete(MiniMib), + ?vtrace("do_log_to_io -> done", []), ok. loop(eof, _Log, _Write) -> + ?vtrace("loop -> entry when eof", []), ok; -loop({error, _} = Error, _Log, _Write) -> +loop({error, _Reason} = Error, _Log, _Write) -> + ?vtrace("loop -> entry with error" + "~n Reason: ~p", [_Reason]), Error; loop({Cont, Terms}, Log, Write) -> - case (catch lists:foreach(Write, Terms)) of + ?vtrace("loop -> entry with terms" + "~n Cont: ~p" + "~n length(Terms): ~p", [Cont, length(Terms)]), + case (catch lists:foreach(Write, Terms)) of {'EXIT', Reason} -> + ?vtrace("loop -> failure while writing terms" + "~n Reason: ~p", [Reason]), {error, Reason}; - _ -> + _X -> + ?vtrace("loop -> terms written" + "~n X: ~p", [_X]), loop(disk_log:chunk(Log, Cont), Log, Write) end; loop({Cont, Terms, BadBytes}, Log, Write) -> @@ -657,6 +709,8 @@ loop({Cont, Terms, BadBytes}, Log, Write) -> loop(disk_log:chunk(Log, Cont), Log, Write) end; loop(Error, _Log, _Write) -> + ?vtrace("loop -> entry with unknown" + "~n Error: ~p", [Error]), Error. @@ -671,14 +725,17 @@ format_msg(Entry, Mib, Start, Stop) -> %% This is an old-style entry, that never had the sequence-number do_format_msg({Timestamp, Packet, {Addr, Port}}, Mib) -> + ?vdebug("do_format_msg -> old style log entry", []), do_format_msg(Timestamp, Packet, Addr, Port, Mib); %% This is the format without sequence-number do_format_msg({Timestamp, Packet, Addr, Port}, Mib) -> + ?vdebug("do_format_msg -> log entry without seqno", []), do_format_msg(Timestamp, Packet, Addr, Port, Mib); %% This is the format with sequence-number do_format_msg({Timestamp, SeqNo, Packet, Addr, Port}, Mib) -> + ?vdebug("do_format_msg -> log entry with seqno", []), do_format_msg(Timestamp, SeqNo, Packet, Addr, Port, Mib); %% This is crap... @@ -686,103 +743,165 @@ do_format_msg(_, _) -> format_tab("** unknown entry in log file\n\n", []). do_format_msg(TimeStamp, {V3Hdr, ScopedPdu}, Addr, Port, Mib) -> + ?vtrace("do_format_msg -> entry with" + "~n Timestamp: ~p" + "~n Addr: ~p" + "~n Port: ~p" + "~n => Try decode scoped pdu", + [TimeStamp, Addr, Port]), case (catch snmp_pdus:dec_scoped_pdu(ScopedPdu)) of ScopedPDU when is_record(ScopedPDU, scopedPdu) -> + ?vtrace("do_format_msg -> scoped pdu decoded" + "~n ScopedPDU: ~p", [ScopedPDU]), Msg = #message{version = 'version-3', vsn_hdr = V3Hdr, data = ScopedPDU}, f(ts2str(TimeStamp), "", Msg, Addr, Port, Mib); + {'EXIT', Reason} -> - format_tab("** error in log file at ~s from ~p:~w ~p\n\n", + ?vinfo("Failed decoding scoped pdu: " + "~n V3Hdr: ~w" + "~n ScopedPdu: ~w" + "~n Reason: ~p", [V3Hdr, ScopedPdu, Reason]), + format_tab("** error in log file at ~s from ~s:~w ~p\n\n", [ts2str(TimeStamp), ip(Addr), Port, Reason]) end; + do_format_msg(TimeStamp, Packet, Addr, Port, Mib) -> + ?vtrace("do_format_msg -> entry with" + "~n Timestamp: ~p" + "~n Addr: ~p" + "~n Port: ~p" + "~n => Try decode packet", + [TimeStamp, Addr, Port]), case (catch snmp_pdus:dec_message(binary_to_list(Packet))) of - Msg when is_record(Msg, message) -> + #message{data = Data} = Msg when (is_record(Data, scopedPdu) orelse + is_record(Data, pdu) orelse + is_record(Data, trappdu)) -> + ?vtrace("do_format_msg -> packet decoded" + "~n Msg: ~p", [Msg]), f(ts2str(TimeStamp), "", Msg, Addr, Port, Mib); + + #message{version = Vsn, + vsn_hdr = VsnHdr} = Msg -> + ?vinfo("Message not fully decoded: " + "~n Msg: ~p", [Msg]), + Reason = + lists:flatten( + io_lib:format("Message not fully decoded: " + "Vsn = ~p, VsnHdr = ~w", [Vsn, VsnHdr])), + format_tab("** error in log file ~s from ~s:~w => " + "\n ~s\n\n", + [ts2str(TimeStamp), ip(Addr), Port, Reason]); + {'EXIT', Reason} -> + ?vinfo("Failed decoding packet: " + "~n Packet: ~w" + "~n Reason: ~p", [Packet, Reason]), format_tab("** error in log file ~p\n\n", [Reason]) end. do_format_msg(TimeStamp, SeqNo, {V3Hdr, ScopedPdu}, Addr, Port, Mib) -> + ?vtrace("do_format_msg -> entry with" + "~n Timestamp: ~p" + "~n SeqNo: ~p" + "~n Addr: ~p" + "~n Port: ~p" + "~n => Try decode scoped pdu", + [TimeStamp, SeqNo, Addr, Port]), case (catch snmp_pdus:dec_scoped_pdu(ScopedPdu)) of ScopedPDU when is_record(ScopedPDU, scopedPdu) -> + ?vtrace("do_format_msg -> scoped pdu decoded" + "~n ScopedPDU: ~p", [ScopedPDU]), Msg = #message{version = 'version-3', vsn_hdr = V3Hdr, data = ScopedPDU}, f(ts2str(TimeStamp), sn2str(SeqNo), Msg, Addr, Port, Mib); + {'EXIT', Reason} -> - format_tab("** error in log file at ~s from ~p:~w ~p\n\n", + ?vinfo("Failed decoding scoped pdu: " + "~n V3Hdr: ~w" + "~n ScopedPdu: ~w" + "~n Reason: ~p", [V3Hdr, ScopedPdu, Reason]), + format_tab("** error in log file at ~s~s from ~s:~w ~p\n\n", [ts2str(TimeStamp), sn2str(SeqNo), ip(Addr), Port, Reason]) end; do_format_msg(TimeStamp, SeqNo, Packet, Addr, Port, Mib) -> + ?vtrace("do_format_msg -> entry with" + "~n Timestamp: ~p" + "~n SeqNo: ~p" + "~n Addr: ~p" + "~n Port: ~p" + "~n => Try decode message", + [TimeStamp, SeqNo, Addr, Port]), case (catch snmp_pdus:dec_message(binary_to_list(Packet))) of - Msg when is_record(Msg, message) -> + #message{data = Data} = Msg when (is_record(Data, scopedPdu) orelse + is_record(Data, pdu) orelse + is_record(Data, trappdu)) -> + ?vtrace("do_format_msg -> message decoded" + "~n Msg: ~p", [Msg]), f(ts2str(TimeStamp), sn2str(SeqNo), Msg, Addr, Port, Mib); + + #message{version = Vsn, + vsn_hdr = VsnHdr} = Msg -> + ?vinfo("Message not fully decoded: " + "~n Msg: ~p", [Msg]), + Reason = + lists:flatten( + io_lib:format("Message not fully decoded: " + "Vsn = ~p, VsnHdr = ~w", [Vsn, VsnHdr])), + format_tab("** error in log file ~s~s from ~s:~w => " + "\n ~s\n\n", + [ts2str(TimeStamp), sn2str(SeqNo), + ip(Addr), Port, Reason]); + {'EXIT', Reason} -> - format_tab("** error in log file ~s from ~p:~w ~p\n\n", + ?vinfo("Failed decoding packet: " + "~n Packet: ~w" + "~n Reason: ~p", [Packet, Reason]), + format_tab("** error in log file ~s (~s) from ~s:~w ~p\n\n", [ts2str(TimeStamp), sn2str(SeqNo), ip(Addr), Port, Reason]) end. -%% format_msg({TimeStamp, {V3Hdr, ScopedPdu}, {Addr, Port}}, -%% Mib, Start, Stop) -> -%% format_msg({TimeStamp, {V3Hdr, ScopedPdu}, Addr, Port}, -%% Mib, Start, Stop); -%% format_msg({TimeStamp, {V3Hdr, ScopedPdu}, Addr, Port}, -%% Mib, Start, Stop) -> -%% case timestamp_filter(TimeStamp, Start, Stop) of -%% true -> -%% case (catch snmp_pdus:dec_scoped_pdu(ScopedPdu)) of -%% ScopedPDU when record(ScopedPDU, scopedPdu) -> -%% Msg = #message{version = 'version-3', -%% vsn_hdr = V3Hdr, -%% data = ScopedPDU}, -%% f(ts2str(TimeStamp), Msg, Addr, Port, Mib); -%% {'EXIT', Reason} -> -%% format_tab("** error in log file at ~s from ~p:~w ~p\n\n", -%% [ts2str(TimeStamp), ip(Addr), Port, Reason]) -%% end; -%% false -> -%% ignore -%% end; -%% format_msg({TimeStamp, Packet, {Addr, Port}}, Mib, Start, Stop) -> -%% format_msg({TimeStamp, Packet, Addr, Port}, Mib, Start, Stop); -%% format_msg({TimeStamp, Packet, Addr, Port}, Mib, Start, Stop) -> -%% case timestamp_filter(TimeStamp, Start, Stop) of -%% true -> -%% case (catch snmp_pdus:dec_message(binary_to_list(Packet))) of -%% Msg when record(Msg, message) -> -%% f(ts2str(TimeStamp), Msg, Addr, Port, Mib); -%% {'EXIT', Reason} -> -%% format_tab("** error in log file ~p\n\n", [Reason]) -%% end; -%% false -> -%% ignore -%% end; -%% format_msg(_, _Mib, _Start, _Stop) -> -%% format_tab("** unknown entry in log file\n\n", []). - f(TimeStamp, SeqNo, #message{version = Vsn, vsn_hdr = VsnHdr, data = Data}, Addr, Port, Mib) -> - Str = format_pdu(Data, Mib), - HdrStr = format_header(Vsn, VsnHdr), - case get_type(Data) of - trappdu -> - f_trap(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); - 'snmpv2-trap' -> - f_trap(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); - 'inform-request' -> - f_inform(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); - 'get-response' -> - f_response(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); - report -> - f_report(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); - _ -> - f_request(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port) + try + begin + Str = format_pdu(Data, Mib), + HdrStr = format_header(Vsn, VsnHdr), + case get_type(Data) of + trappdu -> + f_trap(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); + 'snmpv2-trap' -> + f_trap(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); + 'inform-request' -> + f_inform(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); + 'get-response' -> + f_response(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); + report -> + f_report(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port); + _ -> + f_request(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port) + end + end + catch + T:E -> + ?vinfo("Failed formating log entry" + "~n TimeStamp: ~p" + "~n SeqNo: ~p" + "~n Data: ~p" + "~n Vsn: ~p" + "~n VsnHdr: ~p" + "~n Addr: ~p" + "~n Port: ~p" + "~n Error Type: ~w" + "~n Error: ~p", + [TimeStamp, SeqNo, Data, Vsn, VsnHdr, Addr, Port, T, E]), + format_tab("** error while formating log entry ~p\n\n", [{T, E}]) end. f_request(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port) -> @@ -809,7 +928,7 @@ f_inform(TimeStamp, SeqNo, Vsn, HdrStr, Str, Addr, Port) -> %% Convert a timestamp 2-tupple to a printable string %% ts2str({Local,Universal}) -> - dat2str(Local) ++ " , " ++ dat2str(Universal); + lists:flatten(dat2str(Local) ++ " , " ++ dat2str(Universal)); ts2str(_) -> "". @@ -906,7 +1025,7 @@ get_type(#pdu{type = Type}) -> ip({A,B,C,D}) -> - io_lib:format("~w.~w.~w.~w", [A,B,C,D]). + lists:flatten(io_lib:format("~w.~w.~w.~w", [A,B,C,D])). diff --git a/lib/snmp/src/misc/snmp_verbosity.erl b/lib/snmp/src/misc/snmp_verbosity.erl index e5ff3daf91..7d063fd702 100644 --- a/lib/snmp/src/misc/snmp_verbosity.erl +++ b/lib/snmp/src/misc/snmp_verbosity.erl @@ -154,7 +154,17 @@ image_of_sname(mgr) -> "MGR"; image_of_sname(mgr_misc) -> "MGR_MISC"; image_of_sname(undefined) -> ""; -image_of_sname(V) -> lists:flatten(io_lib:format("~p",[V])). +image_of_sname(S) when is_list(S) -> + %% The assumption is that its a printable string, + %% but just in case it is some other list... + try lists:flatten(io_lib:format("~s", [S])) of + L -> + L + catch + _:_ -> + lists:flatten(io_lib:format("~p", [S])) + end; +image_of_sname(V) -> lists:flatten(io_lib:format("~p", [V])). validate(info) -> info; diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index 141d3df38e..896b98edc2 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -141,7 +141,7 @@ <p>Sets the preferred public key algorithm to use for user authentication. If the the preferred algorithm fails for some reason, the other algorithm is tried. The default is - to try <c><![CDATA[ssh_rsa]]></c> first.</p> + to try <c><![CDATA['ssh-rsa']]></c> first.</p> </item> <tag><c><![CDATA[{pref_public_key_algs, list()}]]></c></tag> <item> @@ -248,7 +248,7 @@ requested by the client. Default is to use the erlang shell: <c><![CDATA[{shell, start, []}]]></c> </item> - <tag><c><![CDATA[{ssh_cli,{channel_callback(), + <tag><c><![CDATA[{ssh_cli, {channel_callback(), channel_init_args()}}]]></c></tag> <item> Provides your own cli implementation, i.e. a channel callback @@ -334,6 +334,20 @@ </func> <func> + <name>peername(ConnectionRef) -> {ok, {Address,Port}} | {error,Error} </name> + <fsummary> </fsummary> + <type> + <v> ConnectionRef = ssh_connection_ref()</v> + <v> Address = ip_address()</v> + <v> Port = integer()</v> + </type> + <desc> + <p>Returns the address and port for the other end of a connection. + </p> + </desc> + </func> + + <func> <name>shell(Host) -> </name> <name>shell(Host, Option) -> </name> <name>shell(Host, Port, Option) -> _</name> @@ -353,6 +367,20 @@ </func> <func> + <name>sockname(ConnectionRef) -> {ok, {Address,Port}} | {error,Error} </name> + <fsummary> </fsummary> + <type> + <v> ConnectionRef = ssh_connection_ref()</v> + <v> Address = ip_address()</v> + <v> Port = integer()</v> + </type> + <desc> + <p>Returns the local address and port number for a connection. + </p> + </desc> + </func> + + <func> <name>start() -> </name> <name>start(Type) -> ok | {error, Reason}</name> <fsummary>Starts the SSH application. </fsummary> diff --git a/lib/ssh/doc/src/ssh_server_key_api.xml b/lib/ssh/doc/src/ssh_server_key_api.xml index c4562e1211..51e1fc1f2e 100644 --- a/lib/ssh/doc/src/ssh_server_key_api.xml +++ b/lib/ssh/doc/src/ssh_server_key_api.xml @@ -29,7 +29,7 @@ -behaviour(ssh_server_key_api). </modulesummary> <description> - <p> Behaviour describing the API for an SSH server's public key handling.By implementing the callbacks defined + <p> Behaviour describing the API for an SSH server's public key handling. By implementing the callbacks defined in this behavior it is possible to customize the SSH server's public key handling. By default the SSH application implements this behavior with help of the standard openssh files, see <seealso marker="SSH_app"> ssh(6)</seealso>.</p> @@ -44,9 +44,9 @@ <p> boolean() = true | false</p> <p> string() = [byte()]</p> - <p> public_key() = #'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</p> - <p> private_key() = #'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</p> - <p> public_key_algorithm() = 'ssh-rsa'| 'ssh-dss' | atom()</p> + <p> public_key() = #'RSAPublicKey'{} | {integer(), #'Dss-Parms'{}} | term()</p> + <p> private_key() = #'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</p> + <p> public_key_algorithm() = 'ssh-rsa' | 'ssh-dss' | atom()</p> </section> <funcs> @@ -56,7 +56,7 @@ <fsummary>Fetches the hosts private key </fsummary> <type> <v>Algorithm = public_key_algorithm()</v> - <d> Host key algorithm. Should support 'ssh-rsa'| 'ssh-dss' but additional algorithms + <d> Host key algorithm. Should support 'ssh-rsa' | 'ssh-dss' but additional algorithms can be handled.</d> <v> DaemonOptions = proplists:proplist() </v> <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso></d> diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl index 7d5478c3f6..80d20abbbd 100644 --- a/lib/ssh/src/ssh.erl +++ b/lib/ssh/src/ssh.erl @@ -28,6 +28,8 @@ -export([start/0, start/1, stop/0, connect/3, connect/4, close/1, connection_info/2, channel_info/3, daemon/1, daemon/2, daemon/3, + peername/1, + sockname/1, stop_listener/1, stop_listener/2, stop_daemon/1, stop_daemon/2, shell/1, shell/2, shell/3]). @@ -245,6 +247,28 @@ shell(Host, Port, Options) -> end. %%-------------------------------------------------------------------- +%% Function: peername(ConnectionRef) -> {ok, {Host,Port}} +%% | {error,Error} +%% +%% Description: Returns the peer address of the connection +%%-------------------------------------------------------------------- +peername(ConnectionRef) -> + [{peer, {_Name,{IP,Port}}}] = + ssh_connection_manager:connection_info(ConnectionRef, [peer]), + {ok, {IP,Port}}. + +%%-------------------------------------------------------------------- +%% Function: sockname(ConnectionRef) -> {ok, {Host,Port}} +%% | {error,Error} +%% +%% Description: Returns the local address of the connection +%%-------------------------------------------------------------------- +sockname(ConnectionRef) -> + [{sockname, Result}] = + ssh_connection_manager:connection_info(ConnectionRef, [sockname]), + Result. + +%%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- fix_idle_time(SshOptions) -> diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index 9de4dd5967..c3e8a3c742 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -46,7 +46,7 @@ handle_sync_event/4, handle_info/3, terminate/3, code_change/4]). %% spawn export --export([ssh_info_handler/3]). +-export([ssh_info_handler/4]). -record(state, { transport_protocol, % ex: tcp @@ -533,7 +533,7 @@ handle_event(renegotiate, StateName, State) -> {next_state, StateName, State}; handle_event({info, From, Options}, StateName, #state{ssh_params = Ssh} = State) -> - spawn(?MODULE, ssh_info_handler, [Options, Ssh, From]), + spawn(?MODULE, ssh_info_handler, [Options, Ssh, State, From]), {next_state, StateName, State}; handle_event(data_size, connected, #state{ssh_params = Ssh0} = State) -> {ok, [{send_oct,Sent}]} = inet:getstat(State#state.socket, [send_oct]), @@ -1022,26 +1022,29 @@ retry_fun(User, Reason, Opts) -> catch Fun(User, Reason) end. -ssh_info_handler(Options, Ssh, From) -> - Info = ssh_info(Options, Ssh, []), +ssh_info_handler(Options, Ssh, State, From) -> + Info = ssh_info(Options, Ssh, State, []), ssh_connection_manager:send_msg({channel_requst_reply, From, Info}). -ssh_info([], _, Acc) -> +ssh_info([], _, _, Acc) -> Acc; ssh_info([client_version | Rest], #ssh{c_vsn = IntVsn, - c_version = StringVsn} = SshParams, Acc) -> - ssh_info(Rest, SshParams, [{client_version, {IntVsn, StringVsn}} | Acc]); + c_version = StringVsn} = SshParams, State, Acc) -> + ssh_info(Rest, SshParams, State, [{client_version, {IntVsn, StringVsn}} | Acc]); ssh_info([server_version | Rest], #ssh{s_vsn = IntVsn, - s_version = StringVsn} = SshParams, Acc) -> - ssh_info(Rest, SshParams, [{server_version, {IntVsn, StringVsn}} | Acc]); + s_version = StringVsn} = SshParams, State, Acc) -> + ssh_info(Rest, SshParams, State, [{server_version, {IntVsn, StringVsn}} | Acc]); -ssh_info([peer | Rest], #ssh{peer = Peer} = SshParams, Acc) -> - ssh_info(Rest, SshParams, [{peer, Peer} | Acc]); +ssh_info([peer | Rest], #ssh{peer = Peer} = SshParams, State, Acc) -> + ssh_info(Rest, SshParams, State, [{peer, Peer} | Acc]); -ssh_info([ _ | Rest], SshParams, Acc) -> - ssh_info(Rest, SshParams, Acc). +ssh_info([sockname | Rest], SshParams, #state{socket=Socket}=State, Acc) -> + ssh_info(Rest, SshParams, State, [{sockname,inet:sockname(Socket)}|Acc]); + +ssh_info([ _ | Rest], SshParams, State, Acc) -> + ssh_info(Rest, SshParams, State, Acc). log_error(Reason) -> Report = io_lib:format("Erlang ssh connection handler failed with reason: " diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index f5db31baee..13caafc055 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -1,7 +1,7 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 2004-2012. All Rights Reserved. +# Copyright Ericsson AB 2004-2013. All Rights Reserved. # # The contents of this file are subject to the Erlang Public License, # Version 1.1, (the "License"); you may not use this file except in @@ -38,7 +38,8 @@ MODULES= \ ssh_sftpd_SUITE \ ssh_sftpd_erlclient_SUITE \ ssh_connection_SUITE \ - ssh_echo_server + ssh_echo_server \ + ssh_peername_sockname_server HRL_FILES_NEEDED_IN_TEST= \ $(ERL_TOP)/lib/ssh/src/ssh.hrl \ diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl index 0aa60624bf..e8f1d5213c 100644 --- a/lib/ssh/test/ssh_basic_SUITE.erl +++ b/lib/ssh/test/ssh_basic_SUITE.erl @@ -22,6 +22,7 @@ -module(ssh_basic_SUITE). -include_lib("common_test/include/ct.hrl"). +-include_lib("kernel/include/inet.hrl"). %% Note: This directive should only be used in test suites. -compile(export_all). @@ -48,7 +49,9 @@ all() -> close]. groups() -> - [{dsa_key, [], [send, exec, exec_compressed, shell, known_hosts, idle_time, rekey, openssh_zlib_basic_test]}, + [{dsa_key, [], [send, + peername_sockname, + exec, exec_compressed, shell, known_hosts, idle_time, rekey, openssh_zlib_basic_test]}, {rsa_key, [], [send, exec, exec_compressed, shell, known_hosts, idle_time, rekey, openssh_zlib_basic_test]}, {dsa_pass_key, [], [pass_phrase]}, {rsa_pass_key, [], [pass_phrase]}, @@ -473,6 +476,52 @@ send(Config) when is_list(Config) -> %%-------------------------------------------------------------------- +peername_sockname() -> + [{doc, "Test ssh:peername/1 and ssh:sockname/1"}]. +peername_sockname(Config) when is_list(Config) -> + process_flag(trap_exit, true), + SystemDir = filename:join(?config(priv_dir, Config), system), + UserDir = ?config(priv_dir, Config), + + {_Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {subsystems, [{"peername_sockname", + {ssh_peername_sockname_server, []}} + ]} + ]), + ConnectionRef = + ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user_dir, UserDir}, + {user_interaction, false}]), + {ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity), + success = ssh_connection:subsystem(ConnectionRef, ChannelId, "peername_sockname", infinity), + {ok,{HostPeerClient,PortPeerClient}} = ssh:peername(ConnectionRef), + {ok,{HostSockClient,PortSockClient}} = ssh:sockname(ConnectionRef), + receive + {ssh_cm, ConnectionRef, {data, ChannelId, _, Response}} -> + {PeerNameSrv,SockNameSrv} = binary_to_term(Response), + {ok,{HostPeerSrv,PortPeerSrv}} = PeerNameSrv, + {ok,{HostSockSrv,PortSockSrv}} = SockNameSrv, + host_equal(HostPeerSrv, HostSockClient), + PortPeerSrv = PortSockClient, + host_equal(HostSockSrv, HostPeerClient), + PortSockSrv = PortPeerClient, + host_equal(HostSockSrv, Host), + PortSockSrv = Port + after 10000 -> + throw(timeout) + end. + +host_equal(H1, H2) -> + not ordsets:is_disjoint(ips(H1), ips(H2)). + +ips(IP) when is_tuple(IP) -> ordsets:from_list([IP]); +ips(Name) when is_list(Name) -> + {ok,#hostent{h_addr_list=IPs4}} = inet:gethostbyname(Name,inet), + {ok,#hostent{h_addr_list=IPs6}} = inet:gethostbyname(Name,inet6), + ordsets:from_list(IPs4++IPs6). + +%%-------------------------------------------------------------------- close() -> [{doc, "Simulate that we try to close an already closed connection"}]. close(Config) when is_list(Config) -> diff --git a/lib/ssh/test/ssh_peername_sockname_server.erl b/lib/ssh/test/ssh_peername_sockname_server.erl new file mode 100644 index 0000000000..7664f3ee25 --- /dev/null +++ b/lib/ssh/test/ssh_peername_sockname_server.erl @@ -0,0 +1,56 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2013. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% + +-module(ssh_peername_sockname_server). + +%% The purpose of this module is to perform tests on the server side of an +%% ssh connection. + + +-behaviour(ssh_daemon_channel). +-record(state, {}). + +-export([init/1, handle_msg/2, handle_ssh_msg/2, terminate/2]). + +init([]) -> + {ok, #state{}}. + +handle_msg({ssh_channel_up, ChannelId, ConnectionManager}, State) -> + ssh_connection:send(ConnectionManager, ChannelId, + term_to_binary( + {catch ssh:peername(ConnectionManager), + catch ssh:sockname(ConnectionManager) + }) + ), + {ok, State}. + +handle_ssh_msg({ssh_cm, _, {exit_signal, ChannelId, _, _Error, _}}, + State) -> + {stop, ChannelId, State}; + +handle_ssh_msg({ssh_cm, _, {exit_status, ChannelId, _Status}}, State) -> + {stop, ChannelId, State}; + +handle_ssh_msg({ssh_cm, _CM, _}, State) -> + {ok, State}. + +terminate(_Reason, _State) -> + ok. diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index 6029a09730..445a47c07b 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -86,7 +86,7 @@ {user_lookup_fun, {fun(), term()}}, {psk_identity, string()}, {srp_identity, {string(), string()}} | {ssl_imp, ssl_imp()} | {reuse_sessions, boolean()} | {reuse_session, fun()} {next_protocols_advertised, [binary()]} | - {client_preferred_next_protocols, client | server, [binary()]} | + {client_preferred_next_protocols, {client | server, [binary()]} | {client | server, [binary()], binary()}} | {log_alert, boolean()} </c></p> @@ -353,8 +353,8 @@ fun(srp, Username :: string(), UserState :: term()) -> when possible. </item> - <tag>{client_preferred_next_protocols, Precedence :: server | client, ClientPrefs :: [binary()]}</tag> - <tag>{client_preferred_next_protocols, Precedence :: server | client, ClientPrefs :: [binary()], Default :: binary()}</tag> + <tag>{client_preferred_next_protocols, {Precedence :: server | client, ClientPrefs :: [binary()]}}</tag> + <tag>{client_preferred_next_protocols, {Precedence :: server | client, ClientPrefs :: [binary()], Default :: binary()}}</tag> <item> <p>Indicates the client will try to perform Next Protocol Negotiation.</p> diff --git a/lib/ssl/src/inet_tls_dist.erl b/lib/ssl/src/inet_tls_dist.erl index 57c859bf24..7367b5c224 100644 --- a/lib/ssl/src/inet_tls_dist.erl +++ b/lib/ssl/src/inet_tls_dist.erl @@ -95,11 +95,6 @@ do_setup(Kernel, Node, Type, MyNode, LongOrShortNames, SetupTime) -> end. close(Socket) -> - try - erlang:error(foo) - catch _:_ -> - io:format("close called ~p ~p~n",[Socket, erlang:get_stacktrace()]) - end, gen_tcp:close(Socket), ok. diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index 6513042e98..e6ed0d8626 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -34,7 +34,7 @@ -export([security_parameters/2, security_parameters/3, suite_definition/1, decipher/5, cipher/5, - suite/1, suites/1, anonymous_suites/0, psk_suites/1, srp_suites/0, + suite/1, suites/1, ec_keyed_suites/0, anonymous_suites/0, psk_suites/1, srp_suites/0, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2]). diff --git a/lib/ssl/src/ssl_handshake.erl b/lib/ssl/src/ssl_handshake.erl index 29a8996bd6..b18452a8f2 100644 --- a/lib/ssl/src/ssl_handshake.erl +++ b/lib/ssl/src/ssl_handshake.erl @@ -49,13 +49,13 @@ ]). %% Cipher suites handling --export([available_suites/2, available_suites/3, cipher_suites/2, - select_session/10]). +-export([available_suites/2, cipher_suites/2, + select_session/10, supported_ecc/1]). %% Extensions handling -export([client_hello_extensions/5, handle_client_hello_extensions/8, %% Returns server hello extensions - handle_server_hello_extensions/9 + handle_server_hello_extensions/9, select_curve/2 ]). %% MISC @@ -89,7 +89,7 @@ client_hello_extensions(Version, CipherSuites, SslOpts, ConnectionStates, Renego {EcPointFormats, EllipticCurves} = case advertises_ec_ciphers(lists:map(fun ssl_cipher:suite_definition/1, CipherSuites)) of true -> - ecc_extensions(tls_v1, Version); + client_ecc_extensions(tls_v1, Version); false -> {undefined, undefined} end, @@ -861,22 +861,29 @@ available_suites(UserSuites, Version) -> UserSuites end. -available_suites(ServerCert, UserSuites, Version) -> - ssl_cipher:filter(ServerCert, available_suites(UserSuites, Version)). +available_suites(ServerCert, UserSuites, Version, Curve) -> + ssl_cipher:filter(ServerCert, available_suites(UserSuites, Version)) + -- unavailable_ecc_suites(Curve). + +unavailable_ecc_suites(no_curve) -> + ssl_cipher:ec_keyed_suites(); +unavailable_ecc_suites(_) -> + []. cipher_suites(Suites, false) -> [?TLS_EMPTY_RENEGOTIATION_INFO_SCSV | Suites]; cipher_suites(Suites, true) -> Suites. -select_session(SuggestedSessionId, CipherSuites, Compressions, Port, Session, Version, +select_session(SuggestedSessionId, CipherSuites, Compressions, Port, #session{ecc = ECCCurve} = + Session, Version, #ssl_options{ciphers = UserSuites} = SslOpts, Cache, CacheCb, Cert) -> {SessionId, Resumed} = ssl_session:server_id(Port, SuggestedSessionId, SslOpts, Cert, Cache, CacheCb), - Suites = ssl_handshake:available_suites(Cert, UserSuites, Version), case Resumed of undefined -> + Suites = available_suites(Cert, UserSuites, Version, ECCCurve), CipherSuite = select_cipher_suite(CipherSuites, Suites), Compression = select_compression(Compressions), {new, Session#session{session_id = SessionId, @@ -886,6 +893,13 @@ select_session(SuggestedSessionId, CipherSuites, Compressions, Port, Session, Ve {resumed, Resumed} end. +supported_ecc(Version) -> + case tls_v1:ecc_curves(Version) of + [] -> + undefined; + Curves -> + #elliptic_curves{elliptic_curve_list = Curves} + end. %%-------------certificate handling -------------------------------- certificate_types({KeyExchange, _, _, _}) @@ -926,9 +940,8 @@ certificate_authorities_from_db(CertDbHandle, CertDbRef) -> handle_client_hello_extensions(RecordCB, Random, #hello_extensions{renegotiation_info = Info, srp = SRP, - next_protocol_negotiation = NextProtocolNegotiation, - ec_point_formats = EcPointFormats0, - elliptic_curves = EllipticCurves0}, Version, + ec_point_formats = ECCFormat, + next_protocol_negotiation = NextProtocolNegotiation}, Version, #ssl_options{secure_renegotiate = SecureRenegotation} = Opts, #session{cipher_suite = CipherSuite, compression_method = Compression} = Session0, ConnectionStates0, Renegotiation) -> @@ -937,12 +950,11 @@ handle_client_hello_extensions(RecordCB, Random, Random, CipherSuite, Compression, ConnectionStates0, Renegotiation, SecureRenegotation), ProtocolsToAdvertise = handle_next_protocol_extension(NextProtocolNegotiation, Renegotiation, Opts), - {EcPointFormats, EllipticCurves} = handle_ecc_extensions(Version, EcPointFormats0, EllipticCurves0), + ServerHelloExtensions = #hello_extensions{ renegotiation_info = renegotiation_info(RecordCB, server, ConnectionStates, Renegotiation), - ec_point_formats = EcPointFormats, - elliptic_curves = EllipticCurves, + ec_point_formats = server_ecc_extension(Version, ECCFormat), next_protocol_negotiation = encode_protocols_advertised_on_server(ProtocolsToAdvertise) }, @@ -1078,7 +1090,7 @@ srp_user(#ssl_options{srp_identity = {UserName, _}}) -> srp_user(_) -> undefined. -ecc_extensions(Module, Version) -> +client_ecc_extensions(Module, Version) -> CryptoSupport = proplists:get_value(public_keys, crypto:supports()), case proplists:get_bool(ecdh, CryptoSupport) of true -> @@ -1089,15 +1101,13 @@ ecc_extensions(Module, Version) -> {undefined, undefined} end. -handle_ecc_extensions(Version, EcPointFormats0, EllipticCurves0) -> +server_ecc_extension(_Version, EcPointFormats) -> CryptoSupport = proplists:get_value(public_keys, crypto:supports()), case proplists:get_bool(ecdh, CryptoSupport) of true -> - EcPointFormats1 = handle_ecc_point_fmt_extension(EcPointFormats0), - EllipticCurves1 = handle_ecc_curves_extension(Version, EllipticCurves0), - {EcPointFormats1, EllipticCurves1}; - _ -> - {undefined, undefined} + handle_ecc_point_fmt_extension(EcPointFormats); + false -> + undefined end. handle_ecc_point_fmt_extension(undefined) -> @@ -1105,11 +1115,6 @@ handle_ecc_point_fmt_extension(undefined) -> handle_ecc_point_fmt_extension(_) -> #ec_point_formats{ec_point_format_list = [?ECPOINT_UNCOMPRESSED]}. -handle_ecc_curves_extension(_Version, undefined) -> - undefined; -handle_ecc_curves_extension(Version, _) -> - #elliptic_curves{elliptic_curve_list = tls_v1:ecc_curves(Version)}. - advertises_ec_ciphers([]) -> false; advertises_ec_ciphers([{ecdh_ecdsa, _,_,_} | _]) -> @@ -1124,6 +1129,22 @@ advertises_ec_ciphers([{ecdh_anon, _,_,_} | _]) -> true; advertises_ec_ciphers([_| Rest]) -> advertises_ec_ciphers(Rest). +select_curve(#elliptic_curves{elliptic_curve_list = ClientCurves}, + #elliptic_curves{elliptic_curve_list = ServerCurves}) -> + select_curve(ClientCurves, ServerCurves); +select_curve(undefined, _) -> + %% Client did not send ECC extension use default curve if + %% ECC cipher is negotiated + {namedCurve, ?secp256k1}; +select_curve(_, []) -> + no_curve; +select_curve(Curves, [Curve| Rest]) -> + case lists:member(Curve, Curves) of + true -> + {namedCurve, Curve}; + false -> + select_curve(Curves, Rest) + end. %%-------------------------------------------------------------------- %%% Internal functions @@ -1648,3 +1669,4 @@ advertised_hash_signs({Major, Minor}) when Major >= 3 andalso Minor >= 3 -> ({Hash, _}) -> proplists:get_bool(Hash, Hashs) end, HashSigns)}; advertised_hash_signs(_) -> undefined. + diff --git a/lib/ssl/src/ssl_handshake.hrl b/lib/ssl/src/ssl_handshake.hrl index 3a3ad8cf35..f25b0df806 100644 --- a/lib/ssl/src/ssl_handshake.hrl +++ b/lib/ssl/src/ssl_handshake.hrl @@ -45,7 +45,8 @@ master_secret, srp_username, is_resumable, - time_stamp + time_stamp, + ecc }). -define(NUM_OF_SESSION_ID_BYTES, 32). % TSL 1.1 & SSL 3 diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index 5618837506..39595b4f95 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -97,8 +97,7 @@ terminated = false, % allow_renegotiate = true, expecting_next_protocol_negotiation = false :: boolean(), - next_protocol = undefined :: undefined | binary(), - client_ecc % {Curves, PointFmt} + next_protocol = undefined :: undefined | binary() }). -define(DEFAULT_DIFFIE_HELLMAN_PARAMS, @@ -405,26 +404,24 @@ hello(#server_hello{cipher_suite = CipherSuite, hello(Hello = #client_hello{client_version = ClientVersion, extensions = #hello_extensions{hash_signs = HashSigns}}, State = #state{connection_states = ConnectionStates0, - port = Port, session = #session{own_certificate = Cert} = Session0, + port = Port, + session = #session{own_certificate = Cert} = Session0, renegotiation = {Renegotiation, _}, session_cache = Cache, session_cache_cb = CacheCb, ssl_options = SslOpts}) -> HashSign = ssl_handshake:select_hashsign(HashSigns, Cert), case tls_handshake:hello(Hello, SslOpts, {Port, Session0, Cache, CacheCb, - ConnectionStates0, Cert}, Renegotiation) of + ConnectionStates0, Cert}, Renegotiation) of {Version, {Type, #session{cipher_suite = CipherSuite} = Session}, - ConnectionStates, - #hello_extensions{ec_point_formats = EcPointFormats, - elliptic_curves = EllipticCurves} = ServerHelloExt} -> + ConnectionStates, ServerHelloExt} -> {KeyAlg, _, _, _} = ssl_cipher:suite_definition(CipherSuite), - NegotiatedHashSign = negotiated_hashsign(HashSign, KeyAlg, Version), - do_server_hello(Type, ServerHelloExt, + NegotiatedHashSign = negotiated_hashsign(HashSign, KeyAlg, Version), + do_server_hello(Type, ServerHelloExt, State#state{connection_states = ConnectionStates, negotiated_version = Version, session = Session, - hashsign_algorithm = NegotiatedHashSign, - client_ecc = {EllipticCurves, EcPointFormats}}); + hashsign_algorithm = NegotiatedHashSign}); #alert{} = Alert -> handle_own_alert(Alert, ClientVersion, hello, State) end; @@ -1647,12 +1644,13 @@ key_exchange(#state{role = server, key_algorithm = Algo, negotiated_version = Version, tls_handshake_history = Handshake0, socket = Socket, - transport_cb = Transport + transport_cb = Transport, + session = #session{ecc = Curve} } = State) when Algo == ecdhe_ecdsa; Algo == ecdhe_rsa; Algo == ecdh_anon -> - ECDHKeys = public_key:generate_key(select_curve(State)), + ECDHKeys = public_key:generate_key(Curve), ConnectionState = ssl_record:pending_connection_state(ConnectionStates0, read), SecParams = ConnectionState#connection_state.security_parameters, @@ -3086,12 +3084,7 @@ default_hashsign(_Version, KeyExchange) KeyExchange == rsa_psk; KeyExchange == srp_anon -> {null, anon}. - -select_curve(#state{client_ecc = {[Curve|_], _}}) -> - {namedCurve, Curve}; -select_curve(_) -> - {namedCurve, ?secp256k1}. - + is_anonymous(Algo) when Algo == dh_anon; Algo == ecdh_anon; Algo == psk; diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index 02bfa69fc5..ecbca83e10 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -70,7 +70,7 @@ client_hello(Host, Port, ConnectionStates, }. %%-------------------------------------------------------------------- --spec server_hello(#session{}, tls_version(), #connection_states{}, +-spec server_hello(binary(), tls_version(), #connection_states{}, #hello_extensions{}) -> #server_hello{}. %% %% Description: Creates a server hello message. @@ -120,17 +120,16 @@ hello(#client_hello{client_version = ClientVersion, cipher_suites = CipherSuites, compression_methods = Compressions, random = Random, - extensions = HelloExt}, + extensions = #hello_extensions{elliptic_curves = Curves} = HelloExt}, #ssl_options{versions = Versions} = SslOpts, {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert}, Renegotiation) -> Version = ssl_handshake:select_version(tls_record, ClientVersion, Versions), case tls_record:is_acceptable_version(Version, Versions) of true -> - %% TODO: need to take supported Curves into Account when selecting the CipherSuite.... - %% if whe have an ECDSA cert with an unsupported curve, we need to drop ECDSA ciphers + ECCCurve = ssl_handshake:select_curve(Curves, ssl_handshake:supported_ecc(Version)), {Type, #session{cipher_suite = CipherSuite} = Session1} = ssl_handshake:select_session(SugesstedId, CipherSuites, Compressions, - Port, Session0, Version, + Port, Session0#session{ecc = ECCCurve}, Version, SslOpts, Cache, CacheCb, Cert), case CipherSuite of no_suite -> diff --git a/lib/stdlib/doc/src/re.xml b/lib/stdlib/doc/src/re.xml index 71a6e34513..7a9f37ca90 100644 --- a/lib/stdlib/doc/src/re.xml +++ b/lib/stdlib/doc/src/re.xml @@ -40,8 +40,8 @@ <p>This module contains regular expression matching functions for strings and binaries.</p> - <p>The regular expression syntax and semantics resemble that of - Perl.</p> + <p>The <seealso marker="#regexp_syntax">regular expression</seealso> + syntax and semantics resemble that of Perl.</p> <p>The library's matching algorithms are currently based on the PCRE library, but not all of the PCRE library is interfaced and @@ -702,7 +702,7 @@ This option makes it possible to include comments inside complicated patterns. N </func> </funcs> - + <marker id="regexp_syntax"></marker> <section> <title>PERL LIKE REGULAR EXPRESSIONS SYNTAX</title> <p>The following sections contain reference material for the diff --git a/lib/stdlib/src/dict.erl b/lib/stdlib/src/dict.erl index 4f8d45dc8d..4b42f64609 100644 --- a/lib/stdlib/src/dict.erl +++ b/lib/stdlib/src/dict.erl @@ -387,7 +387,7 @@ merge(F, D1, D2) -> update(K, fun (V1) -> F(K, V1, V2) end, V2, D) end, D1, D2). - + %% get_slot(Hashdb, Key) -> Slot. %% Get the slot. First hash on the new range, if we hit a bucket %% which has not been split use the unsplit buddy bucket. diff --git a/lib/stdlib/src/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index 73b8da335a..ca6a4b5c58 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -912,7 +912,7 @@ type_test(binary) -> is_binary; type_test(record) -> is_record; type_test(Test) -> Test. - + %% match(Pattern, Term, Bindings) -> %% {match,NewBindings} | nomatch %% or erlang:error({illegal_pattern, Pattern}). @@ -1051,7 +1051,7 @@ match_list([], [], Bs, _BBs) -> {match,Bs}; match_list(_, _, _Bs, _BBs) -> nomatch. - + %% new_bindings() %% bindings(Bindings) %% binding(Name, Bindings) diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index 4b654833ed..40ef6c8998 100644 --- a/lib/stdlib/src/erl_tar.erl +++ b/lib/stdlib/src/erl_tar.erl @@ -222,7 +222,7 @@ format_error(Atom) when is_atom(Atom) -> format_error(Term) -> lists:flatten(io_lib:format("~tp", [Term])). - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% Useful definitions (also start of implementation). @@ -412,7 +412,7 @@ split_filename([Comp|Rest], Prefix, Suffix, Len) -> split_filename([], Prefix, Suffix, _) -> {filename:join(Prefix),filename:join(Suffix)}. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% Retrieving files from a tape archive. diff --git a/lib/stdlib/src/filelib.erl b/lib/stdlib/src/filelib.erl index 9ef4954194..b8c0576e56 100644 --- a/lib/stdlib/src/filelib.erl +++ b/lib/stdlib/src/filelib.erl @@ -248,7 +248,7 @@ ensure_dir(F) -> end end. - + %%% %%% Pattern matching using a compiled wildcard. %%% @@ -360,7 +360,7 @@ do_alt([], _File) -> do_list_dir(Dir, Mod) -> eval_list_dir(Dir, Mod). - + %%% Compiling a wildcard. %% Only for debugging. diff --git a/lib/stdlib/src/gen_server.erl b/lib/stdlib/src/gen_server.erl index 7f65131f67..df68a37c06 100644 --- a/lib/stdlib/src/gen_server.erl +++ b/lib/stdlib/src/gen_server.erl @@ -393,7 +393,7 @@ decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, Hib) -> end. %%% --------------------------------------------------- -%%% Send/recive functions +%%% Send/receive functions %%% --------------------------------------------------- do_send(Dest, Msg) -> case catch erlang:send(Dest, Msg, [noconnect]) of diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl index 92a086b077..9e69601770 100644 --- a/lib/stdlib/src/io_lib.erl +++ b/lib/stdlib/src/io_lib.erl @@ -583,7 +583,7 @@ printable_unicode_list(_) -> false. %Everything else is false nl() -> "\n". - + %% %% Utilities for collecting characters in input files %% diff --git a/lib/stdlib/src/lists.erl b/lib/stdlib/src/lists.erl index b5577165f4..d6a9f4645d 100644 --- a/lib/stdlib/src/lists.erl +++ b/lib/stdlib/src/lists.erl @@ -630,7 +630,7 @@ flatlength([H|T], L) when is_list(H) -> flatlength([_|T], L) -> flatlength(T, L + 1); flatlength([], L) -> L. - + %% keymember(Key, Index, [Tuple]) Now a BIF! %% keyfind(Key, Index, [Tuple]) A BIF! %% keysearch(Key, Index, [Tuple]) Now a BIF! @@ -1163,7 +1163,7 @@ rumerge(T1, []) -> T1; rumerge(T1, [H2 | T2]) -> lists:reverse(rumerge2_1(T1, T2, [], H2), []). - + %% all(Predicate, List) %% any(Predicate, List) %% map(Function, List) diff --git a/lib/stdlib/src/string.erl b/lib/stdlib/src/string.erl index 4ed27ff4eb..d0bd0cb26e 100644 --- a/lib/stdlib/src/string.erl +++ b/lib/stdlib/src/string.erl @@ -257,7 +257,7 @@ chars(C, N, Tail) when N > 0 -> chars(C, N-1, [C|Tail]); chars(C, 0, Tail) when is_integer(C) -> Tail. - + %% Torbjörn's bit. %%% COPIES %%% @@ -461,7 +461,7 @@ sub_string(String, Start) -> substr(String, Start). Stop :: pos_integer(). sub_string(String, Start, Stop) -> substr(String, Start, Stop - Start + 1). - + %% ISO/IEC 8859-1 (latin1) letters are converted, others are ignored %% diff --git a/lib/stdlib/test/slave_SUITE.erl b/lib/stdlib/test/slave_SUITE.erl index 37fc694083..1d6a3ac90d 100644 --- a/lib/stdlib/test/slave_SUITE.erl +++ b/lib/stdlib/test/slave_SUITE.erl @@ -230,7 +230,7 @@ rsh_test(ResultTo) -> link(ResultTo), ?line {error, no_rsh} = slave:start(super, slave3). - + %%% Utilities. diff --git a/lib/test_server/src/ts.erl b/lib/test_server/src/ts.erl index 8e71c69d35..189a71a8ce 100644 --- a/lib/test_server/src/ts.erl +++ b/lib/test_server/src/ts.erl @@ -622,7 +622,7 @@ run_test(File, Args, Options) -> run_test(File, Args, Options, Vars) -> ts_run:run(File, Args, Options, Vars). - + %% This module provides some convenient shortcuts to running %% the test server from within a started Erlang shell. %% (This are here for backwards compatibility.) diff --git a/lib/tools/emacs/erlang-eunit.el b/lib/tools/emacs/erlang-eunit.el index f2c0db67dd..0adeff1a02 100644 --- a/lib/tools/emacs/erlang-eunit.el +++ b/lib/tools/emacs/erlang-eunit.el @@ -40,6 +40,10 @@ This is useful, reducing the save-compile-load-test cycle to one keychord.") (defvar erlang-eunit-recent-info '((mode . nil) (module . nil) (test . nil) (cover . nil)) "Info about the most recent running of an EUnit test representation.") +(defvar erlang-error-regexp-alist + '(("^\\([^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\)[:) \t]" . (1 2))) + "*Patterns for matching Erlang errors.") + ;;; ;;; Switch between src/EUnit test buffers ;;; diff --git a/lib/tools/emacs/erlang-start.el b/lib/tools/emacs/erlang-start.el index e1dc86621e..76e0575e68 100644 --- a/lib/tools/emacs/erlang-start.el +++ b/lib/tools/emacs/erlang-start.el @@ -52,7 +52,7 @@ ;; ;; To set the variable you can use the following command: ;; M-x set-variable RET debug-on-error RET t RET - + ;;; Code: ;; diff --git a/lib/tools/emacs/erlang.el b/lib/tools/emacs/erlang.el index 624042204c..c395d22356 100644 --- a/lib/tools/emacs/erlang.el +++ b/lib/tools/emacs/erlang.el @@ -697,6 +697,7 @@ resulting regexp is surrounded by \\_< and \\_>." "char" "cons" "deep_string" + "iodata" "iolist" "maybe_improper_list" "module" @@ -708,6 +709,7 @@ resulting regexp is surrounded by \\_< and \\_>." "nonempty_list" "nonempty_improper_list" "nonempty_maybe_improper_list" + "nonempty_string" "no_return" "pos_integer" "string" @@ -1025,7 +1027,7 @@ behaviour.") (defvar erlang-mode-syntax-table nil "Syntax table in use in Erlang-mode buffers.") - + (defvar erlang-skel-file "erlang-skels" "The type of erlang-skeletons that should be used, default @@ -1272,7 +1274,7 @@ Unfortunately, XEmacs hasn't got support for a special Font Lock syntax table. The effect is that `apply' in the atom `foo_apply' will be highlighted as a bif.") - + ;;; Avoid errors while compiling this file. ;; `eval-when-compile' is not defined in Emacs 18. We define it as a @@ -1321,7 +1323,7 @@ Lock syntax table. The effect is that `apply' in the atom (require 'tempo) (require 'compile)))) - + (defun erlang-version () "Return the current version of Erlang mode." (interactive) @@ -1516,7 +1518,7 @@ Other commands: (set (make-local-variable 'outline-level) (lambda () 1)) (set (make-local-variable 'add-log-current-defun-function) 'erlang-current-defun)) - + (defun erlang-font-lock-init () "Initialize Font Lock for Erlang mode." (or erlang-font-lock-syntax-table @@ -1686,7 +1688,7 @@ plus variables, macros and records." (font-lock-mode 1) (funcall (symbol-function 'font-lock-fontify-buffer))) - + (defun erlang-menu-init () "Init menus for Erlang mode. @@ -1905,7 +1907,7 @@ Example: The new menu is returned. No guarantee is given that the original menu is left unchanged." (delq entry items)) - + ;; Man code: (defun erlang-man-init () @@ -2228,7 +2230,7 @@ For example: After installing the line, kill and restart Emacs, or restart Erlang mode with the command `M-x erlang-mode RET'."))) - + ;; Skeleton code: ;; This code is based on the package `tempo' which is part of modern @@ -2349,7 +2351,7 @@ The first character of DD is space if the value is less than 10." (erlang-string-to-int (substring date 8 10)) (substring date 4 7) (substring date -4)))) - + ;; Indentation code: (defun erlang-indent-command (&optional whole-exp) @@ -3132,7 +3134,7 @@ commands." (skip-chars-backward " \t") (max (if (bolp) 0 (1+ (current-column))) comment-column))))) - + ;;; Erlang movement commands ;; All commands below work as movement commands. I.e. if the point is @@ -3336,7 +3338,7 @@ With negative argument go towards the beginning of the buffer." (forward-sexp 1) (buffer-substring start (point))))) - + ;;; Miscellaneous (defun erlang-fill-paragraph (&optional justify) @@ -3445,7 +3447,7 @@ at the end." (error "Can't clone argument list")) (insert args) (set-mark p))) - + ;;; Information retrieval functions. (defun erlang-buffer-substring (beg end) @@ -3772,7 +3774,7 @@ exported function." (store-match-data old-match-data) (member (cons name arity) exports)))) - + ;;; Check module name ;; The function `write-file', bound to C-x C-w, calls @@ -3835,7 +3837,7 @@ This function is normally placed in the hook `local-write-file-hooks'." ;; Must return nil since it is added to `local-write-file-hook'. nil) - + ;;; Electric functions. (defun erlang-electric-semicolon (&optional arg) @@ -4229,7 +4231,7 @@ This function is designed to be a member of a criteria list." (erlang-skip-blank) (looking-at "end[^_a-zA-Z0-9]"))) - + ;; Erlang tags support which is aware of erlang modules. ;; ;; Not yet implemented under XEmacs. (Hint: The Emacs 19 etags @@ -4539,7 +4541,7 @@ Tags can be given on the forms `tag', `module:', `module:tag'." (or default (error "There is no default tag")) spec))))) - + ;; Search tag functions which are aware of Erlang modules. The tactic ;; is to store new search functions into the local variables of the ;; TAGS buffers. The variables are restored directly after the @@ -4715,7 +4717,7 @@ for a tag on the form `module:tag'." (string= mod (erlang-get-module-from-file-name (file-of-tag))))))) - + ;;; Tags completion, Emacs 19 `etags' specific. ;;; ;;; The basic idea is to create a second completion table `erlang-tags- @@ -4834,7 +4836,7 @@ about Erlang modules." ;; Only the first one will be stored in the table. (intern (concat module ":") table)))))) table)) - + ;;; ;;; Prepare for other methods to run an Erlang slave process. ;;; @@ -4916,7 +4918,7 @@ future, a new shell on an already running host will be started." (call-interactively erlang-next-error-function)) - + ;;; ;;; Erlang Shell Mode -- Major mode used for Erlang shells. ;;; @@ -5052,7 +5054,7 @@ Selects Comint or Compilation mode command as appropriate." (define-key map "\M-\C-m" 'compile-goto-error) (unless inferior-erlang-use-cmm (define-key map "\C-x`" 'erlang-next-error))) - + ;;; ;;; Inferior Erlang -- Run an Erlang shell as a subprocess. ;;; diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl index bf21aa6b48..13d9aefb0c 100644 --- a/lib/tools/src/cover.erl +++ b/lib/tools/src/cover.erl @@ -255,16 +255,7 @@ compile_directory(Dir, Options) when is_list(Dir), is_list(Options) -> end. compile_modules(Files,Options) -> - Options2 = lists:filter(fun(Option) -> - case Option of - {i, Dir} when is_list(Dir) -> true; - {d, _Macro} -> true; - {d, _Macro, _Value} -> true; - export_all -> true; - _ -> false - end - end, - Options), + Options2 = filter_options(Options), compile_modules(Files,Options2,[]). compile_modules([File|Files], Options, Result) -> @@ -273,6 +264,17 @@ compile_modules([File|Files], Options, Result) -> compile_modules([],_Opts,Result) -> reverse(Result). +filter_options(Options) -> + lists:filter(fun(Option) -> + case Option of + {i, Dir} when is_list(Dir) -> true; + {d, _Macro} -> true; + {d, _Macro, _Value} -> true; + export_all -> true; + _ -> false + end + end, + Options). %% compile_beam(ModFile) -> Result | {error,Reason} %% ModFile - see compile/1 @@ -622,8 +624,9 @@ main_process_loop(State) -> Compiled0 = State#main_state.compiled, case get_beam_file(Module,BeamFile0,Compiled0) of {ok,BeamFile} -> + UserOptions = get_compile_options(Module,BeamFile), {Reply,Compiled} = - case do_compile_beam(Module,BeamFile,[]) of + case do_compile_beam(Module,BeamFile,UserOptions) of {ok, Module} -> remote_load_compiled(State#main_state.nodes, [{Module,BeamFile}]), @@ -1421,12 +1424,23 @@ get_abstract_code(Module, Beam) -> end. get_source_info(Module, Beam) -> + Compile = get_compile_info(Module, Beam), + case lists:keyfind(source, 1, Compile) of + { source, _ } = Tuple -> [Tuple]; + false -> [] + end. + +get_compile_options(Module, Beam) -> + Compile = get_compile_info(Module, Beam), + case lists:keyfind(options, 1, Compile) of + {options, Options } -> filter_options(Options); + false -> [] + end. + +get_compile_info(Module, Beam) -> case beam_lib:chunks(Beam, [compile_info]) of {ok, {Module, [{compile_info, Compile}]}} -> - case lists:keyfind(source, 1, Compile) of - { source, _ } = Tuple -> [Tuple]; - false -> [] - end; + Compile; _ -> [] end. diff --git a/lib/tools/src/tags.erl b/lib/tools/src/tags.erl index 1c72ef8db5..e3cc51cdb2 100644 --- a/lib/tools/src/tags.erl +++ b/lib/tools/src/tags.erl @@ -292,7 +292,7 @@ word_char(C) when C >= $0, C =< $9 -> true; word_char($_) -> true; word_char(_) -> false. - + %%% Output routines %% Check the options `outfile' and `outdir'. @@ -323,7 +323,7 @@ genout(Os, Name, Entries) -> io:put_chars(Os, lists:reverse(Entries)). - + %%% help routines %% Flatten and reverse a nested list. diff --git a/lib/tools/test/cover_SUITE.erl b/lib/tools/test/cover_SUITE.erl index c033be98a3..29b26c7a76 100644 --- a/lib/tools/test/cover_SUITE.erl +++ b/lib/tools/test/cover_SUITE.erl @@ -28,7 +28,7 @@ export_import/1, otp_5031/1, eif/1, otp_5305/1, otp_5418/1, otp_6115/1, otp_7095/1, otp_8188/1, otp_8270/1, otp_8273/1, otp_8340/1, - otp_10979_hanging_node/1]). + otp_10979_hanging_node/1, compile_beam_opts/1]). -include_lib("test_server/include/test_server.hrl"). @@ -53,7 +53,7 @@ all() -> dont_reconnect_after_stop, stop_node_after_disconnect, export_import, otp_5031, eif, otp_5305, otp_5418, otp_6115, otp_7095, otp_8188, otp_8270, otp_8273, - otp_8340, otp_10979_hanging_node]; + otp_8340, otp_10979_hanging_node, compile_beam_opts]; _pid -> {skip, "It looks like the test server is running " @@ -1401,6 +1401,39 @@ otp_10979_hanging_node(_Config) -> ok. +compile_beam_opts(doc) -> + ["Take compiler options from beam in cover:compile_beam"]; +compile_beam_opts(suite) -> []; +compile_beam_opts(Config) when is_list(Config) -> + {ok, Cwd} = file:get_cwd(), + ok = file:set_cwd(?config(priv_dir, Config)), + IncDir = filename:join(?config(data_dir, Config), + "included_functions"), + File = filename:join([?config(data_dir, Config), "otp_11439", "t.erl"]), + %% use all compiler options allowed by cover:filter_options + %% i and d don't make sense when compiling from beam though + {ok, t} = + compile:file(File, [{i, IncDir}, + {d, 'BOOL'}, + {d, 'MACRO', macro_defined}, + export_all, + debug_info, + return_errors]), + Exports = + [{func1,0}, + {macro, 0}, + {exported,0}, + {nonexported,0}, + {module_info,0}, + {module_info,1}], + Exports = t:module_info(exports), + {ok, t} = cover:compile_beam("t"), + Exports = t:module_info(exports), + cover:stop(), + ok = file:delete("t.beam"), + ok = file:set_cwd(Cwd), + ok. + %%--Auxiliary------------------------------------------------------------ analyse_expr(Expr, Config) -> diff --git a/lib/tools/test/cover_SUITE_data/otp_11439/t.erl b/lib/tools/test/cover_SUITE_data/otp_11439/t.erl new file mode 100644 index 0000000000..d1eb9f16ee --- /dev/null +++ b/lib/tools/test/cover_SUITE_data/otp_11439/t.erl @@ -0,0 +1,11 @@ +-module(t). +-export([exported/0]). +-include("cover_inc.hrl"). +-ifdef(BOOL). +macro() -> + ?MACRO. +-endif. +exported() -> + ok. +nonexported() -> + ok. diff --git a/lib/tools/test/eprof_SUITE_data/eed.erl b/lib/tools/test/eprof_SUITE_data/eed.erl index 520c5f3dd1..5f2a21aa60 100644 --- a/lib/tools/test/eprof_SUITE_data/eed.erl +++ b/lib/tools/test/eprof_SUITE_data/eed.erl @@ -146,7 +146,7 @@ format_error({'EXIT', {Code, {Mod, Func, Args}}}) -> [{Code, {Mod, Func, length(Args)}}])); format_error(A) -> atom_to_list(A). - + %%% Parsing commands. @@ -327,7 +327,7 @@ when 0 =< Num1, Num1 =< Num2, Num2 =< State#state.lines -> check_lines(_, _, _, _) -> error(bad_linenum). - + %%% Executing commands. %% ($)= - print line number @@ -657,7 +657,7 @@ undo_command(_, _, _) -> write_command(_Cmd, [_First, _Last], _St) -> error(not_implemented). - + %%% Primitive buffer operations. print_current(St) -> @@ -717,7 +717,7 @@ wrap_next_line(State) when State#state.dot == State#state.lines -> wrap_next_line(State) -> next_line(State). - + %%% Utilities. get_pattern(End, Cmd, State) -> diff --git a/lib/xmerl/src/xmerl.erl b/lib/xmerl/src/xmerl.erl index 3249094e78..01af183eef 100644 --- a/lib/xmerl/src/xmerl.erl +++ b/lib/xmerl/src/xmerl.erl @@ -303,18 +303,17 @@ apply_tag_cb(Ms, F, Args) -> apply_cb(Ms, F, '#element#', Args). apply_cb(Ms, F, Df, Args) -> - apply_cb(Ms, F, Df, Args, Ms). - -apply_cb([M|Ms], F, Df, Args, Ms0) -> - case catch apply(M, F, Args) of - {'EXIT', {undef,[{M,F,_,_}|_]}} -> - apply_cb(Ms, F, Df, Args, Ms0); - {'EXIT', Reason} -> - exit(Reason); - Res -> - Res + apply_cb(Ms, F, Df, Args, length(Args)). + +apply_cb(Ms, F, Df, Args, A) -> + apply_cb(Ms, F, Df, Args, A, Ms). + +apply_cb([M|Ms], F, Df, Args, A, Ms0) -> + case erlang:function_exported(M, F, A) of + true -> apply(M, F, Args); + false -> apply_cb(Ms, F, Df, Args, A, Ms0) end; -apply_cb([], Df, Df, Args, _Ms0) -> +apply_cb([], Df, Df, Args, A, _Ms0) -> exit({unknown_tag, {Df, Args}}); -apply_cb([], F, Df, Args, Ms0) -> - apply_cb(Ms0, Df, Df, [F|Args]). +apply_cb([], F, Df, Args, A, Ms0) -> + apply_cb(Ms0, Df, Df, [F|Args], A+1). diff --git a/lib/xmerl/src/xmerl_regexp.erl b/lib/xmerl/src/xmerl_regexp.erl index 0c53e6f34a..9303bdb125 100644 --- a/lib/xmerl/src/xmerl_regexp.erl +++ b/lib/xmerl/src/xmerl_regexp.erl @@ -593,7 +593,7 @@ sub_first_match(S, {regexp,RE}) -> nomatch -> nomatch end. - + %% This is the regular expression grammar used. It is equivalent to the %% one used in AWK, except that we allow ^ $ to be used anywhere and fail %% in the matching. @@ -961,7 +961,7 @@ re_apply_or(never_match, R2) -> R2; re_apply_or(R1, never_match) -> R1; re_apply_or(nomatch, R2) -> R2; re_apply_or(R1, nomatch) -> R1. - + %% Record definitions for the NFA, DFA and compiler. -record(nfa_state, {no,edges=[],accept=no}). @@ -1026,7 +1026,7 @@ parse_reas([{RegExp,A}|REAs], S) -> {error,E} -> {error,E} end; parse_reas([], Stack) -> {ok,reverse(Stack)}. - + %% build_combined_nfa(RegExpActionList) -> {NFA,StartState}. %% Build the combined NFA using Thompson's construction straight out %% of the book. Build the separate NFAs in the same order as the @@ -1147,7 +1147,7 @@ nfa_comp_class(Cc) -> comp_crs([{C1,C2}|Crs], Last) -> [{Last,C1-1}|comp_crs(Crs, C2+1)]; comp_crs([], Last) -> [{Last,maxchar}]. - + %% build_dfa(NFA, NfaStartState) -> {DFA,DfaStartState}. %% Build a DFA from an NFA using "subset construction". The major %% difference from the book is that we keep the marked and unmarked @@ -1282,7 +1282,7 @@ accept([St|Sts], NFA) -> #nfa_state{accept=no} -> accept(Sts, NFA) end; accept([], _NFA) -> no. - + %% minimise_dfa(DFA, StartState, FirstState) -> {DFA,StartState}. %% Minimise the DFA by removing equivalent states. We consider a %% state if both the transitions and the their accept state is the @@ -1331,7 +1331,7 @@ pack_dfa([D|DFA], NewN, Rs, PDFA) -> pack_dfa(DFA, NewN+1, [{D#dfa_state.no,NewN}|Rs], [D#dfa_state{no=NewN}|PDFA]); pack_dfa([], _NewN, Rs, PDFA) -> {PDFA,Rs}. - + %% comp_apply(String, StartPos, DFAReg) -> {match,RestPos,Rest} | nomatch. %% Apply the DFA of a regular expression to a string. If %% there is a match return the position of the remaining string and diff --git a/lib/xmerl/src/xmerl_xpath.erl b/lib/xmerl/src/xmerl_xpath.erl index b3301f2faf..be0e863ce4 100644 --- a/lib/xmerl/src/xmerl_xpath.erl +++ b/lib/xmerl/src/xmerl_xpath.erl @@ -713,10 +713,26 @@ node_test(_Test, node_test({wildcard, _}, #xmlNode{type=ElAt}, _Context) when ElAt==element; ElAt==attribute; ElAt==namespace -> true; -node_test({prefix_test, Prefix}, #xmlNode{node = N}, _Context) -> +node_test({prefix_test, Prefix}, #xmlNode{node = N}, Context) -> case N of - #xmlElement{nsinfo = {Prefix, _}} -> true; - #xmlAttribute{nsinfo = {Prefix, _}} -> true; + #xmlElement{nsinfo = {Prefix, _}} -> + true; + #xmlElement{expanded_name = {Uri, _}} -> + case expanded_name(Prefix, "_", Context) of + {Uri, _} -> + true; + _ -> + false + end; + #xmlAttribute{nsinfo = {Prefix, _}} -> + true; + #xmlAttribute{expanded_name = {Uri, _}} -> + case expanded_name(Prefix, "_", Context) of + {Uri, _} -> + true; + _ -> + false + end; _ -> false end; @@ -760,20 +776,21 @@ node_test({name, {_Tag, Prefix, Local}}, node_test({name, {Tag,_Prefix,_Local}}, #xmlNode{node = #xmlAttribute{name = Tag}}, _Context) -> true; -node_test({name, {_Tag, Prefix, Local}}, - #xmlNode{node = #xmlAttribute{expanded_name = {URI, Local}, - nsinfo = {_Prefix1, _}, - namespace = NS}}, _Context) -> - NSNodes = NS#xmlNamespace.nodes, - case lists:keysearch(Prefix, 1, NSNodes) of - {value, {_, URI}} -> - ?dbg("node_test(~, ~p) -> true.~n", - [{_Tag, Prefix, Local}, write_node(NSNodes)]), - true; - false -> - ?dbg("node_test(~, ~p) -> false.~n", - [{_Tag, Prefix, Local}, write_node(NSNodes)]), - false +node_test({name, {Tag, Prefix, Local}}, + #xmlNode{node = #xmlAttribute{name = Name, + expanded_name = EExpName + }}, Context) -> + case expanded_name(Prefix, Local, Context) of + [] -> + Res = (Tag == Name), + ?dbg("node_test(~p, ~p) -> ~p.~n", + [{Tag, Prefix, Local}, write_node(Name), Res]), + Res; + ExpName -> + Res = (ExpName == EExpName), + ?dbg("node_test(~p, ~p) -> ~p.~n", + [{Tag, Prefix, Local}, write_node(Name), Res]), + Res end; node_test({name, {_Tag, [], Local}}, #xmlNode{node = #xmlNsNode{prefix = Local}}, _Context) -> diff --git a/lib/xmerl/test/xmerl_SUITE.erl b/lib/xmerl/test/xmerl_SUITE.erl index e21355f877..8432e66a97 100644 --- a/lib/xmerl/test/xmerl_SUITE.erl +++ b/lib/xmerl/test/xmerl_SUITE.erl @@ -42,7 +42,7 @@ %%---------------------------------------------------------------------- all() -> [{group, cpd_tests}, xpath_text1, xpath_main, - xpath_abbreviated_syntax, xpath_functions, + xpath_abbreviated_syntax, xpath_functions, xpath_namespaces, {group, misc}, {group, eventp_tests}, {group, ticket_tests}, {group, app_test}, {group, appup_test}]. @@ -205,6 +205,11 @@ xpath_functions(Config) -> ?line file:set_cwd(filename:join(?config(data_dir,Config),xpath)), ?line ok = xpath_abbrev:functions(). +xpath_namespaces(suite) -> []; +xpath_namespaces(Config) -> + ?line file:set_cwd(filename:join(?config(data_dir,Config),xpath)), + ?line ok = xpath_abbrev:namespaces(). + %%---------------------------------------------------------------------- latin1_alias(suite) -> []; diff --git a/lib/xmerl/test/xmerl_SUITE_data/xpath/purchaseOrder.xml b/lib/xmerl/test/xmerl_SUITE_data/xpath/purchaseOrder.xml index a5ae223d65..16090c3590 100644 --- a/lib/xmerl/test/xmerl_SUITE_data/xpath/purchaseOrder.xml +++ b/lib/xmerl/test/xmerl_SUITE_data/xpath/purchaseOrder.xml @@ -1,7 +1,8 @@ <?xml version="1.0"?> <apo:purchaseOrder xmlns:apo="http://www.example.com/PO1" + xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" orderDate="1999-10-20"> - <billTo country="US"> + <billTo country="US" xsi:type="apo:USAddress"> <name>Robert Smith</name> <street>8 Oak Avenue</street> <!-- etc. --> @@ -10,7 +11,7 @@ <zip>95819</zip> </billTo> <apo:comment>Hurry, my lawn is going wild!</apo:comment> - <shipTo country="US"> + <shipTo country="US" xsi:type="apo:USAddress"> <name>Alice Smith</name> <street>123 Maple Street</street> <!-- etc. --> diff --git a/lib/xmerl/test/xmerl_SUITE_data/xpath/xpath_abbrev.erl b/lib/xmerl/test/xmerl_SUITE_data/xpath/xpath_abbrev.erl index 7b6f1e95b3..afd39b6598 100644 --- a/lib/xmerl/test/xmerl_SUITE_data/xpath/xpath_abbrev.erl +++ b/lib/xmerl/test/xmerl_SUITE_data/xpath/xpath_abbrev.erl @@ -8,6 +8,7 @@ -module(xpath_abbrev). -export([test/0, check_node_set/2, ticket_6873/0, ticket_7496/0, functions/0]). +-export([namespaces/0]). -include("test_server.hrl"). -include_lib("xmerl/include/xmerl.hrl"). @@ -264,3 +265,33 @@ functions() -> [city,city,comment]), ?line ok = Test(Doc2,"//*[starts-with(name(),'{http://www.example.com/PO1')]", ['apo:purchaseOrder','apo:comment']). + + +namespaces() -> + {Doc,_} = xmerl_scan:file("purchaseOrder.xml", [{namespace_conformant, true}]), + + %% Element name using regular namespace and context namespace declaration. + ?line [#xmlElement{nsinfo = {_, "purchaseOrder"}}] = + xmerl_xpath:string("/apo:purchaseOrder", Doc), + ?line [#xmlElement{nsinfo = {_, "purchaseOrder"}}] = + xmerl_xpath:string("/t:purchaseOrder", Doc, [{namespace, [{"t", "http://www.example.com/PO1"}]}]), + + %% Wildcard element name using regular namespace and context namespace declaration. + ?line [#xmlElement{nsinfo = {_, "comment"}}] = + xmerl_xpath:string("./apo:*", Doc), + ?line [#xmlElement{nsinfo = {_, "comment"}}] = + xmerl_xpath:string("./t:*", Doc, [{namespace, [{"t", "http://www.example.com/PO1"}]}]), + + %% Attribute name using regular namespace and context namespace declaration. + ?line [#xmlAttribute{nsinfo = {_, "type"}}, #xmlAttribute{nsinfo = {_, "type"}}] = + xmerl_xpath:string("//@xsi:type", Doc), + ?line [#xmlAttribute{nsinfo = {_, "type"}}, #xmlAttribute{nsinfo = {_, "type"}}] = + xmerl_xpath:string("//@t:type", Doc, [{namespace, [{"t", "http://www.w3.org/2001/XMLSchema-instance"}]}]), + + %% Wildcard attribute name using regular namespace and context namespace declaration. + ?line [#xmlAttribute{nsinfo = {_, "type"}}, #xmlAttribute{nsinfo = {_, "type"}}] = + xmerl_xpath:string("//@xsi:*", Doc), + ?line [#xmlAttribute{nsinfo = {_, "type"}}, #xmlAttribute{nsinfo = {_, "type"}}] = + xmerl_xpath:string("//@t:*", Doc, [{namespace, [{"t", "http://www.w3.org/2001/XMLSchema-instance"}]}]), + + ok. diff --git a/system/doc/top/src/erl_html_tools.erl b/system/doc/top/src/erl_html_tools.erl index 1e2b8c86af..73d131ec0b 100644 --- a/system/doc/top/src/erl_html_tools.erl +++ b/system/doc/top/src/erl_html_tools.erl @@ -655,7 +655,7 @@ sub_repl([[{St, L}] |Ss], Fun, Acc0, S, Pos) -> {string:substr(S, Pos+1, St-Pos) ++ Rep ++ Rs, NewAcc}; sub_repl([], _Fun, Acc, S, Pos) -> {string:substr(S, Pos+1), Acc}. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Error and warnings diff --git a/xcomp/erl-xcomp-vars.sh b/xcomp/erl-xcomp-vars.sh index eccdff47e3..337e0fb809 100644 --- a/xcomp/erl-xcomp-vars.sh +++ b/xcomp/erl-xcomp-vars.sh @@ -26,4 +26,4 @@ # and precious variables in $ERL_TOP/erts/aclocal.m4. # -erl_xcomp_vars="erl_xcomp_sysroot erl_xcomp_isysroot erl_xcomp_bigendian erl_xcomp_double_middle_endian erl_xcomp_linux_clock_gettime_correction erl_xcomp_linux_nptl erl_xcomp_linux_usable_sigusrx erl_xcomp_linux_usable_sigaltstack erl_xcomp_poll erl_xcomp_kqueue erl_xcomp_putenv_copy erl_xcomp_reliable_fpe erl_xcomp_getaddrinfo erl_xcomp_gethrvtime_procfs_ioctl erl_xcomp_clock_gettime_cpu_time erl_xcomp_after_morecore_hook erl_xcomp_dlsym_brk_wrappers" +erl_xcomp_vars="erl_xcomp_sysroot erl_xcomp_isysroot erl_xcomp_bigendian erl_xcomp_double_middle_endian erl_xcomp_linux_clock_gettime_correction erl_xcomp_linux_nptl erl_xcomp_linux_usable_sigusrx erl_xcomp_linux_usable_sigaltstack erl_xcomp_poll erl_xcomp_kqueue erl_xcomp_putenv_copy erl_xcomp_reliable_fpe erl_xcomp_getaddrinfo erl_xcomp_gethrvtime_procfs_ioctl erl_xcomp_clock_gettime_cpu_time erl_xcomp_after_morecore_hook erl_xcomp_dlsym_brk_wrappers erl_xcomp_posix_memalign" diff --git a/xcomp/erl-xcomp.conf.template b/xcomp/erl-xcomp.conf.template index 7d70332cef..ad72b7d66b 100644 --- a/xcomp/erl-xcomp.conf.template +++ b/xcomp/erl-xcomp.conf.template @@ -264,4 +264,10 @@ # system must have reliable floating point exceptions. #erl_xcomp_reliable_fpe= +# * `erl_xcomp_posix_memalign' - `yes|no'. Defaults to `yes' if `posix_memalign' +# system call exists; otherwise `no'. If `yes', the target system must have a +# `posix_memalign' implementation that accepts larger than page size +# alignment. +#erl_xcomp_posix_memalign= + ## ----------------------------------------------------------------------------- |