Pisilinux/core
5
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

huile rebuild

Browse Source
This commit is contained in:
Rmys
2025-11-07 17:57:40 +03:00
parent 7a85f15ae2
commit 6cf6be768b
6 changed files with 787 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files
system/devel/guile/files/disable-test-out-of-memory.patch
+24
View File
@@ -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) \
system/devel/guile/files/gcc10-x86-disable-one-test.patch
+22
View File
@@ -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
system/devel/guile/files/gcc14.patch
+14
View File
@@ -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);
system/devel/guile/files/gcc15.patch
+312
View File
@@ -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 <collin.funk1@gmail.com>
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
system/devel/guile/files/guile-3.0.10-32bit_fixes-1.patch
+403
View File
@@ -0,0 +1,403 @@
Submitted By: Douglas R. Reno <renodr at linuxfromscratch dot org>
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 <wingo@pobox.com>
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 <wingo@pobox.com>
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 <wingo@pobox.com>
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 <wingo@pobox.com>
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
system/devel/guile/pspec.xml
+12 -1
View File
@@ -25,8 +25,12 @@
<Dependency>libunistring-devel</Dependency> <Dependency>libunistring-devel</Dependency>
</BuildDependencies> </BuildDependencies>
<Patches> <Patches>
<Patch level="1">guile-3.0.10-backport-issue72913.patch</Patch>
<Patch level="1">guile-3.0.10-c23.patch</Patch> <Patch level="1">guile-3.0.10-c23.patch</Patch>
<Patch level="1">gcc14.patch</Patch>
<Patch level="1">gcc15.patch</Patch>
<Patch level="1">gcc10-x86-disable-one-test.patch</Patch>
<Patch level="1">disable-test-out-of-memory.patch</Patch>
<Patch level="1">guile-3.0.10-32bit_fixes-1.patch</Patch>
</Patches> </Patches>
</Source> </Source>
@@ -73,6 +77,13 @@
</Package> </Package>
<History> <History>
<Update release="10">
<Date>2024-11-06</Date>
<Version>3.0.10</Version>
<Comment>Rebuild.</Comment>
<Name>Pisi Linux Community</Name>
<Email>admin@pisilinux.org</Email>
</Update>
<Update release="9"> <Update release="9">
<Date>2024-10-30</Date> <Date>2024-10-30</Date>
<Version>3.0.10</Version> <Version>3.0.10</Version>