summaryrefslogtreecommitdiff
path: root/guix/scripts/pack.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludovic.courtes@inria.fr>2018-05-02 17:08:37 +0200
committerLudovic Courtès <ludo@gnu.org>2018-05-10 14:53:57 +0200
commit47a60325ca650e8fc1a291c8655b4297f4de8deb (patch)
treec35def0132f7fa9d078d6818721667b8dbd73ba2 /guix/scripts/pack.scm
parent54fd5ad0a5da92a35056a72021174234913fe10f (diff)
pack: Add '--relocatable'.
* gnu/packages/aux-files/run-in-namespace.c: New file. * Makefile.am (AUX_FILES): Add it. * guix/scripts/pack.scm (<c-compiler>): New record type. (c-compiler, bootstrap-c-compiler, c-compiler-compiler): New procedures. (self-contained-tarball): Use 'relative-file-name' for the SOURCE -> TARGET symlink. (docker-image): Add 'defmod' to please Geiser. (wrapped-package, map-manifest-entries): New procedures. (%options, show-help): Add --relocatable. (guix-pack): Honor it.
Diffstat (limited to 'guix/scripts/pack.scm')
-rw-r--r--guix/scripts/pack.scm182
1 files changed, 173 insertions, 9 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0e09a01496..db5609219f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -32,6 +32,8 @@
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system gnu)
#:use-module (guix scripts build)
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
@@ -100,11 +102,14 @@ with a properly initialized store database.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack."
(define build
- (with-imported-modules '((guix build utils)
- (guix build store-copy)
- (gnu build install))
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (guix build union)
+ (guix build store-copy)
+ (gnu build install)))
#~(begin
(use-modules (guix build utils)
+ ((guix build union) #:select (relative-file-name))
(gnu build install)
(srfi srfi-1)
(srfi srfi-26)
@@ -119,7 +124,8 @@ added to the pack."
((source '-> target)
(let ((target (string-append #$profile "/" target)))
`((directory ,(dirname source))
- (,source -> ,target))))))
+ (,source
+ -> ,(relative-file-name (dirname source) target)))))))
(define directives
;; Fully-qualified symlinks.
@@ -217,11 +223,13 @@ the image."
(('gnu rest ...) #t)
(rest #f)))
+ (define defmod 'define-module) ;trick Geiser
+
(define config
;; (guix config) module for consumption by (guix gcrypt).
(scheme-file "gcrypt-config.scm"
#~(begin
- (define-module (guix config)
+ (#$defmod (guix config)
#:export (%libgcrypt))
;; XXX: Work around <http://bugs.gnu.org/15602>.
@@ -267,6 +275,150 @@ the image."
;;;
+;;; Compiling C programs.
+;;;
+
+;; A C compiler. That lowers to a single program that can be passed typical C
+;; compiler flags, and it makes sure the whole toolchain is available.
+(define-record-type <c-compiler>
+ (%c-compiler toolchain guile)
+ c-compiler?
+ (toolchain c-compiler-toolchain)
+ (guile c-compiler-guile))
+
+(define* (c-compiler #:optional inputs
+ #:key (guile (default-guile)))
+ (%c-compiler inputs guile))
+
+(define (bootstrap-c-compiler)
+ "Return the C compiler that uses the bootstrap toolchain. This is used only
+by '--bootstrap', for testing purposes."
+ (define bootstrap-toolchain
+ (list (first (assoc-ref %bootstrap-inputs "gcc"))
+ (first (assoc-ref %bootstrap-inputs "binutils"))
+ (first (assoc-ref %bootstrap-inputs "libc"))))
+
+ (c-compiler bootstrap-toolchain
+ #:guile %bootstrap-guile))
+
+(define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
+ "Lower COMPILER to a single script that does the right thing."
+ (define toolchain
+ (or (c-compiler-toolchain compiler)
+ (list (first (assoc-ref (standard-packages) "gcc"))
+ (first (assoc-ref (standard-packages) "ld-wrapper"))
+ (first (assoc-ref (standard-packages) "binutils"))
+ (first (assoc-ref (standard-packages) "libc"))
+ (gexp-input (first (assoc-ref (standard-packages) "libc"))
+ "static"))))
+
+ (define inputs
+ (match (append-map package-propagated-inputs
+ (filter package? toolchain))
+ (((labels things . _) ...)
+ (append toolchain things))))
+
+ (define search-paths
+ (cons $PATH
+ (append-map package-native-search-paths
+ (filter package? inputs))))
+
+ (define run
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (guix search-paths)))
+ #~(begin
+ (use-modules (guix build utils) (guix search-paths)
+ (ice-9 match))
+
+ (define (output-file args)
+ (let loop ((args args))
+ (match args
+ (() "a.out")
+ (("-o" file _ ...) file)
+ ((head rest ...) (loop rest)))))
+
+ (set-search-paths (map sexp->search-path-specification
+ '#$(map search-path-specification->sexp
+ search-paths))
+ '#$inputs)
+
+ (let ((output (output-file (command-line))))
+ (apply invoke "gcc" (cdr (command-line)))
+ (invoke "strip" output)))))
+
+ (when target
+ ;; TODO: Yep, we'll have to do it someday!
+ (leave (G_ "cross-compilation not implemented here;
+please email '~a'~%")
+ (@ (guix config) %guix-bug-report-address)))
+
+ (gexp->script "c-compiler" run
+ #:guile (c-compiler-guile compiler)))
+
+
+;;;
+;;; Wrapped package.
+;;;
+
+(define* (wrapped-package package
+ #:optional (compiler (c-compiler)))
+ (define runner
+ (local-file (search-auxiliary-file "run-in-namespace.c")))
+
+ (define build
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
+
+ (define (strip-store-prefix file)
+ ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
+ ;; "/bin/foo".
+ (let* ((len (string-length (%store-directory)))
+ (base (string-drop file (+ 1 len))))
+ (match (string-index base #\/)
+ (#f base)
+ (index (string-drop base index)))))
+
+ (define (build-wrapper program)
+ ;; Build a user-namespace wrapper for PROGRAM.
+ (format #t "building wrapper for '~a'...~%" program)
+ (copy-file #$runner "run.c")
+
+ (substitute* "run.c"
+ (("@WRAPPED_PROGRAM@") program)
+ (("@STORE_DIRECTORY@") (%store-directory)))
+
+ (let* ((base (strip-store-prefix program))
+ (result (string-append #$output "/" base)))
+ (mkdir-p (dirname result))
+ (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
+ "run.c" "-o" result)
+ (delete-file "run.c")))
+
+ (setvbuf (current-output-port)
+ (cond-expand (guile-2.2 'line)
+ (else _IOLBF)))
+ (for-each build-wrapper
+ (append (find-files #$(file-append package "/bin"))
+ (find-files #$(file-append package "/sbin"))
+ (find-files #$(file-append package "/libexec")))))))
+
+ (computed-file (string-append (package-full-name package "-") "R")
+ build))
+
+(define (map-manifest-entries proc manifest)
+ "Apply PROC to all the entries of MANIFEST and return a new manifest."
+ (make-manifest
+ (map (lambda (entry)
+ (manifest-entry
+ (inherit entry)
+ (item (proc (manifest-entry-item entry)))))
+ (manifest-entries manifest))))
+
+
+;;;
;;; Command-line options.
;;;
@@ -302,6 +454,9 @@ the image."
(option '(#\f "format") #t #f
(lambda (opt name arg result)
(alist-cons 'format (string->symbol arg) result)))
+ (option '(#\R "relocatable") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'relocatable? #t result)))
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
@@ -354,6 +509,8 @@ Create a bundle of PACKAGE.\n"))
(display (G_ "
-f, --format=FORMAT build a pack in the given FORMAT"))
(display (G_ "
+ -R, --relocatable produce relocatable executables"))
+ (display (G_ "
-e, --expression=EXPR consider the package EXPR evaluates to"))
(display (G_ "
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
@@ -417,6 +574,9 @@ Create a bundle of PACKAGE.\n"))
(with-error-handling
(with-store store
+ ;; Set the build options before we do anything else.
+ (set-build-options-from-command-line store opts)
+
(parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build (package-derivation
store
@@ -425,7 +585,13 @@ Create a bundle of PACKAGE.\n"))
(canonical-package guile-2.2))
#:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?))
- (manifest (manifest-from-args store opts))
+ (relocatable? (assoc-ref opts 'relocatable?))
+ (manifest (let ((manifest (manifest-from-args store opts)))
+ ;; Note: We cannot honor '--bootstrap' here because
+ ;; 'glibc-bootstrap' lacks 'libc.a'.
+ (if relocatable?
+ (map-manifest-entries wrapped-package manifest)
+ manifest)))
(pack-format (assoc-ref opts 'format))
(name (string-append (symbol->string pack-format)
"-pack"))
@@ -444,12 +610,10 @@ Create a bundle of PACKAGE.\n"))
(leave (G_ "~a: unknown pack format")
format))))
(localstatedir? (assoc-ref opts 'localstatedir?)))
- ;; Set the build options before we do anything else.
- (set-build-options-from-command-line store opts)
-
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
manifest
+ #:relative-symlinks? relocatable?
#:hooks (if bootstrap?
'()
%default-profile-hooks)