distro: Add a statically-linked, relocatable Guile 2.0 package.

* distro/packages/base.scm (%guile-static, %guile-static-stripped): New
  variables.

* distro/patches/guile-relocatable.patch: New file.
* Makefile.am (dist_patch_DATA): Add it.

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'."