From 763b1f87e769cbe617f30c9100fd61c81ef821e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Feb 2020 09:56:11 +0100 Subject: [PATCH 01/42] Switch CI to use Debian stable --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 43528960f..ff2bf03b8 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,4 +1,4 @@ -image: debian:testing +image: debian:stable before_script: - dpkg --add-architecture i386 From 297ae99c3f1959f387f59da535eb68f34ae523fe Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Mon, 6 Apr 2020 16:04:57 +1200 Subject: [PATCH 02/42] Add flag bits to the jit_reloc_kind enum --- lightening.h | 2 ++ lightening/lightening.c | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/lightening.h b/lightening.h index bcf2032fa..4749723bf 100644 --- a/lightening.h +++ b/lightening.h @@ -91,6 +91,8 @@ enum jit_reloc_kind JIT_RELOC_JCC_WITH_VENEER, JIT_RELOC_LOAD_FROM_POOL, #endif + JIT_RELOC_MASK = 15, + JIT_RELOC_FLAG_0 = 16, }; typedef struct jit_reloc diff --git a/lightening/lightening.c b/lightening/lightening.c index ca5708f0a..8d4c3d7cd 100644 --- a/lightening/lightening.c +++ b/lightening/lightening.c @@ -379,7 +379,7 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr) ASSERT((diff & ((1 << reloc.rsh) - 1)) == 0); diff >>= reloc.rsh; - switch (reloc.kind) + switch (reloc.kind & JIT_RELOC_MASK) { case JIT_RELOC_ABSOLUTE: if (sizeof(diff) == 4) @@ -1365,7 +1365,7 @@ emit_literal_pool(jit_state_t *_jit, enum guard_pool guard) if (_jit->overflow) return; - switch (entry->reloc.kind) { + switch (entry->reloc.kind & JIT_RELOC_MASK) { case JIT_RELOC_JMP_WITH_VENEER: patch_jmp_offset((uint32_t*) loc, diff); emit_veneer(_jit, (void*) (uintptr_t) entry->value); From aacaa6e38cda6154c5ab5d8d6bb2fe1b84feb256 Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Mon, 6 Apr 2020 19:44:03 +1200 Subject: [PATCH 03/42] Add separate functions for veneer patching --- lightening/aarch64.c | 8 ++++++-- lightening/arm-cpu.c | 12 ++++++++++++ lightening/lightening.c | 6 ++++-- 3 files changed, 22 insertions(+), 4 deletions(-) diff --git a/lightening/aarch64.c b/lightening/aarch64.c index 2e525166c..b605cc53a 100644 --- a/lightening/aarch64.c +++ b/lightening/aarch64.c @@ -114,8 +114,12 @@ DEFINE_ENCODER(size, 2, 22, unsigned, uint32_t) } \ } -DEFINE_PATCHABLE_INSTRUCTION(jmp, simm26, JMP_WITH_VENEER, 2); -DEFINE_PATCHABLE_INSTRUCTION(jcc, simm19, JCC_WITH_VENEER, 2); +#define DEFINE_PATCHABLE_INSTRUCTIONS(name, kind, RELOC, rsh) \ + DEFINE_PATCHABLE_INSTRUCTION(name, kind, RELOC, rsh); \ + DEFINE_PATCHABLE_INSTRUCTION(veneer_##name, kind, RELOC, rsh); + +DEFINE_PATCHABLE_INSTRUCTIONS(jmp, simm26, JMP_WITH_VENEER, 2); +DEFINE_PATCHABLE_INSTRUCTIONS(jcc, simm19, JCC_WITH_VENEER, 2); DEFINE_PATCHABLE_INSTRUCTION(load_from_pool, simm19, LOAD_FROM_POOL, 2); struct veneer diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index d96d57b2d..8e3b12196 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -325,6 +325,12 @@ patch_jmp_offset(uint32_t *loc, int32_t v) write_wide_thumb(loc, patch_thumb_jump(read_wide_thumb(loc), v)); } +static void +patch_veneer_jmp_offset(uint32_t *loc, int32_t v) +{ + patch_jmp_offset(loc, v); +} + static jit_reloc_t emit_thumb_jump(jit_state_t *_jit, uint32_t inst) { @@ -401,6 +407,12 @@ patch_jcc_offset(uint32_t *loc, int32_t v) write_wide_thumb(loc, patch_thumb_cc_jump(read_wide_thumb(loc), v)); } +static void +patch_veneer_jcc_offset(uint32_t *loc, int32_t v) +{ + patch_jcc_offset(loc, v); +} + static jit_reloc_t emit_thumb_cc_jump(jit_state_t *_jit, uint32_t inst) { diff --git a/lightening/lightening.c b/lightening/lightening.c index 8d4c3d7cd..09402634b 100644 --- a/lightening/lightening.c +++ b/lightening/lightening.c @@ -107,9 +107,11 @@ static void emit_literal_pool(jit_state_t *_jit, enum guard_pool guard); static int32_t read_jmp_offset(uint32_t *loc); static int offset_in_jmp_range(ptrdiff_t offset); static void patch_jmp_offset(uint32_t *loc, ptrdiff_t offset); +static void patch_veneer_jmp_offset(uint32_t *loc, ptrdiff_t offset); static int32_t read_jcc_offset(uint32_t *loc); static int offset_in_jcc_range(ptrdiff_t offset); static void patch_jcc_offset(uint32_t *loc, ptrdiff_t offset); +static void patch_veneer_jcc_offset(uint32_t *loc, ptrdiff_t offset); static void patch_veneer(uint32_t *loc, jit_pointer_t addr); static int32_t read_load_from_pool_offset(uint32_t *loc); #endif @@ -1367,11 +1369,11 @@ emit_literal_pool(jit_state_t *_jit, enum guard_pool guard) switch (entry->reloc.kind & JIT_RELOC_MASK) { case JIT_RELOC_JMP_WITH_VENEER: - patch_jmp_offset((uint32_t*) loc, diff); + patch_veneer_jmp_offset((uint32_t*) loc, diff); emit_veneer(_jit, (void*) (uintptr_t) entry->value); break; case JIT_RELOC_JCC_WITH_VENEER: - patch_jcc_offset((uint32_t*) loc, diff); + patch_veneer_jcc_offset((uint32_t*) loc, diff); emit_veneer(_jit, (void*) (uintptr_t) entry->value); break; case JIT_RELOC_LOAD_FROM_POOL: From 1656fc1d81e7e2978edd3438c4390de6f95c471b Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 17:31:25 +1200 Subject: [PATCH 04/42] Add a test for local forward and backward jumps --- tests/jmpi_local.c | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 tests/jmpi_local.c diff --git a/tests/jmpi_local.c b/tests/jmpi_local.c new file mode 100644 index 000000000..49e450732 --- /dev/null +++ b/tests/jmpi_local.c @@ -0,0 +1,25 @@ +#include "test.h" + +static void +run_test(jit_state_t *j, uint8_t *arena_base, size_t arena_size) +{ + jit_begin(j, arena_base, arena_size); + + jit_reloc_t r = jit_jmp (j); + jit_reti (j, 0); + jit_pointer_t addr = jit_address (j); + jit_reti (j, 1); + jit_patch_here (j, r); + jit_jmpi (j, addr); + jit_reti (j, 2); + + int (*f)(void) = jit_end(j, NULL); + + ASSERT(f() == 1); +} + +int +main (int argc, char *argv[]) +{ + return main_helper(argc, argv, run_test); +} From ba24ce465f3d0b8a3888e4a668f7410b49415c12 Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 19:36:13 +1200 Subject: [PATCH 05/42] Use an rsh of 0 for jumps on ARM This will allow supporting jumping to ARM (as opposed to Thumb) code. --- lightening/arm-cpu.c | 44 ++++++++++++++++++++------------------------ 1 file changed, 20 insertions(+), 24 deletions(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 8e3b12196..9f7876ee3 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -267,7 +267,7 @@ write_wide_thumb(uint32_t *loc, uint32_t v) static int offset_in_jmp_range(int32_t offset) { - return -0x800000 <= offset && offset <= 0x7fffff; + return -0x1000000 <= offset && offset <= 0xffffff; } static int32_t @@ -287,7 +287,7 @@ decode_thumb_jump(uint32_t v) ret |= i2 << 21; ret |= hi << 11; ret |= lo; - return ret; + return ret << 1; } static const uint32_t thumb_jump_mask = 0xf800d000; @@ -296,13 +296,14 @@ static uint32_t encode_thumb_jump(int32_t v) { ASSERT(offset_in_jmp_range(v)); + v >>= 1; uint32_t s = !!(v & 0x800000); uint32_t i1 = !!(v & 0x400000); uint32_t i2 = !!(v & 0x200000); uint32_t j1 = s ? i1 : !i1; uint32_t j2 = s ? i2 : !i2; uint32_t ret = (s<<26)|((v&0x1ff800)<<5)|(j1<<13)|(j2<<11)|(v&0x7ff); - ASSERT(decode_thumb_jump(ret) == v); + ASSERT(decode_thumb_jump(ret) == v << 1); ASSERT((ret & thumb_jump_mask) == 0); return ret; } @@ -322,13 +323,14 @@ read_jmp_offset(uint32_t *loc) static void patch_jmp_offset(uint32_t *loc, int32_t v) { - write_wide_thumb(loc, patch_thumb_jump(read_wide_thumb(loc), v)); + write_wide_thumb(loc, patch_thumb_jump(read_wide_thumb(loc), v | 1)); } static void patch_veneer_jmp_offset(uint32_t *loc, int32_t v) { - patch_jmp_offset(loc, v); + ASSERT(!(v & 1)); + patch_jmp_offset(loc, v | 1); } static jit_reloc_t @@ -336,10 +338,9 @@ emit_thumb_jump(jit_state_t *_jit, uint32_t inst) { while (1) { uint8_t *pc_base = _jit->pc.uc + 4; - uint8_t rsh = 1; - int32_t off = (_jit->pc.uc - pc_base) >> rsh; + int32_t off = (uint8_t*)jit_address(_jit) - pc_base; jit_reloc_t ret = - jit_reloc (_jit, JIT_RELOC_JMP_WITH_VENEER, 0, _jit->pc.uc, pc_base, rsh); + jit_reloc (_jit, JIT_RELOC_JMP_WITH_VENEER, 0, _jit->pc.uc, pc_base, 0); uint8_t thumb_jump_width = 24; if (add_pending_literal(_jit, ret, thumb_jump_width - 1)) { emit_wide_thumb(_jit, patch_thumb_jump(inst, off)); @@ -351,7 +352,7 @@ emit_thumb_jump(jit_state_t *_jit, uint32_t inst) static int offset_in_jcc_range(int32_t v) { - return -0x80000 <= v && v <= 0x7ffff; + return -0x100000 <= v && v <= 0xfffff; } static int32_t @@ -369,7 +370,7 @@ decode_thumb_cc_jump(uint32_t v) ret |= j1 << 17; ret |= hi << 11; ret |= lo; - return ret; + return ret << 1; } static const uint32_t thumb_cc_jump_mask = 0xfbc0d000; @@ -378,13 +379,14 @@ static uint32_t encode_thumb_cc_jump(int32_t v) { ASSERT(offset_in_jcc_range(v)); + v >>= 1; uint32_t s = !!(v & 0x80000); uint32_t j2 = !!(v & 0x40000); uint32_t j1 = !!(v & 0x20000); uint32_t hi = (v >> 11) & 0x3f; uint32_t lo = v & 0x7ff; uint32_t ret = (s<<26)|(hi << 16)|(j1<<13)|(j2<<11)|lo; - ASSERT(decode_thumb_cc_jump(ret) == v); + ASSERT(decode_thumb_cc_jump(ret) == v << 1); ASSERT((ret & thumb_cc_jump_mask) == 0); return ret; } @@ -404,13 +406,14 @@ read_jcc_offset(uint32_t *loc) static void patch_jcc_offset(uint32_t *loc, int32_t v) { - write_wide_thumb(loc, patch_thumb_cc_jump(read_wide_thumb(loc), v)); + write_wide_thumb(loc, patch_thumb_cc_jump(read_wide_thumb(loc), v | 1)); } static void patch_veneer_jcc_offset(uint32_t *loc, int32_t v) { - patch_jcc_offset(loc, v); + ASSERT(!(v & 1)); + patch_jcc_offset(loc, v | 1); } static jit_reloc_t @@ -418,10 +421,9 @@ emit_thumb_cc_jump(jit_state_t *_jit, uint32_t inst) { while (1) { uint8_t *pc_base = _jit->pc.uc + 4; - uint8_t rsh = 1; - int32_t off = (_jit->pc.uc - pc_base) >> rsh; + int32_t off = (uint8_t*)jit_address(_jit) - pc_base; jit_reloc_t ret = - jit_reloc (_jit, JIT_RELOC_JCC_WITH_VENEER, 0, _jit->pc.uc, pc_base, rsh); + jit_reloc (_jit, JIT_RELOC_JCC_WITH_VENEER, 0, _jit->pc.uc, pc_base, 0); uint8_t thumb_cc_jump_width = 20; if (add_pending_literal(_jit, ret, thumb_cc_jump_width - 1)) { emit_wide_thumb(_jit, patch_thumb_cc_jump(inst, off)); @@ -2076,8 +2078,6 @@ jmp(jit_state_t *_jit) static void jmpi(jit_state_t *_jit, jit_word_t i0) { - /* Strip thumb bit, if any. */ - i0 &= ~1; return jit_patch_there(_jit, jmp(_jit), (void*)i0); } @@ -2917,10 +2917,7 @@ callr(jit_state_t *_jit, int32_t r0) static void calli(jit_state_t *_jit, jit_word_t i0) { - if (i0 & 1) - jit_patch_there(_jit, T2_BLI(_jit), (void*)(i0 & ~1)); - else - jit_patch_there(_jit, T2_BLXI(_jit), (void*)i0); + jit_patch_there(_jit, T2_BLI(_jit), (void*)i0); } static void @@ -3002,8 +2999,7 @@ static void patch_jmp_without_veneer(jit_state_t *_jit, uint32_t *loc) { uint8_t *pc_base = ((uint8_t *)loc) + 4; - uint8_t rsh = 1; - int32_t off = (_jit->pc.uc - pc_base) >> rsh; + int32_t off = (uint8_t*)jit_address(_jit) - pc_base; write_wide_thumb(loc, THUMB2_B | encode_thumb_jump(off)); } From 8045386a4597454507b31139ad87e5ea6fe5164a Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 19:30:18 +1200 Subject: [PATCH 06/42] Return a function pointer from jit_address This will allow supporting ARM code on armv7 without having to change any users of Lightening. --- lightening/lightening.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lightening/lightening.c b/lightening/lightening.c index 09402634b..92e40c4bf 100644 --- a/lightening/lightening.c +++ b/lightening/lightening.c @@ -171,7 +171,7 @@ jit_pointer_t jit_address(jit_state_t *_jit) { ASSERT (_jit->start); - return _jit->pc.uc; + return jit_address_to_function_pointer (_jit->pc.uc); } void From 7f5f26269f7f70dfa78f032b42448b4fbd4ab501 Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 20:37:12 +1200 Subject: [PATCH 07/42] Stop setting the thumb bit except on jumps to veneers Thanks to the previous commit, the jump targets should all be correct. --- lightening/arm-cpu.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 9f7876ee3..9b328adc5 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -323,7 +323,7 @@ read_jmp_offset(uint32_t *loc) static void patch_jmp_offset(uint32_t *loc, int32_t v) { - write_wide_thumb(loc, patch_thumb_jump(read_wide_thumb(loc), v | 1)); + write_wide_thumb(loc, patch_thumb_jump(read_wide_thumb(loc), v)); } static void @@ -406,7 +406,7 @@ read_jcc_offset(uint32_t *loc) static void patch_jcc_offset(uint32_t *loc, int32_t v) { - write_wide_thumb(loc, patch_thumb_cc_jump(read_wide_thumb(loc), v | 1)); + write_wide_thumb(loc, patch_thumb_cc_jump(read_wide_thumb(loc), v)); } static void From a6fee1add8043f54b3adfe9e539b25c69456d2d6 Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 21:24:51 +1200 Subject: [PATCH 08/42] Use bx instead of mov for jumps on ARM --- lightening/arm-cpu.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 9b328adc5..3cea9f878 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -2066,7 +2066,7 @@ rshi_u(jit_state_t *_jit, int32_t r0, int32_t r1, jit_word_t i0) static void jmpr(jit_state_t *_jit, int32_t r0) { - T1_MOV(_jit, jit_gpr_regno(_PC), r0); + T1_BX(_jit, r0); } static jit_reloc_t @@ -3022,11 +3022,10 @@ emit_veneer(jit_state_t *_jit, jit_pointer_t target) { uint16_t thumb1_ldr = 0x4800; int32_t tmp = jit_gpr_regno(JIT_TMP1); - int32_t rd = jit_gpr_regno(_PC); ASSERT(tmp < 8); // Loaded addr is 4 bytes after the LDR, which is aligned, so offset is 0. emit_u16(_jit, thumb1_ldr | (tmp << 8)); - emit_u16(_jit, THUMB_MOV|((_u4(rd)&8)<<4)|(_u4(tmp)<<3)|(rd&7)); + emit_u16(_jit, THUMB_BX|(_u4(tmp)<<3)); emit_u32(_jit, (uint32_t) target); } From 52ec8aefa0c6a4926c61b9e027fce7256034ad6e Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 21:26:57 +1200 Subject: [PATCH 09/42] Remove T2_BLXI --- lightening/arm-cpu.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 3cea9f878..192c70583 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -1042,12 +1042,6 @@ T2_BLI(jit_state_t *_jit) return tb(_jit, THUMB2_BLI); } -static jit_reloc_t -T2_BLXI(jit_state_t *_jit) -{ - return tb(_jit, THUMB2_BLXI); -} - enum dmb_option { DMB_ISH = 0xb }; static void T1_DMB(jit_state_t *_jit, enum dmb_option option) From 11b9d3744e963a121270712199bbfa7edb70d245 Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 22:10:15 +1200 Subject: [PATCH 10/42] Always emit veneers for non-bl jumps to ARM code It is unlikely for any ARM code to be close enough to not have needed a veneer, but it is possible, especially if running in a program with another JIT library. --- lightening/aarch64.c | 4 ++-- lightening/arm-cpu.c | 26 ++++++++++++++++++-------- lightening/lightening.c | 9 +++++---- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/lightening/aarch64.c b/lightening/aarch64.c index b605cc53a..2b3ed4d60 100644 --- a/lightening/aarch64.c +++ b/lightening/aarch64.c @@ -90,9 +90,9 @@ DEFINE_ENCODER(size, 2, 22, unsigned, uint32_t) { \ return read_signed_bitfield(*loc, kind##_width, kind##_shift); \ } \ - static int offset_in_##name##_range(ptrdiff_t diff) maybe_unused; \ + static int offset_in_##name##_range(ptrdiff_t diff, int flags) maybe_unused; \ static int \ - offset_in_##name##_range(ptrdiff_t diff) \ + offset_in_##name##_range(ptrdiff_t diff, int flags) \ { \ return in_signed_range(diff, kind##_width); \ } \ diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 192c70583..1bb739467 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -186,6 +186,8 @@ #define _NOREG (jit_gpr_regno(_PC)) +#define JIT_RELOC_B JIT_RELOC_FLAG_0 + static void emit_wide_thumb(jit_state_t *_jit, uint32_t inst) { @@ -265,9 +267,12 @@ write_wide_thumb(uint32_t *loc, uint32_t v) } static int -offset_in_jmp_range(int32_t offset) +offset_in_jmp_range(int32_t offset, int flags) { - return -0x1000000 <= offset && offset <= 0xffffff; + if (!(offset & 1) && flags | JIT_RELOC_B) + return 0; + else + return -0x1000000 <= offset && offset <= 0xffffff; } static int32_t @@ -295,7 +300,7 @@ static const uint32_t thumb_jump_mask = 0xf800d000; static uint32_t encode_thumb_jump(int32_t v) { - ASSERT(offset_in_jmp_range(v)); + ASSERT(offset_in_jmp_range(v, 0)); v >>= 1; uint32_t s = !!(v & 0x800000); uint32_t i1 = !!(v & 0x400000); @@ -339,8 +344,10 @@ emit_thumb_jump(jit_state_t *_jit, uint32_t inst) while (1) { uint8_t *pc_base = _jit->pc.uc + 4; int32_t off = (uint8_t*)jit_address(_jit) - pc_base; - jit_reloc_t ret = - jit_reloc (_jit, JIT_RELOC_JMP_WITH_VENEER, 0, _jit->pc.uc, pc_base, 0); + enum jit_reloc_kind kind = JIT_RELOC_JMP_WITH_VENEER; + if (inst == THUMB2_B) + kind |= JIT_RELOC_B; + jit_reloc_t ret = jit_reloc (_jit, kind, 0, _jit->pc.uc, pc_base, 0); uint8_t thumb_jump_width = 24; if (add_pending_literal(_jit, ret, thumb_jump_width - 1)) { emit_wide_thumb(_jit, patch_thumb_jump(inst, off)); @@ -350,9 +357,12 @@ emit_thumb_jump(jit_state_t *_jit, uint32_t inst) } static int -offset_in_jcc_range(int32_t v) +offset_in_jcc_range(int32_t v, int flags) { - return -0x100000 <= v && v <= 0xfffff; + if (!(v & 1)) + return 0; + else + return -0x100000 <= v && v <= 0xfffff; } static int32_t @@ -378,7 +388,7 @@ static const uint32_t thumb_cc_jump_mask = 0xfbc0d000; static uint32_t encode_thumb_cc_jump(int32_t v) { - ASSERT(offset_in_jcc_range(v)); + ASSERT(offset_in_jcc_range(v, 0)); v >>= 1; uint32_t s = !!(v & 0x80000); uint32_t j2 = !!(v & 0x40000); diff --git a/lightening/lightening.c b/lightening/lightening.c index 92e40c4bf..66207885f 100644 --- a/lightening/lightening.c +++ b/lightening/lightening.c @@ -105,11 +105,11 @@ enum guard_pool { GUARD_NEEDED, NO_GUARD_NEEDED }; static void emit_literal_pool(jit_state_t *_jit, enum guard_pool guard); static int32_t read_jmp_offset(uint32_t *loc); -static int offset_in_jmp_range(ptrdiff_t offset); +static int offset_in_jmp_range(ptrdiff_t offset, int flags); static void patch_jmp_offset(uint32_t *loc, ptrdiff_t offset); static void patch_veneer_jmp_offset(uint32_t *loc, ptrdiff_t offset); static int32_t read_jcc_offset(uint32_t *loc); -static int offset_in_jcc_range(ptrdiff_t offset); +static int offset_in_jcc_range(ptrdiff_t offset, int flags); static void patch_jcc_offset(uint32_t *loc, ptrdiff_t offset); static void patch_veneer_jcc_offset(uint32_t *loc, ptrdiff_t offset); static void patch_veneer(uint32_t *loc, jit_pointer_t addr); @@ -380,6 +380,7 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr) ptrdiff_t diff = (uint8_t*)addr - pc_base; ASSERT((diff & ((1 << reloc.rsh) - 1)) == 0); diff >>= reloc.rsh; + int flags = reloc.kind & ~JIT_RELOC_MASK; switch (reloc.kind & JIT_RELOC_MASK) { @@ -406,7 +407,7 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr) uint8_t *target = pc_base + (voff << reloc.rsh); if (target == loc.uc) { // PC still in range to reify direct branch. - if (offset_in_jmp_range(diff)) { + if (offset_in_jmp_range(diff, flags)) { // Target also in range: reify direct branch. patch_jmp_offset(loc.ui, diff); remove_pending_literal(_jit, reloc); @@ -425,7 +426,7 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr) int32_t voff = read_jcc_offset(loc.ui); uint8_t *target = pc_base + (voff << reloc.rsh); if (target == loc.uc) { - if (offset_in_jcc_range(diff)) { + if (offset_in_jcc_range(diff, flags)) { patch_jcc_offset(loc.ui, diff); remove_pending_literal(_jit, reloc); } else { From 0ff3b3163c3bf7bc9b498403428999deb771d2cd Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 21:32:55 +1200 Subject: [PATCH 11/42] Convert BLI to BLXI for jumps to ARM code With this, Guile builds and runs in both ARM and Thumb mode. Closes: #12 --- lightening/arm-cpu.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 1bb739467..0e38883ef 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -316,7 +316,13 @@ encode_thumb_jump(int32_t v) static uint32_t patch_thumb_jump(uint32_t inst, int32_t v) { - return (inst & thumb_jump_mask) | encode_thumb_jump(v); + inst &= thumb_jump_mask; + if (!(v & 1)) { + ASSERT(inst == THUMB2_BLI || inst == THUMB2_BLXI); + v = (v + 2) & ~2; + inst = THUMB2_BLXI; + } + return inst | encode_thumb_jump(v); } static int32_t From 2a4ed4b77648fc6cc640c1b6bd9a4019cd6a1974 Mon Sep 17 00:00:00 2001 From: Icecream95 Date: Thu, 9 Apr 2020 22:34:21 +1200 Subject: [PATCH 12/42] Add CI jobs for ARM in both instruction sets --- .gitlab-ci.yml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ff2bf03b8..0360cf0c7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -30,4 +30,9 @@ aarch64: armhf: stage: test script: - - make -C tests test-armv7 CC_ARMv7=arm-linux-gnueabihf-gcc + - make -C tests test-armv7 CC_ARMv7="arm-linux-gnueabihf-gcc -marm" + +armhf-thumb: + stage: test + script: + - make -C tests test-armv7 CC_ARMv7="arm-linux-gnueabihf-gcc -mthumb" From fc139231a67d97aaa29509e61c8f616c6b7f23ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 12 Jun 2020 15:58:54 +0200 Subject: [PATCH 13/42] Make CSE more robust * module/language/cps/cse.scm (eliminate-common-subexpressions-in-fun): I think it's possible to get an orphan loop, with predecessors after successors in the original RPO. Handle that here. --- module/language/cps/cse.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 5fe89ce47..3cc48cdf7 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -551,7 +551,11 @@ false. It could be that both true and false proofs are available." (prune-successors analysis label (term-successors term)))) ((trivial-intset preds) => (lambda (pred) - (match (intmap-ref out pred) + (match (and (< pred label) (intmap-ref out pred)) + (#f + ;; Orphan loop; branch folding must have removed + ;; entry. Could still be alive though. + (visit-term-normally)) (($ $kargs names' vars' ($ $continue _ _ ($ $values vals))) ;; Substitute dominating definitions, and try to elide the ;; predecessor entirely. @@ -583,7 +587,7 @@ false. It could be that both true and false proofs are available." ;; those as well. (add-auxiliary-definitions! pred vars substs term-key))) (visit-term-normally)) - (_ + ((or ($ $kclause) ($ $kreceive)) (visit-term-normally))))) (else (visit-term-normally))))))) From c7dec0b2317fedafe6eb9c26d584dd853f47c83d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 12 Jun 2020 12:42:48 +0200 Subject: [PATCH 14/42] doc: Remove copy/pasted sentence. * doc/ref/api-io.texi (I/O Extensions): Remove sentence pasted from 'read' when explaining 'write' method. --- doc/ref/api-io.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 270a97075..ecbd35585 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1596,7 +1596,7 @@ of bytes read. @item write A port's @code{write} implementation flushes write buffers to the -mutable store. A port's @code{read} implementation fills read buffers. +mutable store. It should write out bytes from the supplied bytevector @code{src}, starting at offset @code{start} and continuing for @code{count} bytes, and return the number of bytes that were written. From 2e2e13c40a38a399daf6466f95c8975600ab5ded Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 15 Jun 2020 10:08:57 +0200 Subject: [PATCH 15/42] Update NEWS. * NEWS: Update. --- NEWS | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/NEWS b/NEWS index ae2a1d73e..6a86482c7 100644 --- a/NEWS +++ b/NEWS @@ -45,6 +45,11 @@ the first Scheme compiler. Because the baseline compiler runs faster and includes less code than the CPS compiler, Guile takes less time to build. +** New 'pipeline' procedure in (ice-9 popen) + +The 'pipeline' procedure provides a simple way to spawn command pipeline +as one would do in a shell. + ** Refreshed bitvector facility See "Bit Vectors" in the manual, for more on all of these. @@ -80,6 +85,21 @@ This replaces bit-invert!. These replace the wonky "bit-set*!" procedure. +* Bug fixes + +** statprof reports the names of primitives + +Previously statprof would show strings like "anon #x1234" for primitives +written in C. + +** 'http-get', 'http-post', etc. now honor #:verify-certificates? + () + +** (web http) parser recognizes the CONNECT and PATCH methods + +** Initial revealed count of file ports is now zero + () + * New deprecations ** Old bitvector interfaces deprecated From 0360843acee98f26598d8f77eda880a03ea3be93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 17 Jun 2020 16:59:50 +0200 Subject: [PATCH 16/42] srfi-1: Rewrite 'find' in Scheme. This halves the wall-clock time of: guile -c '(use-modules (srfi srfi-1)) (define lst (make-list 100000000 1)) (find zero? lst)' and yields an 18% speedup on: guile -c '(use-modules (srfi srfi-1)) (define lst (make-list 100000000 1)) (find (lambda (x) (= 2 x)) lst)' * libguile/srfi-1.c (scm_srfi1_find): Remove. * libguile/srfi-1.h (scm_srfi1_find): Likewise. * module/srfi/srfi-1.scm (find): New procedure. * doc/ref/srfi-modules.texi (SRFI-1 Searching): Adjust docstring. --- doc/ref/srfi-modules.texi | 4 ++-- libguile/srfi-1.c | 25 +------------------------ libguile/srfi-1.h | 3 +-- module/srfi/srfi-1.scm | 13 ++++++++++++- 4 files changed, 16 insertions(+), 29 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 9de8396d7..2e66bafb9 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019 +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -824,7 +824,7 @@ predicate or a comparison object for determining which elements are to be searched. @deffn {Scheme Procedure} find pred lst -Return the first element of @var{lst} which satisfies the predicate +Return the first element of @var{lst} that satisfies the predicate @var{pred} and @code{#f} if no such element is found. @end deffn diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index ca812935a..39291a439 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -1,6 +1,6 @@ /* srfi-1.c --- SRFI-1 procedures for Guile - Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018 + Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018,2020 Free Software Foundation, Inc. This file is part of Guile. @@ -575,29 +575,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0, - (SCM pred, SCM lst), - "Return the first element of @var{lst} which satisfies the\n" - "predicate @var{pred}, or return @code{#f} if no such element is\n" - "found.") -#define FUNC_NAME s_scm_srfi1_find -{ - SCM_VALIDATE_PROC (SCM_ARG1, pred); - - for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) - { - SCM elem = SCM_CAR (lst); - if (scm_is_true (scm_call_1 (pred, elem))) - return elem; - } - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); - - return SCM_BOOL_F; -} -#undef FUNC_NAME - - SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0, (SCM pred, SCM lst), "Return the first pair of @var{lst} whose @sc{car} satisfies the\n" diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index 82efaef42..fa21dc42a 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -1,5 +1,5 @@ /* srfi-1.h --- SRFI-1 procedures for Guile - Copyright 2002-2003,2005-2006,2010-2011,2018 + Copyright 2002-2003,2005-2006,2010-2011,2018,2020 Free Software Foundation, Inc. This file is part of Guile. @@ -33,7 +33,6 @@ SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred); -SCM_INTERNAL SCM scm_srfi1_find (SCM pred, SCM lst); SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst); SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst); SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index c0ee53548..e5b28e777 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -1,6 +1,6 @@ ;;; srfi-1.scm --- List Library -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014, 2020 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -720,6 +720,17 @@ the list returned." ;;; Searching +(define (find pred lst) + "Return the first element of @var{lst} that satisfies the predicate +@var{pred}, or return @code{#f} if no such element is found." + (check-arg procedure? pred find) + (let loop ((lst lst)) + (and (not (null? lst)) + (let ((head (car lst))) + (if (pred head) + head + (loop (cdr lst))))))) + (define (take-while pred ls) "Return a new list which is the longest initial prefix of LS whose elements all satisfy the predicate PRED." From cd4c747fb8cd6c65f18471aad54427d87b884ebc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 17 Jun 2020 17:33:28 +0200 Subject: [PATCH 17/42] srfi-1: Rewrite 'find-tail' in Scheme. * libguile/srfi-1.c (scm_srfi1_find_tail): Remove. * libguile/srfi-1.h (scm_srfi1_find_tail): Likewise. * module/srfi/srfi-1.scm (find-tail): New procedure. --- libguile/srfi-1.c | 18 ------------------ libguile/srfi-1.h | 1 - module/srfi/srfi-1.scm | 11 +++++++++++ 3 files changed, 11 insertions(+), 19 deletions(-) diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 39291a439..1651bcd5b 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -575,24 +575,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0, - (SCM pred, SCM lst), - "Return the first pair of @var{lst} whose @sc{car} satisfies the\n" - "predicate @var{pred}, or return @code{#f} if no such element is\n" - "found.") -#define FUNC_NAME s_scm_srfi1_find_tail -{ - SCM_VALIDATE_PROC (SCM_ARG1, pred); - - for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) - if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst)))) - return lst; - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); - - return SCM_BOOL_F; -} -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, (SCM lst), "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n" diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index fa21dc42a..3faaaa428 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -33,7 +33,6 @@ SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred); -SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst); SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst); SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest); SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index e5b28e777..1fc7a0e26 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -731,6 +731,17 @@ the list returned." head (loop (cdr lst))))))) +(define (find-tail pred lst) + "Return the first pair of @var{lst} whose @sc{car} satisfies the +predicate @var{pred}, or return @code{#f} if no such element is found." + (check-arg procedure? pred find) + (let loop ((lst lst)) + (and (not (null? lst)) + (let ((head (car lst))) + (if (pred head) + lst + (loop (cdr lst))))))) + (define (take-while pred ls) "Return a new list which is the longest initial prefix of LS whose elements all satisfy the predicate PRED." From a15acbb828dd2e75b35bbc76d48858b230591639 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 17 Jun 2020 17:59:35 +0200 Subject: [PATCH 18/42] srfi-1: Rewrite 'assoc' in Scheme. * libguile/srfi-1.c (scm_srfi1_assoc): Remove. * libguile/srfi-1.h (scm_srfi1_assoc): Likewise. * module/srfi/srfi-1.scm (assoc): New procedure. --- libguile/srfi-1.c | 31 ------------------------------- libguile/srfi-1.h | 1 - module/srfi/srfi-1.scm | 17 +++++++++++++++++ 3 files changed, 17 insertions(+), 32 deletions(-) diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 1651bcd5b..b18ba41c7 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -710,37 +710,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0, - (SCM key, SCM alist, SCM pred), - "Behaves like @code{assq} but uses third argument @var{pred}\n" - "for key comparison. If @var{pred} is not supplied,\n" - "@code{equal?} is used. (Extended from R5RS.)\n") -#define FUNC_NAME s_scm_srfi1_assoc -{ - SCM ls = alist; - scm_t_trampoline_2 equal_p; - if (SCM_UNBNDP (pred)) - equal_p = equal_trampoline; - else - { - SCM_VALIDATE_PROC (SCM_ARG3, pred); - equal_p = scm_call_2; - } - for(; scm_is_pair (ls); ls = SCM_CDR (ls)) - { - SCM tmp = SCM_CAR (ls); - SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME, - "association list"); - if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp)))) - return tmp; - } - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, - "association list"); - return SCM_BOOL_F; -} -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, (SCM pred, SCM list), "Partition the elements of @var{list} with predicate @var{pred}.\n" diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index 3faaaa428..9dafb9c0d 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -36,7 +36,6 @@ SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst); SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest); SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst); -SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred); SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list); SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list); SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 1fc7a0e26..680ee94b5 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -923,6 +923,23 @@ and those making the associations." ;;; Delete / assoc / member +(define* (assoc key alist #:optional (= equal?)) + "Behaves like @code{assq} but uses third argument @var{pred} for key +comparison. If @var{pred} is not supplied, @code{equal?} is +used. (Extended from R5RS.)" + (cond + ((eq? = eq?) (assq key alist)) + ((eq? = eqv?) (assv key alist)) + (else + (check-arg procedure? = assoc) + (let loop ((alist alist)) + (and (pair? alist) + (let ((item (car alist))) + (check-arg pair? item assoc) + (if (= key (car item)) + item + (loop (cdr alist))))))))) + (define* (member x ls #:optional (= equal?)) (cond ;; This might be performance-sensitive, so punt on the check here, From 52809cc63031d4b83323aa9e3dcb780f02849484 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Thu, 4 Jun 2020 21:26:23 +0200 Subject: [PATCH 19/42] read: Use "invalid" rather than "illegal". MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/read.c (scm_read_string_like_syntax): All characters are permitted by law; some aren't valid in certain contexts. * test-suite/tests/reader.test: Replace occurrences of "illegal" by "invalid". * test-suite/tests/strings.test: Likewise. Co-authored-by: Ludovic Courtès --- libguile/read.c | 2 +- test-suite/tests/reader.test | 20 ++++++++++---------- test-suite/tests/strings.test | 18 +++++++++--------- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 040a17834..122a64301 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -704,7 +704,7 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) break; bad_escaped: scm_i_input_error (FUNC_NAME, port, - "illegal character in escape sequence: ~S", + "invalid character in escape sequence: ~S", scm_list_1 (SCM_MAKE_CHAR (c))); } } diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index a931f0416..ef11a4abd 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -1,6 +1,6 @@ ;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*- ;;;; -;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015 +;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020 ;;;; Free Software Foundation, Inc. ;;;; ;;;; Jim Blandy @@ -40,8 +40,8 @@ (cons 'read-error "end of file in string constant$")) (define exception:eof-in-symbol (cons 'read-error "end of file while reading symbol$")) -(define exception:illegal-escape - (cons 'read-error "illegal character in escape sequence: .*$")) +(define exception:invalid-escape + (cons 'read-error "invalid character in escape sequence: .*$")) (define exception:missing-expression (cons 'read-error "no expression after #;")) (define exception:mismatched-paren @@ -234,8 +234,8 @@ (pass-if-exception "eof in string" exception:eof-in-string (read-string "\"the string that never ends")) - (pass-if-exception "illegal escape in string" - exception:illegal-escape + (pass-if-exception "invalid escape in string" + exception:invalid-escape (read-string "\"some string \\???\""))) @@ -304,31 +304,31 @@ (with-test-prefix "r6rs-hex-escapes" (pass-if-exception "non-hex char in two-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-read-options '(r6rs-hex-escapes) (lambda () (with-input-from-string "\"\\x0g;\"" read)))) (pass-if-exception "non-hex char in four-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-read-options '(r6rs-hex-escapes) (lambda () (with-input-from-string "\"\\x000g;\"" read)))) (pass-if-exception "non-hex char in six-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-read-options '(r6rs-hex-escapes) (lambda () (with-input-from-string "\"\\x00000g;\"" read)))) (pass-if-exception "no semicolon at termination of one-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-read-options '(r6rs-hex-escapes) (lambda () (with-input-from-string "\"\\x0\"" read)))) (pass-if-exception "no semicolon at termination of three-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-read-options '(r6rs-hex-escapes) (lambda () (with-input-from-string "\"\\x000\"" read)))) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 52b3dd034..7393bc8ec 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,7 +1,7 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy --- August 1999 ;;;; -;;;; Copyright (C) 1999,2001,2004-2006,2008-2011,2013,2015,2018 +;;;; Copyright (C) 1999,2001,2004-2006,2008-2011,2013,2015,2018,2020 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -25,8 +25,8 @@ (define exception:read-only-string (cons 'misc-error "^string is read-only")) -(define exception:illegal-escape - (cons 'read-error "illegal character in escape sequence")) +(define exception:invalid-escape + (cons 'read-error "invalid character in escape sequence")) ;; Create a string from integer char values, eg. (string-ints 65) => "A" (define (string-ints . args) @@ -197,27 +197,27 @@ (with-test-prefix "escapes" (pass-if-exception "non-hex char in two-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-input-from-string "\"\\x0g\"" read)) (pass-if-exception "non-hex char in four-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-input-from-string "\"\\u000g\"" read)) (pass-if-exception "non-hex char in six-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-input-from-string "\"\\U00000g\"" read)) (pass-if-exception "premature termination of two-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-input-from-string "\"\\x0\"" read)) (pass-if-exception "premature termination of four-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-input-from-string "\"\\u000\"" read)) (pass-if-exception "premature termination of six-digit hex-escape" - exception:illegal-escape + exception:invalid-escape (with-input-from-string "\"\\U00000\"" read)) (pass-if "extra hex digits ignored for two-digit hex escape" From 5fbf5c10fc3054d788a006f619105a8c60741319 Mon Sep 17 00:00:00 2001 From: "Ricardo G. Herdt" Date: Sat, 30 May 2020 22:50:16 +0200 Subject: [PATCH 20/42] doc: Add missing canonicalize-path documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The documentation is copied over from libguile/filesys.c. I just added "(absolute)" to the text to help users finding it, since this term is more common in other languages. * doc/ref/posix.texi (File System): Document it. Signed-off-by: Ludovic Courtès --- doc/ref/posix.texi | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index b2be9d707..f34c5222d 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1040,6 +1040,21 @@ If @var{suffix} is provided, and is equal to the end of @end lisp @end deffn +@deffn {Scheme Procedure} canonicalize-path path +@deffnx {C Function} scm_canonicalize_path (path) +Return the canonical (absolute) path of @var{path}. +A canonical path has no @code{.} or @code{..} components, +nor any repeated path separators (@code{/}) nor symlinks. + +Raises an error if any component of @var{path} does not +exist. + +@lisp +(canonicalize-path "test.xml") +@result{} "/tmp/test.xml" +@end lisp +@end deffn + @deffn {Scheme Procedure} file-exists? filename Return @code{#t} if the file named @var{filename} exists, @code{#f} if not. From a43aa1bc79b99321e8569e644008907d5841e334 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 18 Jun 2020 00:25:15 +0200 Subject: [PATCH 21/42] texinfo: Add basic support for @w{...}. * module/texinfo.scm (texi-command-specs): Add 'w'. (space-significant?): Add it. * module/texinfo/html.scm (tag-replacements): Add 'w'. * test-suite/tests/texinfo.test ("test-texinfo->stexinfo"): Add test. --- module/texinfo.scm | 5 +++-- module/texinfo/html.scm | 3 ++- test-suite/tests/texinfo.test | 4 +++- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/module/texinfo.scm b/module/texinfo.scm index f3af5c332..ff95f182d 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -1,6 +1,6 @@ ;;;; (texinfo) -- parsing of texinfo into SXML ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2020 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo ;;;; Copyright (C) 2001,2002 Oleg Kiselyov ;;;; @@ -211,6 +211,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, (sansserif INLINE-TEXT) (slanted INLINE-TEXT) (t INLINE-TEXT) + (w INLINE-TEXT) ;; Inline args commands (value INLINE-ARGS . (key)) @@ -382,7 +383,7 @@ Examples: ;; The % is for arguments (define (space-significant? command) (memq command - '(example smallexample verbatim lisp smalllisp menu %))) + '(example smallexample verbatim lisp smalllisp menu w %))) ;; Like a DTD for texinfo (define (command-spec command) diff --git a/module/texinfo/html.scm b/module/texinfo/html.scm index d505d7f12..6d139ddeb 100644 --- a/module/texinfo/html.scm +++ b/module/texinfo/html.scm @@ -1,6 +1,6 @@ ;;;; (texinfo html) -- translating stexinfo into shtml ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2020 Free Software Foundation, Inc. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -202,6 +202,7 @@ name, @code{#}, and the node name." (*fragment* div) ;; should be ok (asis span) + (w span (@ (class "verbatim"))) (bold b) (i i) (sample samp) diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 6f7d4c7d8..416fd286c 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -1,6 +1,6 @@ ;;;; texinfo.test -*- scheme -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2020 Free Software Foundation, Inc. ;;;; Copyright (C) 2001,2002 Oleg Kiselyov ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -221,6 +221,8 @@ '((para (code "abc " (code))))) (test-body "@code{ arg }" '((para (code "arg")))) + (test-body "@w{ arg with spaces }" + '((para (w " arg with spaces ")))) (test-body "@acronym{GNU}" '((para (acronym (% (acronym "GNU")))))) From 3f279562fff0b581ce5d0f6cb388a45d3bd2a0d4 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 25 Mar 2020 02:57:17 +0530 Subject: [PATCH 22/42] doc: Fix minor typo in the HTTP headers documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/web.texi (HTTP Headers): Fix minor typo. Signed-off-by: Ludovic Courtès --- doc/ref/web.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 2d07dd7b1..31630def7 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -774,7 +774,7 @@ The MD5 digest of a resource. @deftypevr {HTTP Header} List content-range A range specification, as a list of three elements: the symbol @code{bytes}, either the symbol @code{*} or a pair of integers, -indicating the byte rage, and either @code{*} or an integer, for the +indicating the byte range, and either @code{*} or an integer, for the instance length. Used to indicate that a response only includes part of a resource. @example From 782a5af969b65bbcd00a51877dd28b7ba8b34fd1 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 25 Mar 2020 02:57:18 +0530 Subject: [PATCH 23/42] doc: Improve content-range HTTP header documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/web.texi (HTTP Headers): Improve punctuation in content-range HTTP header documentation. Signed-off-by: Ludovic Courtès --- doc/ref/web.texi | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 31630def7..93cd0214f 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -772,11 +772,11 @@ The MD5 digest of a resource. @end deftypevr @deftypevr {HTTP Header} List content-range -A range specification, as a list of three elements: the symbol -@code{bytes}, either the symbol @code{*} or a pair of integers, -indicating the byte range, and either @code{*} or an integer, for the -instance length. Used to indicate that a response only includes part of -a resource. +Range specification as a list of three elements: the symbol +@code{bytes}, either the symbol @code{*} or a pair of integers +indicating the byte range, and either @code{*} or an integer indicating +the instance length. Used to indicate that a response only includes +part of a resource. @example (parse-header 'content-range "bytes 10-20/*") @result{} (bytes (10 . 20) *) From 67f5b451b06666cf174d013280b20b68e37f4536 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 25 Mar 2020 02:57:19 +0530 Subject: [PATCH 24/42] doc: Document default delimiter of string-join. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/api-data.texi (String Constructors): Document default delimiter of the string-join function. * libguile/srfi-13.c (scm_string_join): Adjust docstring accordingly. Signed-off-by: Ludovic Courtès --- doc/ref/api-data.texi | 7 ++++--- libguile/srfi-13.c | 11 ++++++----- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 41d4f73c9..ed14b2298 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3183,9 +3183,10 @@ produce the corresponding string element. The order in which @deffnx {C Function} scm_string_join (ls, delimiter, grammar) Append the string in the string list @var{ls}, using the string @var{delimiter} as a delimiter between the elements of @var{ls}. -@var{grammar} is a symbol which specifies how the delimiter is -placed between the strings, and defaults to the symbol -@code{infix}. +@var{delimiter} defaults to @w{@samp{ }}, that is, strings in @var{ls} +are appended with the space character in between them. @var{grammar} is +a symbol which specifies how the delimiter is placed between the +strings, and defaults to the symbol @code{infix}. @table @code @item infix diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 97c372674..801591775 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -382,11 +382,12 @@ SCM_SYMBOL (scm_sym_prefix, "prefix"); SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, (SCM ls, SCM delimiter, SCM grammar), - "Append the string in the string list @var{ls}, using the string\n" - "@var{delimiter} as a delimiter between the elements of @var{ls}.\n" - "@var{grammar} is a symbol which specifies how the delimiter is\n" - "placed between the strings, and defaults to the symbol\n" - "@code{infix}.\n" + "Append the string in the string list @var{ls}, using the string\n" + "@var{delimiter} as a delimiter between the elements of @var{ls}.\n" + "@var{delimiter} defaults to @w{@samp{ }}, that is, strings in @var{ls}\n" + "are appended with the space character in between them. @var{grammar} is\n" + "a symbol which specifies how the delimiter is placed between the\n" + "strings, and defaults to the symbol @code{infix}.\n" "\n" "@table @code\n" "@item infix\n" From dfca16fd234c13ff76bbfca20ebc3b0895681bc2 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 25 Mar 2020 02:57:20 +0530 Subject: [PATCH 25/42] doc: Mention (ice-9 time) module path. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/scheme-using.texi (Profile Commands): Mention (ice-9 time) module path. Signed-off-by: Ludovic Courtès --- doc/ref/scheme-using.texi | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 9022eb953..b08c85cbc 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -311,6 +311,9 @@ will be printed farther to the right, though if the width of the indentation passes the @var{max-indent}, the indentation is abbreviated. @end deffn +These REPL commands can also be called as regular functions in scheme +code on including the @code{(ice-9 time)} module. + @node Debug Commands @subsubsection Debug Commands From 1ab2105339f60dba20c8c9680e49110501f3a6a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 18 Jun 2020 17:02:07 +0200 Subject: [PATCH 26/42] web: Accept URI host names consisting only of hex digits. Fixes . Reported by Julien Lepiller . Previously, a host part consisting of hex digits would be mistaken as an IPv6 address and rejected by 'valid-host?'. * module/web/uri.scm (ipv6-regexp): Add colon. * test-suite/tests/web-uri.test ("string->uri")["xyz://abc/x/y/z"]: New test. * NEWS: Update. --- NEWS | 3 +++ module/web/uri.scm | 4 ++-- test-suite/tests/web-uri.test | 9 ++++++++- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 6a86482c7..f489e3e98 100644 --- a/NEWS +++ b/NEWS @@ -95,6 +95,9 @@ written in C. ** 'http-get', 'http-post', etc. now honor #:verify-certificates? () +** web: Accept URI host names consisting only of hex digits + () + ** (web http) parser recognizes the CONNECT and PATCH methods ** Initial revealed count of file ports is now zero diff --git a/module/web/uri.scm b/module/web/uri.scm index b4b89b9cc..728444afc 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -1,6 +1,6 @@ ;;;; (web uri) --- URI manipulation tools ;;;; -;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014,2019 Free Software Foundation, Inc. +;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014,2019,2020 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -188,7 +188,7 @@ for ‘build-uri’ except there is no scheme." (define ipv4-regexp (make-regexp (string-append "^([" digits ".]+)$"))) (define ipv6-regexp - (make-regexp (string-append "^([" hex-digits ":.]+)$"))) + (make-regexp (string-append "^([" hex-digits "]*:[" hex-digits ":.]+)$"))) (define domain-label-regexp (make-regexp (string-append "^[" letters digits "]" diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 94778acac..95fd82f16 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -1,6 +1,6 @@ ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010-2012, 2014, 2017, 2019 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2012, 2014, 2017, 2019, 2020 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -179,6 +179,13 @@ #:port 22 #:path "/baz")) + (pass-if-equal "xyz://abc/x/y/z" ; + (list 'xyz "abc" "/x/y/z") + (let ((uri (string->uri "xyz://abc/x/y/z"))) + (list (uri-scheme uri) + (uri-host uri) + (uri-path uri)))) + (pass-if "http://bad.host.1" (not (string->uri "http://bad.host.1"))) From a0b9d866380b04aff27dcbcf1e13051f3d9685ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2020 15:06:42 +0200 Subject: [PATCH 27/42] Tree-IL-to-CPS compiler delays calls to 'target-most-positive-fixnum'. Fixes a bug whereby, for example, "guild compile --target=i686-linux-gnu" running on x86_64 would generate invalid code for 'bytevector-u32-native-set!' because 'target-most-positive-fixnum' was called from the top-level when (language tree-il compile-cps) was loaded. Consequently, the .go files under prebuilt/ would be invalid, leading to build failures on 32-bit platforms. This issue became apparent with cb8cabe85f535542ac4fcb165d89722500e42653. * module/language/tree-il/compile-cps.scm (bytevector-ref-converter)[tag]: Turn into a lambda so that 'target-most-positive-fixnum' is called in the right context. (bytevector-set-converter)[integer-unboxer]: Likewise. --- .dir-locals.el | 1 + module/language/tree-il/compile-cps.scm | 63 +++++++++++-------------- 2 files changed, 29 insertions(+), 35 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index 14c5d6d58..26e4ff9ff 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -14,6 +14,7 @@ (eval . (put 'with-test-prefix/c&e 'scheme-indent-function 1)) (eval . (put 'with-code-coverage 'scheme-indent-function 1)) (eval . (put 'with-statprof 'scheme-indent-function 1)) + (eval . (put 'with-target 'scheme-indent-function 1)) (eval . (put 'let-gensyms 'scheme-indent-function 1)) (eval . (put 'let-fresh 'scheme-indent-function 2)) (eval . (put 'with-fresh-name-state 'scheme-indent-function 1)) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index bd2bd7799..334b4ce70 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2015,2017-2019 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015,2017-2020 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -895,37 +895,32 @@ ($ (ensure-bytevector klen src op pred bv)))) (define (bytevector-ref-converter scheme-name ptr-op width kind) - (define tag + (define (tag cps k src val) (match kind ('unsigned (if (< (ash 1 (* width 8)) (target-most-positive-fixnum)) - (lambda (cps k src val) - (with-cps cps - (letv s) - (letk kcvt - ($kargs ('s) (s) - ($continue k src ($primcall 'tag-fixnum #f (s))))) - (build-term - ($continue kcvt src ($primcall 'u64->s64 #f (val)))))) - (lambda (cps k src val) - (with-cps cps - (build-term - ($continue k src ($primcall 'u64->scm #f (val)))))))) + (with-cps cps + (letv s) + (letk kcvt + ($kargs ('s) (s) + ($continue k src ($primcall 'tag-fixnum #f (s))))) + (build-term + ($continue kcvt src ($primcall 'u64->s64 #f (val))))) + (with-cps cps + (build-term + ($continue k src ($primcall 'u64->scm #f (val))))))) ('signed (if (< (ash 1 (* width 8)) (target-most-positive-fixnum)) - (lambda (cps k src val) - (with-cps cps - (build-term - ($continue k src ($primcall 'tag-fixnum #f (val)))))) - (lambda (cps k src val) - (with-cps cps - (build-term - ($continue k src ($primcall 's64->scm #f (val)))))))) + (with-cps cps + (build-term + ($continue k src ($primcall 'tag-fixnum #f (val))))) + (with-cps cps + (build-term + ($continue k src ($primcall 's64->scm #f (val))))))) ('float - (lambda (cps k src val) - (with-cps cps - (build-term - ($continue k src ($primcall 'f64->scm #f (val))))))))) + (with-cps cps + (build-term + ($continue k src ($primcall 'f64->scm #f (val)))))))) (lambda (cps k src op param bv idx) (prepare-bytevector-access cps src scheme-name 'bytevector? bv idx width @@ -962,9 +957,9 @@ (build-term ($branch k' kbad src 'imm-s64-< hi (sval))))) (define (integer-unboxer lo hi) - (cond - ((<= hi (target-most-positive-fixnum)) - (lambda (cps src val have-val) + (lambda (cps src val have-val) + (cond + ((<= hi (target-most-positive-fixnum)) (let ((have-val (if (zero? lo) (lambda (cps s) (with-cps cps @@ -989,17 +984,15 @@ ($kargs () () ($continue klo src ($primcall 'untag-fixnum #f (val))))) (build-term - ($branch kbad kuntag src 'fixnum? #f (val))))))) - ((zero? lo) - (lambda (cps src val have-val) + ($branch kbad kuntag src 'fixnum? #f (val)))))) + ((zero? lo) (with-cps cps (letv u) (let$ body (limit-urange src val u hi have-val)) (letk khi ($kargs ('u) (u) ,body)) (build-term - ($continue khi src ($primcall 'scm->u64 #f (val))))))) - (else - (lambda (cps src val have-val) + ($continue khi src ($primcall 'scm->u64 #f (val)))))) + (else (with-cps cps (letv s) (let$ body (limit-srange src val s lo hi have-val)) From ffba9b08c471568f1d7e24a0cae889a954cae515 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2020 16:14:52 +0200 Subject: [PATCH 28/42] Fix undefined behavior in ARMv7 assembler * lightening/arm-cpu.c (rotate_left): Fix the case of rotating by zero, which produced undefined behavior. Many thanks to Andrew Gierth (andrew at tao11 riddles org uk) for the debugging and the fix. --- lightening/arm-cpu.c | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index d96d57b2d..39123c730 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -1,5 +1,5 @@ /* - * Copyright (C) 2012-2017, 2019 Free Software Foundation, Inc. + * Copyright (C) 2012-2017,2019-2020 Free Software Foundation, Inc. * * This file is part of GNU lightning. * @@ -193,8 +193,15 @@ emit_wide_thumb(jit_state_t *_jit, uint32_t inst) emit_u16_with_pool(_jit, inst & 0xffff); } -/* from binutils */ -# define rotate_left(v, n) (v << n | v >> (32 - n)) +static uint32_t +rotate_left(uint32_t v, uint32_t n) { + if (n == 0) { + return v; + } + ASSERT(n < 32); + return (v << n | v >> (32 - n)); +} + static int encode_arm_immediate(unsigned int v) { From 97212e87bdcd9f9cff54aa979a48ce73535a0e88 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2020 16:22:31 +0200 Subject: [PATCH 29/42] Fix zeroing of literal pool entries * lightening/lightening.c (reset_literal_pool): Zero before setting size to 0. Thanks to Dale Smith for pointing this out! --- lightening/lightening.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lightening/lightening.c b/lightening/lightening.c index ca5708f0a..62f1e9d37 100644 --- a/lightening/lightening.c +++ b/lightening/lightening.c @@ -1,5 +1,5 @@ /* - * Copyright (C) 2012-2019 Free Software Foundation, Inc. + * Copyright (C) 2012-2020 Free Software Foundation, Inc. * * This file is part of GNU lightning. * @@ -1238,8 +1238,8 @@ static void reset_literal_pool(jit_state_t *_jit, struct jit_literal_pool *pool) { pool->deadline = _jit->limit - _jit->start; - pool->size = 0; memset(pool->entries, 0, sizeof(pool->entries[0]) * pool->size); + pool->size = 0; } #define INITIAL_LITERAL_POOL_CAPACITY 12 From 2c0fdb045ee4682d797ae6915eb58229a3784d39 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 19 Jun 2020 16:30:12 +0200 Subject: [PATCH 30/42] Fix unused variable warning for no-literal-pool targets * lightening/lightening.c (jit_patch_there): Conditionally define flags. --- lightening/lightening.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lightening/lightening.c b/lightening/lightening.c index 207712622..6948a81ee 100644 --- a/lightening/lightening.c +++ b/lightening/lightening.c @@ -380,7 +380,9 @@ jit_patch_there(jit_state_t* _jit, jit_reloc_t reloc, jit_pointer_t addr) ptrdiff_t diff = (uint8_t*)addr - pc_base; ASSERT((diff & ((1 << reloc.rsh) - 1)) == 0); diff >>= reloc.rsh; +#ifdef JIT_NEEDS_LITERAL_POOL int flags = reloc.kind & ~JIT_RELOC_MASK; +#endif switch (reloc.kind & JIT_RELOC_MASK) { From c7f76d94dabb589601e809710de5fcc9c4c9a882 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2020 20:56:38 +0200 Subject: [PATCH 31/42] popen: 'open-process' returns unbuffered ports. * module/ice-9/popen.scm (open-process)[unbuffered, fdes-pair]: New procedures. Use them. Return unbuffered ports. * test-suite/tests/popen.test ("open-pipe*"): New test prefix. --- module/ice-9/popen.scm | 25 ++++++++++++++++++++----- test-suite/tests/popen.test | 23 +++++++++++++++++++++++ 2 files changed, 43 insertions(+), 5 deletions(-) diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index 5ab93f275..a0ef0dc71 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -99,13 +99,28 @@ process (based on pipes) is created and returned. @var{mode} specifies whether an input, an output or an input-output port to the process is created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}." + (define (unbuffered port) + (setvbuf port 'none) + port) + + (define (fdes-pair ports) + (and ports + (cons (port->fdes (car ports)) (port->fdes (cdr ports))))) + (let* ((from (and (or (string=? mode OPEN_READ) - (string=? mode OPEN_BOTH)) (pipe->fdes))) + (string=? mode OPEN_BOTH)) + (pipe))) (to (and (or (string=? mode OPEN_WRITE) - (string=? mode OPEN_BOTH)) (pipe->fdes))) - (pid (piped-process command args from to))) - (values (and from (fdes->inport (car from))) - (and to (fdes->outport (cdr to))) pid))) + (string=? mode OPEN_BOTH)) + (pipe))) + (pid (piped-process command args + (fdes-pair from) + (fdes-pair to)))) + ;; The original 'open-process' procedure would return unbuffered + ;; ports; do the same here. + (values (and from (unbuffered (car from))) + (and to (unbuffered (cdr to))) + pid))) (define (open-pipe* mode command . args) "Executes the program @var{command} with optional arguments diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 86e388923..692156a34 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -196,6 +196,29 @@ exec 2>~a; read REPLY" (close-pipe port) result)))))) + + (with-test-prefix "open-pipe*" + + (pass-if-equal "OPEN_BOTH" + '(0 (good!)) + ;; This test ensures that the ports that underlie the read/write + ;; port are unbuffered. If they were buffered, the child process + ;; would wait in 'read' forever. + (let ((pipe (open-pipe* OPEN_BOTH "guile" "-c" + (object->string + '(begin + (setvbuf (current-output-port) 'line) + (write '(hello!)) + (newline) + (let ((greeting (read))) + (write '(good!)))))))) + (setvbuf pipe 'line) + (let ((return (read pipe))) + (write '(hi!) pipe) + (newline pipe) + (let ((last (read pipe))) + (list (close-pipe pipe) last)))))) + ;; ;; close-pipe ;; From 5f22d1090bef72639f2744402c0466d8dbf8f8ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 19 Jun 2020 21:06:09 +0200 Subject: [PATCH 32/42] popen: Correct 'pipeline' docstring. * module/ice-9/popen.scm (pipeline): Change docstring for correct Texinfo syntax and to use commas instead of em dashes, as in the manual. --- module/ice-9/popen.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index a0ef0dc71..e638726a4 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -215,10 +215,10 @@ information on how to interpret this value." (open-pipe command OPEN_BOTH)) (define (pipeline commands) - "Execute a pipeline of @var(commands) -- where each command is a list of a -program and its arguments as strings -- returning an input port to the + "Execute a pipeline of @var{commands}, where each command is a list of a +program and its arguments as strings, returning an input port to the end of the pipeline, an output port to the beginning of the pipeline and -a list of PIDs of the processes executing the @var(commands)." +a list of PIDs of the processes executing the @var{commands}." (let* ((to (pipe->fdes)) (pipes (map (lambda _ (pipe->fdes)) commands)) (pipeline (fold (lambda (from proc prev) From 1bb909a44d2303f88bb05125fc6742e97f80cd1d Mon Sep 17 00:00:00 2001 From: Andrew Gierth Date: Fri, 19 Jun 2020 17:07:34 +0100 Subject: [PATCH 33/42] Fix ARMv7 THUMB encoding for immediates. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lightening/arm-cpu.c (encode_thumb_immediate): Fix return value in third case. Signed-off-by: Ludovic Courtès --- lightening/arm-cpu.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lightening/arm-cpu.c b/lightening/arm-cpu.c index 4445266af..2b4eecc29 100644 --- a/lightening/arm-cpu.c +++ b/lightening/arm-cpu.c @@ -230,7 +230,7 @@ encode_thumb_immediate(unsigned int v) return ((v & 0xff) | (1 << 12)); /* abcdefgh 00000000 abcdefgh 00000000 */ if (((v & 0xffff0000) >> 16) == (v & 0xffff) && (v & 0xff) == 0) - return ((v & 0x000000ff) | (2 << 12)); + return (((v & 0x0000ff00) >> 8) | (2 << 12)); /* abcdefgh abcdefgh abcdefgh abcdefgh */ if ( (v & 0xff) == ((v & 0xff00) >> 8) && ((v & 0xff00) >> 8) == ((v & 0xff0000) >> 16) && From e3d9bdf03f0ee6440515c473f789fa501012ec76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 20 Jun 2020 16:13:16 +0200 Subject: [PATCH 34/42] tests: Make 'TARGETS' overridable. This allows users to run "make TARGETS=armv7", for instance. * tests/Makefile (TARGETS): Make it overridable. --- tests/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/Makefile b/tests/Makefile index 81279720d..b358a886b 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,5 +1,5 @@ TESTS=$(sort $(basename $(wildcard *.c))) -TARGETS=native ia32 aarch64 armv7 +TARGETS ?= native ia32 aarch64 armv7 # Suitable values of cross-compiler variables for Debian: # From e20ca01d9bfebd6e71f09e4a5bfbf80d44745e9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 20 Jun 2020 16:14:10 +0200 Subject: [PATCH 35/42] tests: Remove 'glibc' from the 'guix environment' command line. * tests/Makefile (CC_IA32, CC_AARCH64, CC_ARMv7): Remove 'glibc' from the 'guix environment' command line since it's redundant with 'gcc-toolchain'. --- tests/Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/Makefile b/tests/Makefile index b358a886b..769b43423 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -17,9 +17,9 @@ TARGETS ?= native ia32 aarch64 armv7 # gcc-aarch64-linux-gnu libc6-dev-arm64-cross libc6:arm64 # CC = gcc -CC_IA32=guix environment --pure -s i686-linux --ad-hoc gcc-toolchain glibc -- gcc -CC_AARCH64=guix environment --pure -s aarch64-linux --ad-hoc gcc-toolchain glibc -- gcc -CC_ARMv7=guix environment --pure -s armhf-linux --ad-hoc gcc-toolchain glibc -- gcc +CC_IA32=guix environment --pure -s i686-linux --ad-hoc gcc-toolchain -- gcc +CC_AARCH64=guix environment --pure -s aarch64-linux --ad-hoc gcc-toolchain -- gcc +CC_ARMv7=guix environment --pure -s armhf-linux --ad-hoc gcc-toolchain -- gcc CFLAGS = -Wall -O0 -g all: $(foreach TARGET,$(TARGETS),$(addprefix test-$(TARGET)-,$(TESTS))) From 24ef197b1269f8371b1f4a412caa6d2b99d66839 Mon Sep 17 00:00:00 2001 From: "Dale P. Smith" Date: Sat, 20 Jun 2020 16:28:44 +0200 Subject: [PATCH 36/42] Add 'movi' test. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a followup to 1bb909a44d2303f88bb05125fc6742e97f80cd1d. It reproduces the bug that 1bb909a44d2303f88bb05125fc6742e97f80cd1d fixes on ARMv7. * tests/movi.c: New file. Co-authored-by: Ludovic Courtès --- tests/movi.c | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 tests/movi.c diff --git a/tests/movi.c b/tests/movi.c new file mode 100644 index 000000000..fcdd656c0 --- /dev/null +++ b/tests/movi.c @@ -0,0 +1,22 @@ +#include "test.h" + +static void +run_test(jit_state_t *j, uint8_t *arena_base, size_t arena_size) +{ + jit_begin(j, arena_base, arena_size); + size_t align = jit_enter_jit_abi(j, 0, 0, 0); + + jit_movi(j, JIT_R0, 0xa500a500); + jit_leave_jit_abi(j, 0, 0, align); + jit_retr(j, JIT_R0); + + jit_uword_t (*f)(void) = jit_end(j, NULL); + + ASSERT(f() == 0xa500a500); +} + +int +main (int argc, char *argv[]) +{ + return main_helper(argc, argv, run_test); +} From 3523ad1326b0f374e82d6b5428997e3a38fd821d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 21 Jun 2020 15:11:43 +0200 Subject: [PATCH 37/42] Update NEWS. * NEWS: Update. --- NEWS | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS b/NEWS index f489e3e98..591eb8bb9 100644 --- a/NEWS +++ b/NEWS @@ -92,6 +92,10 @@ These replace the wonky "bit-set*!" procedure. Previously statprof would show strings like "anon #x1234" for primitives written in C. +** JIT bugs on ARMv7 have been fixed + (, + ) + ** 'http-get', 'http-post', etc. now honor #:verify-certificates? () From 492717db95c69bd6ab26de33808ebcd5804d2a5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 21 Jun 2020 22:16:58 +0200 Subject: [PATCH 38/42] Update NEWS. * NEWS: Update. --- NEWS | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NEWS b/NEWS index 591eb8bb9..c11e266ba 100644 --- a/NEWS +++ b/NEWS @@ -92,6 +92,13 @@ These replace the wonky "bit-set*!" procedure. Previously statprof would show strings like "anon #x1234" for primitives written in C. +** Compiler reduces 'equal?' when passed a character literal + +The compiler now properly reduces expressions such as (equal? c #\x) to +(eq? c #\x). This was not the case in 3.0.2, which could lead to slower +code, especially in 'match' expressions with many clauses with with +character literals. + ** JIT bugs on ARMv7 have been fixed (, ) From 5d052c87bd8f0fd894e67f0bebd4fa6f6160d83c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 21 Jun 2020 15:26:08 +0200 Subject: [PATCH 39/42] GNU Guile 3.0.3. * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. (LIBGUILE_INTERFACE_CURRENT): Increment. (LIBGUILE_INTERFACE_REVISION, LIBGUILE_INTERFACE_AGE): Reset. This accounts for commit b517a91ba4aaccf920a81eb8bf71ca090a9b457c and similar, which remove C functions in '--disable-deprecated' builds. --- GUILE-VERSION | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 3bb019510..f005f3789 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=3 GUILE_MINOR_VERSION=0 -GUILE_MICRO_VERSION=2 +GUILE_MICRO_VERSION=3 GUILE_EFFECTIVE_VERSION=3.0 @@ -16,7 +16,7 @@ GUILE_EFFECTIVE_VERSION=3.0 # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=2 -LIBGUILE_INTERFACE_REVISION=1 -LIBGUILE_INTERFACE_AGE=1 +LIBGUILE_INTERFACE_CURRENT=3 +LIBGUILE_INTERFACE_REVISION=0 +LIBGUILE_INTERFACE_AGE=0 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From 1b2be93d6e9537a623e9cc476e151341c6e39a1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 24 Jun 2020 15:19:27 +0200 Subject: [PATCH 40/42] Revert "GNU Guile 3.0.3." This change suggested an ABI incompatibility that's not there for normal builds: https://lists.gnu.org/archive/html/guile-user/2020-06/msg00059.html Reported by Chris Vine. This reverts commit 5d052c87bd8f0fd894e67f0bebd4fa6f6160d83c. --- GUILE-VERSION | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index f005f3789..3bb019510 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=3 GUILE_MINOR_VERSION=0 -GUILE_MICRO_VERSION=3 +GUILE_MICRO_VERSION=2 GUILE_EFFECTIVE_VERSION=3.0 @@ -16,7 +16,7 @@ GUILE_EFFECTIVE_VERSION=3.0 # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=3 -LIBGUILE_INTERFACE_REVISION=0 -LIBGUILE_INTERFACE_AGE=0 +LIBGUILE_INTERFACE_CURRENT=2 +LIBGUILE_INTERFACE_REVISION=1 +LIBGUILE_INTERFACE_AGE=1 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From 4e8ead96f7b9195cf083987d53c50ca2f4a4f4bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 24 Jun 2020 15:28:05 +0200 Subject: [PATCH 41/42] GNU Guile 3.0.4 (SONAME fix). * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. (LIBGUILE_INTERFACE_CURRENT): Increment. (LIBGUILE_INTERFACE_REVISION): Reset. (LIBGUILE_INTERFACE_AGE): Increment. This accounts for commit, which adds a new symbol to the ABI. --- GUILE-VERSION | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 3bb019510..a20da3d76 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=3 GUILE_MINOR_VERSION=0 -GUILE_MICRO_VERSION=2 +GUILE_MICRO_VERSION=4 GUILE_EFFECTIVE_VERSION=3.0 @@ -14,9 +14,10 @@ GUILE_EFFECTIVE_VERSION=3.0 # Makefile.am. # See libtool info pages for more information on how and when to -# change these. +# change these. Note: We consider the ABI of default builds, and not +# that of '--disable-deprecated' builds. -LIBGUILE_INTERFACE_CURRENT=2 -LIBGUILE_INTERFACE_REVISION=1 -LIBGUILE_INTERFACE_AGE=1 +LIBGUILE_INTERFACE_CURRENT=3 +LIBGUILE_INTERFACE_REVISION=0 +LIBGUILE_INTERFACE_AGE=2 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From 5e1748f75128107e3a0707b66df5adb95d98437e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 24 Jun 2020 15:42:12 +0200 Subject: [PATCH 42/42] Update NEWS. * NEWS: Update. --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index c11e266ba..5824e31ab 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,15 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. + +Changes in 3.0.4 (since 3.0.3) + +This release fixes the SONAME of libguile-3.0.so, which was erroneously +bumped in 3.0.3 compared to 3.0.2. Distributions are strongly +encouraged to use 3.0.4 instead of 3.0.3. + +Thanks to Chris Vine for reporting the issue. + Changes in 3.0.3 (since 3.0.2)