summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am1
-rw-r--r--distro/packages/base.scm100
-rw-r--r--distro/patches/guile-relocatable.patch60
-rw-r--r--guix/store.scm4
-rw-r--r--guix/utils.scm20
5 files changed, 185 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am
index 610d2d2f2c..2bb8d48ed9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,6 +50,7 @@ dist_patch_DATA = \
distro/patches/binutils-ld-new-dtags.patch \
distro/patches/diffutils-gets-undeclared.patch \
distro/patches/guile-1.8-cpp-4.5.patch \
+ distro/patches/guile-relocatable.patch \
distro/patches/libtool-skip-tests.patch \
distro/patches/m4-gets-undeclared.patch \
distro/patches/m4-readlink-EINVAL.patch \
diff --git a/distro/packages/base.scm b/distro/packages/base.scm
index 2fb67b62af..39044e1c30 100644
--- a/distro/packages/base.scm
+++ b/distro/packages/base.scm
@@ -1997,4 +1997,104 @@ store.")
(license #f)
(home-page #f)))
+(define %guile-static
+ ;; A statically-linked Guile that is relocatable--i.e., it can search
+ ;; .scm and .go files relative to its installation directory, rather
+ ;; than in hard-coded configure-time paths.
+ (let ((guile (package (inherit guile-2.0)
+ (inputs
+ `(("patch/relocatable"
+ ,(search-patch "guile-relocatable.patch"))
+ ,@(package-inputs guile-2.0)))
+ (arguments
+ `(;; When `configure' checks for ltdl availability, it
+ ;; doesn't try to link using libtool, and thus fails
+ ;; because of a missing -ldl. Work around that.
+ #:configure-flags '("LDFLAGS=-ldl")
+
+ #:phases (alist-cons-before
+ 'configure 'static-guile
+ (lambda _
+ (substitute* "libguile/Makefile.in"
+ ;; Create a statically-linked `guile'
+ ;; executable.
+ (("^guile_LDFLAGS =")
+ "guile_LDFLAGS = -all-static")
+
+ ;; Add `-ldl' *after* libguile-2.0.la.
+ (("^guile_LDADD =(.*)$" _ ldadd)
+ (string-append "guile_LDADD = "
+ (string-trim-right ldadd)
+ " -ldl\n"))))
+ %standard-phases)
+
+ ;; Allow Guile to be relocated, as is needed during
+ ;; bootstrap.
+ #:patches
+ (list (assoc-ref %build-inputs "patch/relocatable"))
+
+ ;; There are uses of `dynamic-link' in
+ ;; {foreign,coverage}.test that don't fly here.
+ #:tests? #f)))))
+ (static-package guile (current-source-location))))
+
+(define %guile-static-stripped
+ ;; A stripped static Guile binary, for use during bootstrap.
+ (package (inherit %guile-static)
+ (name "guile-static-stripped")
+ (build-system trivial-build-system)
+ (arguments
+ `(#:modules ((guix build utils))
+ #:builder
+ (let ()
+ (use-modules (ice-9 ftw)
+ (guix build utils))
+
+ (define (copy-recursively source destination)
+ ;; Copy SOURCE directory to DESTINATION.
+ (with-directory-excursion source
+ (file-system-fold (const #t)
+ (lambda (file stat result) ; leaf
+ (format #t "copying `~s/~s' to `~s'...~%"
+ source file destination)
+ (copy-file file
+ (string-append destination
+ "/" file)))
+ (lambda (dir stat result) ; down
+ (let ((dir (string-append destination
+ "/" dir)))
+ (unless (file-exists? dir)
+ (mkdir dir))))
+ (lambda (dir stat result) ; up
+ result)
+ (const #t) ; skip
+ (lambda (file stat errno result)
+ (format (current-error-port)
+ "i/o error: ~a: ~a~%" file
+ (strerror errno)))
+ #t
+ ".")))
+
+ (let ((in (assoc-ref %build-inputs "guile"))
+ (out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (mkdir (string-append out "/share"))
+ (mkdir (string-append out "/share/guile"))
+ (mkdir (string-append out "/share/guile/2.0"))
+ (copy-recursively (string-append in "/share/guile/2.0")
+ (string-append out "/share/guile/2.0"))
+
+ (mkdir (string-append out "/lib"))
+ (mkdir (string-append out "/lib/guile"))
+ (mkdir (string-append out "/lib/guile/2.0"))
+ (mkdir (string-append out "/lib/guile/2.0/ccache"))
+ (copy-recursively (string-append in "/lib/guile/2.0/ccache")
+ (string-append out "/lib/guile/2.0/ccache"))
+
+ (mkdir (string-append out "/bin"))
+ (copy-file (string-append in "/bin/guile")
+ (string-append out "/bin/guile"))
+ #t))))
+ (inputs `(("guile" ,%guile-static)))))
+
;;; base.scm ends here
diff --git a/distro/patches/guile-relocatable.patch b/distro/patches/guile-relocatable.patch
new file mode 100644
index 0000000000..d96d6a8c9a
--- /dev/null
+++ b/distro/patches/guile-relocatable.patch
@@ -0,0 +1,60 @@
+This patch changes Guile to use a default search path relative to the
+location of the `guile' binary, allowing it to be relocated.
+
+diff --git a/libguile/load.c b/libguile/load.c
+index af2ca45..751c903 100644
+--- a/libguile/load.c
++++ b/libguile/load.c
+@@ -26,6 +26,7 @@
+
+ #include <string.h>
+ #include <stdio.h>
++#include <libgen.h>
+
+ #include "libguile/_scm.h"
+ #include "libguile/private-gc.h" /* scm_getenv_int */
+@@ -255,6 +256,26 @@ scm_init_load_path ()
+ SCM cpath = SCM_EOL;
+
+ #ifdef SCM_LIBRARY_DIR
++ char *bin_dir, *prefix, *module_dir, *ccache_dir;
++
++ /* Determine the source and compiled module directories at run-time,
++ relative to the executable's location. */
++
++ bin_dir = dirname (strdupa (program_invocation_name));
++
++ prefix = scm_gc_malloc_pointerless (strlen (bin_dir) + 4, "string");
++ strcpy (prefix, bin_dir);
++ strcat (prefix, "/..");
++ prefix = canonicalize_file_name (prefix);
++
++ module_dir = scm_gc_malloc_pointerless (strlen (prefix) + 50, "string");
++ strcpy (module_dir, prefix);
++ strcat (module_dir, "/share/guile/2.0");
++
++ ccache_dir = scm_gc_malloc_pointerless (strlen (prefix) + 50, "string");
++ strcpy (ccache_dir, prefix);
++ strcat (ccache_dir, "/lib/guile/2.0/ccache");
++
+ env = getenv ("GUILE_SYSTEM_PATH");
+ if (env && strcmp (env, "") == 0)
+ /* special-case interpret system-path=="" as meaning no system path instead
+@@ -263,7 +284,7 @@ scm_init_load_path ()
+ else if (env)
+ path = scm_parse_path (scm_from_locale_string (env), path);
+ else
+- path = scm_list_4 (scm_from_locale_string (SCM_LIBRARY_DIR),
++ path = scm_list_4 (scm_from_locale_string (module_dir),
+ scm_from_locale_string (SCM_SITE_DIR),
+ scm_from_locale_string (SCM_GLOBAL_SITE_DIR),
+ scm_from_locale_string (SCM_PKGDATA_DIR));
+@@ -276,7 +297,7 @@ scm_init_load_path ()
+ cpath = scm_parse_path (scm_from_locale_string (env), cpath);
+ else
+ {
+- cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR),
++ cpath = scm_list_2 (scm_from_locale_string (ccache_dir),
+ scm_from_locale_string (SCM_SITE_CCACHE_DIR));
+ }
+
diff --git a/guix/store.scm b/guix/store.scm
index 3eedcbed57..9c965af605 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -264,6 +264,10 @@
;; This trick allows use of the `scm_c_read' optimization.
(socket PF_UNIX SOCK_STREAM 0)))
(a (make-socket-address PF_UNIX file)))
+
+ ;; Enlarge the receive buffer.
+ (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+
(connect s a)
(write-int %worker-magic-1 s)
(let ((r (read-int s)))
diff --git a/guix/utils.scm b/guix/utils.scm
index a87f119558..2d51e44a22 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -588,6 +588,26 @@ FIELD/DEFAULT-VALUE tuples."
(hash-set! cache args results)
(apply values results)))))))
+(define-syntax hash-set-proc
+ (syntax-rules (eq? eqv? equal?)
+ ((_ eq?) hashq-set!)
+ ((_ eqv?) hashv-set!)
+ ((_ equal?) hash-set!)))
+
+(define-syntax hash-ref*
+ (syntax-rules (eq? eqv? equal?)
+ ((_ table key eq?) (hashq-ref table key))
+ ((_ table key eqv?) (hashv-ref table key))
+ ((_ table key equal?) (hash-ref table key))))
+
+(define-syntax memoizing-lambda
+ (syntax-rules ()
+ ((_ ((arg type) ...) body ...)
+ (let ((cache (make-weak-key-hash-table 100)))
+ (lambda (arg ...)
+ (or (and (hash-ref* cache)))
+ )))))
+
(define (gnu-triplet->nix-system triplet)
"Return the Nix system type corresponding to TRIPLET, a GNU triplet as
returned by `config.guess'."
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-05 06:34:48 +0000