diff --git a/system/devel/guile/files/disable-test-out-of-memory.patch b/system/devel/guile/files/disable-test-out-of-memory.patch new file mode 100644 index 00000000..8b23bf6f --- /dev/null +++ b/system/devel/guile/files/disable-test-out-of-memory.patch @@ -0,0 +1,24 @@ +--- guile/test-suite/standalone/Makefile.am 2023-01-29 21:51:48.697140831 +0100 ++++ guile/test-suite/standalone/Makefile.am 2023-01-29 21:52:22.869517398 +0100 +@@ -298,9 +298,6 @@ + check_SCRIPTS += test-stack-overflow + TESTS += test-stack-overflow + +-check_SCRIPTS += test-out-of-memory +-TESTS += test-out-of-memory +- + check_SCRIPTS += test-close-on-exec + TESTS += test-close-on-exec + +diff -Nur guile-3.0.7/test-suite/standalone/Makefile.in new/test-suite/standalone/Makefile.in +--- guile-3.0.7/test-suite/standalone/Makefile.in 2021-05-10 10:30:31.000000000 +0200 ++++ new/test-suite/standalone/Makefile.in 2021-05-15 13:53:17.370706370 +0200 +@@ -106,7 +106,7 @@ + test-scm-c-bind-keyword-arguments$(EXEEXT) \ + test-srfi-4$(EXEEXT) $(am__append_6) $(am__EXEEXT_1) \ + test-smob-mark$(EXEEXT) test-smob-mark-race$(EXEEXT) \ +- test-stack-overflow test-out-of-memory test-close-on-exec ++ test-stack-overflow test-close-on-exec + check_PROGRAMS = test-num2integral$(EXEEXT) test-round$(EXEEXT) \ + test-foreign-object-c$(EXEEXT) test-list$(EXEEXT) \ + test-unwind$(EXEEXT) test-conversion$(EXEEXT) \ diff --git a/system/devel/guile/files/gcc10-x86-disable-one-test.patch b/system/devel/guile/files/gcc10-x86-disable-one-test.patch new file mode 100644 index 00000000..53471fff --- /dev/null +++ b/system/devel/guile/files/gcc10-x86-disable-one-test.patch @@ -0,0 +1,22 @@ +diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test +index 59e370e..6b07655 100644 +--- a/test-suite/tests/numbers.test ++++ b/test-suite/tests/numbers.test +@@ -5309,7 +5309,7 @@ + d)))))))) + + (with-test-prefix "fractions" +- (for '((1/10 16/3 10/7)) ;; denominators ++ (for '((1/10 16/3)) ;; denominators + (lambda (d) + (for '((0 1 2 5 1/2 3/2 5/2)) ;; multiples + (lambda (m) +@@ -5319,7 +5319,7 @@ + d)))))))) + + (with-test-prefix "mixed types" +- (for `((10 ,big 12.0 10/7 +inf.0 -inf.0 +nan.0)) ;; denominators ++ (for `((10 ,big 12.0 +inf.0 -inf.0 +nan.0)) ;; denominators + (lambda (d) + (for `((25 ,(* 3/2 big) 130.0 15/7 + 0 0.0 -0.0 +inf.0 -inf.0 +nan.0)) ;; numerators diff --git a/system/devel/guile/files/gcc14.patch b/system/devel/guile/files/gcc14.patch new file mode 100644 index 00000000..ab7196ff --- /dev/null +++ b/system/devel/guile/files/gcc14.patch @@ -0,0 +1,14 @@ +See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=73835 + +diff -upr guile-3.0.9.orig/libguile/filesys.c guile-3.0.9/libguile/filesys.c +--- guile-3.0.9.orig/libguile/filesys.c 2024-10-16 19:35:32.891699878 +0200 ++++ guile-3.0.9/libguile/filesys.c 2024-10-16 19:43:31.660093415 +0200 +@@ -1329,7 +1329,7 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, + + ssize_t result SCM_UNUSED; + size_t c_count, total = 0; +- scm_t_off c_offset; ++ off_t c_offset; + int in_fd, out_fd; + + VALIDATE_FD_OR_PORT (out_fd, out, 1); diff --git a/system/devel/guile/files/gcc15.patch b/system/devel/guile/files/gcc15.patch new file mode 100644 index 00000000..60ee4777 --- /dev/null +++ b/system/devel/guile/files/gcc15.patch @@ -0,0 +1,312 @@ +Patch-Source: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=78464 +--- +From ea57c7f79f92e2be7a179464ae7f45e1e130a075 Mon Sep 17 00:00:00 2001 +From: Collin Funk +Date: Fri, 16 May 2025 22:51:57 -0700 +Subject: [PATCH] Fix build with C23 compilers. + +* libguile/scm.h (scm_t_subr): Always define to void pointer. Update +commentary to account for C23. +* libguile/lightening/lightening.h (jit_function_pointer_t): Define to a +void pointer. +* libguile/init.c (scm_boot_guile): Add prototype to main_func. +* libguile/hash.c (floor): Add function prototype. +* libguile/posix.c (scm_getpgrp): Just call the system definition +directly. +* libguile/array-map.c (scm_ramapc): Cast the function pointer with the +correct number of arguments. +* libguile/gsubr.c (scm_apply_subr): Likewise. +(scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic) +scm_c_define_gsubr_with_generic): Use scm_t_subr for the fcn argument +which matches the declarations in libguile/gsubr.h. +* libguile/fluids.c (scm_c_with_fluids, scm_with_fluid): Add function +prototype to cproc. +* libguile/smob.c (apply_0, apply_1, apply_2, apply_3): Cast the +function with the correct number of arguments. +(scm_set_smob_apply): Use scm_t_subr for the apply argument which +patches libguile/smob.h. +--- + libguile/array-map.c | 5 ++-- + libguile/fluids.c | 4 +-- + libguile/gsubr.c | 51 +++++++++++++++++++------------- + libguile/hash.c | 2 +- + libguile/init.c | 3 +- + libguile/lightening/lightening.h | 2 +- + libguile/posix.c | 4 +-- + libguile/scm.h | 10 ++----- + libguile/smob.c | 10 +++---- + 9 files changed, 47 insertions(+), 44 deletions(-) + +diff --git a/libguile/array-map.c b/libguile/array-map.c +index ce0f7ba09..db0efd791 100644 +--- a/libguile/array-map.c ++++ b/libguile/array-map.c +@@ -101,7 +101,6 @@ cindk (SCM ra, ssize_t *ve, int kend) + int + scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) + { +- int (*cproc) () = cproc_ptr; + SCM z, va0, lva, *plva; + int k, kmax, kroll; + ssize_t *vi, inc; +@@ -197,7 +196,9 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) + SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll)); + for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y)) + SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll)); +- if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva))) ++ if (! (SCM_UNBNDP (data) ++ ? ((int (*) (SCM, SCM)) cproc_ptr) (va0, lva) ++ : ((int (*) (SCM, SCM, SCM)) cproc_ptr) (va0, data, lva))) + return 0; + --k; + } +diff --git a/libguile/fluids.c b/libguile/fluids.c +index ebdb48fbc..f6d918a34 100644 +--- a/libguile/fluids.c ++++ b/libguile/fluids.c +@@ -506,7 +506,7 @@ SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, + #undef FUNC_NAME + + SCM +-scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) ++scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (void *), void *cdata) + #define FUNC_NAME "scm_c_with_fluids" + { + SCM ans; +@@ -544,7 +544,7 @@ scm_with_fluid (SCM fluid, SCM value, SCM thunk) + } + + SCM +-scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) ++scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (void *), void *cdata) + #define FUNC_NAME "scm_c_with_fluid" + { + SCM ans; +diff --git a/libguile/gsubr.c b/libguile/gsubr.c +index a33cbb9c4..c3afd6f47 100644 +--- a/libguile/gsubr.c ++++ b/libguile/gsubr.c +@@ -467,38 +467,47 @@ scm_subr_name (SCM subr) + SCM + scm_apply_subr (union scm_vm_stack_element *sp, uint32_t idx, ptrdiff_t nslots) + { +- SCM (*subr)() = subrs[idx]; ++ void *subr = subrs[idx]; + + #define ARG(i) (sp[i].as_scm) + switch (nslots - 1) + { + case 0: +- return subr (); ++ return ((SCM (*) (void)) subr) (); + case 1: +- return subr (ARG (0)); ++ return ((SCM (*) (SCM)) subr) (ARG (0)); + case 2: +- return subr (ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM)) subr) (ARG (1), ARG (0)); + case 3: +- return subr (ARG (2), ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM)) subr) (ARG (2), ARG (1), ARG (0)); + case 4: +- return subr (ARG (3), ARG (2), ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM, SCM)) subr) (ARG (3), ARG (2), ARG (1), ++ ARG (0)); + case 5: +- return subr (ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM, SCM, SCM)) subr) (ARG (4), ARG (3), ++ ARG (2), ARG (1), ++ ARG (0)); + case 6: +- return subr (ARG (5), ARG (4), ARG (3), ARG (2), ARG (1), +- ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM, SCM, SCM, SCM)) subr) (ARG (5), ARG (4), ++ ARG (3), ARG (2), ++ ARG (1), ++ ARG (0)); + case 7: +- return subr (ARG (6), ARG (5), ARG (4), ARG (3), ARG (2), +- ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM, SCM, SCM, SCM, SCM)) subr) ++ (ARG (6), ARG (5), ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); + case 8: +- return subr (ARG (7), ARG (6), ARG (5), ARG (4), ARG (3), +- ARG (2), ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM)) subr) ++ (ARG (7), ARG (6), ARG (5), ARG (4), ARG (3), ARG (2), ARG (1), ++ ARG (0)); + case 9: +- return subr (ARG (8), ARG (7), ARG (6), ARG (5), ARG (4), +- ARG (3), ARG (2), ARG (1), ARG (0)); ++ return ((SCM (*) (SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM)) subr) ++ (ARG (8), ARG (7), ARG (6), ARG (5), ARG (4), ARG (3), ARG (2), ++ ARG (1), ARG (0)); + case 10: +- return subr (ARG (9), ARG (8), ARG (7), ARG (6), ARG (5), +- ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); ++ return ++ ((SCM (*) (SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM)) subr) ++ (ARG (9), ARG (8), ARG (7), ARG (6), ARG (5), ARG (4), ARG (3), ++ ARG (2), ARG (1), ARG (0)); + default: + abort (); /* SCM_GSUBR_MAX */ + } +@@ -506,13 +515,13 @@ scm_apply_subr (union scm_vm_stack_element *sp, uint32_t idx, ptrdiff_t nslots) + } + + SCM +-scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) ++scm_c_make_gsubr (const char *name, int req, int opt, int rst, scm_t_subr fcn) + { + return create_subr (0, name, req, opt, rst, fcn, NULL); + } + + SCM +-scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) ++scm_c_define_gsubr (const char *name, int req, int opt, int rst, scm_t_subr fcn) + { + return create_subr (1, name, req, opt, rst, fcn, NULL); + } +@@ -522,7 +531,7 @@ scm_c_make_gsubr_with_generic (const char *name, + int req, + int opt, + int rst, +- SCM (*fcn)(), ++ scm_t_subr fcn, + SCM *gf) + { + return create_subr (0, name, req, opt, rst, fcn, gf); +@@ -533,7 +542,7 @@ scm_c_define_gsubr_with_generic (const char *name, + int req, + int opt, + int rst, +- SCM (*fcn)(), ++ scm_t_subr fcn, + SCM *gf) + { + return create_subr (1, name, req, opt, rst, fcn, gf); +diff --git a/libguile/hash.c b/libguile/hash.c +index b7ad03309..cca3dd32b 100644 +--- a/libguile/hash.c ++++ b/libguile/hash.c +@@ -48,7 +48,7 @@ + ␌ + + #ifndef floor +-extern double floor(); ++extern double floor (double); + #endif + + +diff --git a/libguile/init.c b/libguile/init.c +index 3df8c5ae5..37300f59a 100644 +--- a/libguile/init.c ++++ b/libguile/init.c +@@ -277,7 +277,8 @@ static void *invoke_main_func(void *body_data); + + + void +-scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure) ++scm_boot_guile (int argc, char ** argv, ++ void (*main_func) (void *, int, char **), void *closure) + { + void *res; + struct main_func_closure c; +diff --git a/libguile/lightening/lightening.h b/libguile/lightening/lightening.h +index b364e18cc..ecb47152a 100644 +--- a/libguile/lightening/lightening.h ++++ b/libguile/lightening/lightening.h +@@ -222,7 +222,7 @@ JIT_API void* jit_end(jit_state_t*, size_t*); + JIT_API void jit_align(jit_state_t*, unsigned); + + JIT_API jit_pointer_t jit_address(jit_state_t*); +-typedef void (*jit_function_pointer_t)(); ++typedef void *jit_function_pointer_t; + JIT_API jit_function_pointer_t jit_address_to_function_pointer(jit_pointer_t); + JIT_API void jit_patch_here(jit_state_t*, jit_reloc_t); + JIT_API void jit_patch_there(jit_state_t*, jit_reloc_t, jit_pointer_t); +diff --git a/libguile/posix.c b/libguile/posix.c +index c8bbb0f83..4fde82416 100644 +--- a/libguile/posix.c ++++ b/libguile/posix.c +@@ -988,9 +988,7 @@ SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, + "This is the POSIX definition, not BSD.") + #define FUNC_NAME s_scm_getpgrp + { +- int (*fn)(); +- fn = (int (*) ()) getpgrp; +- return scm_from_int (fn (0)); ++ return scm_from_int (getpgrp ()); + } + #undef FUNC_NAME + #endif /* HAVE_GETPGRP */ +diff --git a/libguile/scm.h b/libguile/scm.h +index 180b40159..de6940e04 100644 +--- a/libguile/scm.h ++++ b/libguile/scm.h +@@ -810,15 +810,9 @@ enum scm_tc8_tags + ␌ + + /* The type of subrs, i.e., Scheme procedures implemented in C. Empty +- function declarators are used internally for pointers to functions of +- any arity. However, these are equivalent to `(void)' in C++, are +- obsolescent as of C99, and trigger `strict-prototypes' GCC warnings +- (bug #23681). */ +-#ifdef BUILDING_LIBGUILE +-typedef SCM (* scm_t_subr) (); +-#else ++ function declarators are equivelent to `(void)' in C++ and C23. ++ So we must use a void pointer and cast it. */ + typedef void *scm_t_subr; +-#endif + + typedef struct scm_dynamic_state scm_t_dynamic_state; + typedef struct scm_print_state scm_print_state; +diff --git a/libguile/smob.c b/libguile/smob.c +index 8e4da9adb..4c97499fa 100644 +--- a/libguile/smob.c ++++ b/libguile/smob.c +@@ -133,28 +133,28 @@ static SCM scm_smob_trampolines[16]; + static SCM + apply_0 (SCM smob) + { +- SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; ++ SCM (*subr) (SCM) = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob); + } + + static SCM + apply_1 (SCM smob, SCM a) + { +- SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; ++ SCM (*subr) (SCM, SCM) = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob, a); + } + + static SCM + apply_2 (SCM smob, SCM a, SCM b) + { +- SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; ++ SCM (*subr) (SCM, SCM, SCM) = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob, a, b); + } + + static SCM + apply_3 (SCM smob, SCM a, SCM b, SCM c) + { +- SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; ++ SCM (*subr) (SCM, SCM, SCM, SCM) = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob, a, b, c); + } + +@@ -254,7 +254,7 @@ scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) + } + + void +-scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), ++scm_set_smob_apply (scm_t_bits tc, scm_t_subr apply, + unsigned int req, unsigned int opt, unsigned int rst) + { + SCM trampoline = scm_smob_trampoline (req, opt, rst); +-- +2.49.0 diff --git a/system/devel/guile/files/guile-3.0.10-32bit_fixes-1.patch b/system/devel/guile/files/guile-3.0.10-32bit_fixes-1.patch new file mode 100644 index 00000000..ff5254d7 --- /dev/null +++ b/system/devel/guile/files/guile-3.0.10-32bit_fixes-1.patch @@ -0,0 +1,403 @@ +Submitted By: Douglas R. Reno +Date: 2025-08-31 +Initial Package Version: 3.0.10 +Upstream Status: Applied +Source: Upstream (commit aff9ac96) +Description: Fixes several problems in Guile that cause problems + when building it on 32-bit systems. I bumped into this + recently while building GDB on a 32-bit system, as I + use a plugin written in Scheme that goes through Guile. + Gentoo and several others have adopted the patch as + it's needed for all 32-bit architectures. + +From 605440d8021061a4ef8c18370783ef39f62c59b2 Mon Sep 17 00:00:00 2001 +From: Andy Wingo +Date: Wed, 25 Sep 2024 17:23:06 +0200 +Subject: [PATCH 1/4] Fix fixpoint needed-bits computation in + specialize-numbers + +* module/language/cps/specialize-numbers.scm (next-power-of-two): Use +integer-length. No change. +(compute-significant-bits): Fix the fixpoint computation, which was +failing to complete in some cases with loops. +--- + module/language/cps/specialize-numbers.scm | 27 ++++++++-------------- + 1 file changed, 10 insertions(+), 17 deletions(-) + +diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm +index 4ec88871c..12963cd71 100644 +--- a/module/language/cps/specialize-numbers.scm ++++ b/module/language/cps/specialize-numbers.scm +@@ -265,10 +265,7 @@ + (sigbits-intersect a (sigbits-intersect b c))) + + (define (next-power-of-two n) +- (let lp ((out 1)) +- (if (< n out) +- out +- (lp (ash out 1))))) ++ (ash 1 (integer-length n))) + + (define (range->sigbits min max) + (cond +@@ -310,18 +307,16 @@ + BITS indicating the significant bits needed for a variable. BITS may be + #f to indicate all bits, or a non-negative integer indicating a bitmask." + (let ((preds (invert-graph (compute-successors cps kfun)))) +- (let lp ((worklist (intmap-keys preds)) (visited empty-intset) +- (out empty-intmap)) ++ (let lp ((worklist (intmap-keys preds)) (out empty-intmap)) + (match (intset-prev worklist) + (#f out) + (label +- (let ((worklist (intset-remove worklist label)) +- (visited* (intset-add visited label))) ++ (let ((worklist (intset-remove worklist label))) + (define (continue out*) +- (if (and (eq? out out*) (eq? visited visited*)) +- (lp worklist visited out) ++ (if (eq? out out*) ++ (lp worklist out) + (lp (intset-union worklist (intmap-ref preds label)) +- visited* out*))) ++ out*))) + (define (add-def out var) + (intmap-add out var 0 sigbits-union)) + (define (add-defs out vars) +@@ -352,12 +347,10 @@ BITS indicating the significant bits needed for a variable. BITS may be + (($ $values args) + (match (intmap-ref cps k) + (($ $kargs _ vars) +- (if (intset-ref visited k) +- (fold (lambda (arg var out) +- (intmap-add out arg (intmap-ref out var) +- sigbits-union)) +- out args vars) +- out)) ++ (fold (lambda (arg var out) ++ (intmap-add out arg (intmap-ref out var (lambda (_) 0)) ++ sigbits-union)) ++ out args vars)) + (($ $ktail) + (add-unknown-uses out args)))) + (($ $call proc args) +-- +2.47.0 + + +From 6953fcb8d9b7d9d36bf36e83e80e24153d37e2a4 Mon Sep 17 00:00:00 2001 +From: Andy Wingo +Date: Wed, 25 Sep 2024 17:24:51 +0200 +Subject: [PATCH 2/4] Fix boxing of non-fixnum negative u64 values + +* module/language/cps/specialize-numbers.scm (u64->fixnum/truncate): New +helper. +(specialize-operations): Fix specialized boxing of u64 values to +truncate possibly-negative values, to avoid confusing CSE. Fixes +https://debbugs.gnu.org/cgi/bugreport.cgi?bug=71891. +--- + module/language/cps/specialize-numbers.scm | 21 ++++++++++++++++++++- + 1 file changed, 20 insertions(+), 1 deletion(-) + +diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm +index 12963cd71..e9761f0cb 100644 +--- a/module/language/cps/specialize-numbers.scm ++++ b/module/language/cps/specialize-numbers.scm +@@ -115,6 +115,13 @@ + (letk ks64 ($kargs ('s64) (s64) ,tag-body)) + (build-term + ($continue ks64 src ($primcall 'u64->s64 #f (u64)))))) ++(define (u64->fixnum/truncate cps k src u64 bits) ++ (with-cps cps ++ (letv truncated) ++ (let$ tag-body (u64->fixnum k src truncated)) ++ (letk ku64 ($kargs ('truncated) (truncated) ,tag-body)) ++ (build-term ++ ($continue ku64 src ($primcall 'ulogand/immediate bits (u64)))))) + (define-simple-primcall scm->u64) + (define-simple-primcall scm->u64/truncate) + (define-simple-primcall u64->scm) +@@ -473,7 +480,19 @@ BITS indicating the significant bits needed for a variable. BITS may be + (define (box-s64 result) + (if (fixnum-result? result) tag-fixnum s64->scm)) + (define (box-u64 result) +- (if (fixnum-result? result) u64->fixnum u64->scm)) ++ (call-with-values ++ (lambda () ++ (lookup-post-type types label result 0)) ++ (lambda (type min max) ++ (cond ++ ((and (type<=? type &exact-integer) ++ (<= 0 min max (target-most-positive-fixnum))) ++ u64->fixnum) ++ ((only-fixnum-bits-used? result) ++ (lambda (cps k src u64) ++ (u64->fixnum/truncate cps k src u64 (intmap-ref sigbits result)))) ++ (else ++ u64->scm))))) + (define (box-f64 result) + f64->scm) + +-- +2.47.0 + + +From b0559dbe88eb54e2bba4a82dd1f7e7c5b6de2f55 Mon Sep 17 00:00:00 2001 +From: Andy Wingo +Date: Mon, 23 Sep 2024 15:57:23 +0200 +Subject: [PATCH 3/4] Narrow parameter of logand/immediate if no bits used + +* module/language/cps/specialize-numbers.scm (specialize-operations): +Narrow ulogand/immediate param according to used bits. +--- + module/language/cps/specialize-numbers.scm | 8 +++++--- + 1 file changed, 5 insertions(+), 3 deletions(-) + +diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm +index e9761f0cb..262dee484 100644 +--- a/module/language/cps/specialize-numbers.scm ++++ b/module/language/cps/specialize-numbers.scm +@@ -1,6 +1,6 @@ + ;;; Continuation-passing style (CPS) intermediate language (IL) + +-;; Copyright (C) 2015-2021, 2023 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2021,2023-2024 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 +@@ -573,9 +573,11 @@ BITS indicating the significant bits needed for a variable. BITS may be + (specialize-unop cps k src op param a + (unbox-u64 a) (box-u64 result)))) + +- (('logand/immediate (? u64-result? ) param (? u64-operand? a)) ++ (('logand/immediate (? u64-result?) param (? u64-operand? a)) + (specialize-unop cps k src 'ulogand/immediate +- (logand param (1- (ash 1 64))) ++ (logand param ++ (or (intmap-ref sigbits result) -1) ++ (1- (ash 1 64))) + a + (unbox-u64 a) (box-u64 result))) + +-- +2.47.0 + + +From 51db308ec2107f9fb32a06004e7a0a3da6418ff6 Mon Sep 17 00:00:00 2001 +From: Andy Wingo +Date: Thu, 26 Sep 2024 11:14:52 +0200 +Subject: [PATCH 4/4] Run sigbits fixpoint based on use/def graph, not cfg + +* module/language/cps/specialize-numbers.scm (sigbits-ref): New helper. +(invert-graph*): New helper. +(compute-significant-bits): When visiting a term changes computed +needed-bits for one of its definitions, we need to revisit the variables +that contributed to its result (the uses), because they might need more +bits as well. Previously we were doing this by enqueueing predecessors +to the term, which worked if the uses were defined in predecessors, or +if all defining terms were already in the worklist, which is the case +without loops. But with loops, when revisiting a term, you could see +that it causes sigbits to change, enqueue its predecessors, but then the +predecessors don't change anything and the fixpoint stops before +reaching the definitions of the variables we need. So instead we +compute the use-def graph and enqueue defs directly. +--- + module/language/cps/specialize-numbers.scm | 120 ++++++++++----------- + 1 file changed, 54 insertions(+), 66 deletions(-) + +diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm +index 262dee484..ac63c8194 100644 +--- a/module/language/cps/specialize-numbers.scm ++++ b/module/language/cps/specialize-numbers.scm +@@ -286,6 +286,9 @@ + (and (type<=? type (logior &exact-integer &u64 &s64)) + (range->sigbits min max))))) + ++(define (sigbits-ref sigbits var) ++ (intmap-ref sigbits var (lambda (_) 0))) ++ + (define significant-bits-handlers (make-hash-table)) + (define-syntax-rule (define-significant-bits-handler + ((primop label types out def ...) param arg ...) +@@ -297,24 +300,42 @@ + (define-significant-bits-handler ((logand label types out res) param a b) + (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) + (inferred-sigbits types label b) +- (intmap-ref out res (lambda (_) 0))))) ++ (sigbits-ref out res)))) + (intmap-add (intmap-add out a sigbits sigbits-union) + b sigbits sigbits-union))) + (define-significant-bits-handler ((logand/immediate label types out res) param a) + (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) + param +- (intmap-ref out res (lambda (_) 0))))) ++ (sigbits-ref out res)))) + (intmap-add out a sigbits sigbits-union))) + + (define (significant-bits-handler primop) + (hashq-ref significant-bits-handlers primop)) + ++(define (invert-graph* defs) ++ "Given a graph LABEL->VAR..., return a graph VAR->LABEL.... Like the one ++in (language cps graphs), but different because it doesn't assume that ++the domain will be the same before and after." ++ (persistent-intmap ++ (intmap-fold (lambda (label vars out) ++ (intset-fold ++ (lambda (var out) ++ (intmap-add! out var (intset label) intset-union)) ++ vars ++ out)) ++ defs ++ empty-intmap))) ++ + (define (compute-significant-bits cps types kfun) + "Given the locally inferred types @var{types}, compute a map of VAR -> + BITS indicating the significant bits needed for a variable. BITS may be + #f to indicate all bits, or a non-negative integer indicating a bitmask." +- (let ((preds (invert-graph (compute-successors cps kfun)))) +- (let lp ((worklist (intmap-keys preds)) (out empty-intmap)) ++ (let ((cps (intmap-select cps (compute-function-body cps kfun)))) ++ ;; Label -> Var... ++ (define-values (defs uses) (compute-defs-and-uses cps)) ++ ;; Var -> Label... ++ (define defs-by-var (invert-graph* defs)) ++ (let lp ((worklist (intmap-keys cps)) (out empty-intmap)) + (match (intset-prev worklist) + (#f out) + (label +@@ -322,69 +343,36 @@ BITS indicating the significant bits needed for a variable. BITS may be + (define (continue out*) + (if (eq? out out*) + (lp worklist out) +- (lp (intset-union worklist (intmap-ref preds label)) ++ (lp (intset-fold ++ (lambda (use worklist) ++ (intset-union worklist (intmap-ref defs-by-var use))) ++ (intmap-ref uses label) ++ worklist) + out*))) +- (define (add-def out var) +- (intmap-add out var 0 sigbits-union)) +- (define (add-defs out vars) +- (match vars +- (() out) +- ((var . vars) (add-defs (add-def out var) vars)))) +- (define (add-unknown-use out var) ++ (define (add-unknown-use var out) + (intmap-add out var (inferred-sigbits types label var) + sigbits-union)) +- (define (add-unknown-uses out vars) +- (match vars +- (() out) +- ((var . vars) +- (add-unknown-uses (add-unknown-use out var) vars)))) ++ (define (default) ++ (intset-fold add-unknown-use (intmap-ref uses label) out)) + (continue + (match (intmap-ref cps label) +- (($ $kfun src meta self) +- (if self (add-def out self) out)) +- (($ $kargs names vars term) +- (let ((out (add-defs out vars))) +- (match term +- (($ $continue k src exp) +- (match exp +- ((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun) +- ($ $code) ($ $rec)) +- ;; No uses, so no info added to sigbits. +- out) +- (($ $values args) +- (match (intmap-ref cps k) +- (($ $kargs _ vars) +- (fold (lambda (arg var out) +- (intmap-add out arg (intmap-ref out var (lambda (_) 0)) +- sigbits-union)) +- out args vars)) +- (($ $ktail) +- (add-unknown-uses out args)))) +- (($ $call proc args) +- (add-unknown-use (add-unknown-uses out args) proc)) +- (($ $callk label proc args) +- (let ((out (add-unknown-uses out args))) +- (if proc +- (add-unknown-use out proc) +- out))) +- (($ $calli args callee) +- (add-unknown-uses (add-unknown-use out callee) args)) +- (($ $primcall name param args) +- (let ((h (significant-bits-handler name))) +- (if h +- (match (intmap-ref cps k) +- (($ $kargs _ defs) +- (h label types out param args defs))) +- (add-unknown-uses out args)))))) +- (($ $branch kf kt src op param args) +- (add-unknown-uses out args)) +- (($ $switch kf kt src arg) +- (add-unknown-use out arg)) +- (($ $prompt k kh src escape? tag) +- (add-unknown-use out tag)) +- (($ $throw src op param args) +- (add-unknown-uses out args))))) +- (_ out))))))))) ++ (($ $kargs _ _ ($ $continue k _ ($ $primcall op param args))) ++ (match (significant-bits-handler op) ++ (#f (default)) ++ (h ++ (match (intmap-ref cps k) ++ (($ $kargs _ defs) ++ (h label types out param args defs)))))) ++ (($ $kargs _ _ ($ $continue k _ ($ $values args))) ++ (match (intmap-ref cps k) ++ (($ $kargs _ vars) ++ (fold (lambda (arg var out) ++ (intmap-add out arg (sigbits-ref out var) ++ sigbits-union)) ++ out args vars)) ++ (($ $ktail) ++ (default)))) ++ (_ (default)))))))))) + + (define (specialize-operations cps) + (define (u6-parameter? param) +@@ -416,7 +404,7 @@ BITS indicating the significant bits needed for a variable. BITS may be + (define (all-u64-bits-set? var) + (operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64)))) + (define (only-fixnum-bits-used? var) +- (let ((bits (intmap-ref sigbits var))) ++ (let ((bits (sigbits-ref sigbits var))) + (and bits (= bits (logand bits (target-most-positive-fixnum)))))) + (define (fixnum-result? result) + (or (only-fixnum-bits-used? result) +@@ -429,7 +417,7 @@ BITS indicating the significant bits needed for a variable. BITS may be + min max + (target-most-positive-fixnum))))))) + (define (only-u64-bits-used? var) +- (let ((bits (intmap-ref sigbits var))) ++ (let ((bits (sigbits-ref sigbits var))) + (and bits (= bits (logand bits (1- (ash 1 64))))))) + (define (u64-result? result) + (or (only-u64-bits-used? result) +@@ -490,7 +478,7 @@ BITS indicating the significant bits needed for a variable. BITS may be + u64->fixnum) + ((only-fixnum-bits-used? result) + (lambda (cps k src u64) +- (u64->fixnum/truncate cps k src u64 (intmap-ref sigbits result)))) ++ (u64->fixnum/truncate cps k src u64 (sigbits-ref sigbits result)))) + (else + u64->scm))))) + (define (box-f64 result) +@@ -576,7 +564,7 @@ BITS indicating the significant bits needed for a variable. BITS may be + (('logand/immediate (? u64-result?) param (? u64-operand? a)) + (specialize-unop cps k src 'ulogand/immediate + (logand param +- (or (intmap-ref sigbits result) -1) ++ (or (sigbits-ref sigbits a) -1) + (1- (ash 1 64))) + a + (unbox-u64 a) (box-u64 result))) +-- +2.47.0 + + diff --git a/system/devel/guile/pspec.xml b/system/devel/guile/pspec.xml index afdbe6d4..b819410e 100644 --- a/system/devel/guile/pspec.xml +++ b/system/devel/guile/pspec.xml @@ -25,8 +25,12 @@ libunistring-devel - guile-3.0.10-backport-issue72913.patch guile-3.0.10-c23.patch + gcc14.patch + gcc15.patch + gcc10-x86-disable-one-test.patch + disable-test-out-of-memory.patch + guile-3.0.10-32bit_fixes-1.patch @@ -73,6 +77,13 @@ + + 2024-11-06 + 3.0.10 + Rebuild. + Pisi Linux Community + admin@pisilinux.org + 2024-10-30 3.0.10