Browse Source

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.
version-0.8.3
Ludovic Courtès 10 years ago
parent
commit
df1fab5837
  1. 1
      Makefile.am
  2. 100
      distro/packages/base.scm
  3. 60
      distro/patches/guile-relocatable.patch
  4. 4
      guix/store.scm
  5. 20
      guix/utils.scm

1
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 \

100
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

60
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));
}

4
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)))

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

Loading…
Cancel
Save