diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | distro/packages/base.scm | 100 | ||||
| -rw-r--r-- | distro/patches/guile-relocatable.patch | 60 | ||||
| -rw-r--r-- | guix/store.scm | 4 | ||||
| -rw-r--r-- | guix/utils.scm | 20 |
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'." |