summaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/cross-toolchain.scm178
-rw-r--r--gnu/build/file-systems.scm153
-rw-r--r--gnu/build/vm.scm16
3 files changed, 267 insertions, 80 deletions
diff --git a/gnu/build/cross-toolchain.scm b/gnu/build/cross-toolchain.scm
new file mode 100644
index 0000000000..450443ca63
--- /dev/null
+++ b/gnu/build/cross-toolchain.scm
@@ -0,0 +1,178 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build cross-toolchain)
+ #:use-module (guix build utils)
+ #:use-module (guix build gnu-build-system)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 ftw)
+ #:export (cross-gcc-build-phases))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to build a cross-compiler.
+;;;
+;;; Code:
+
+(define %gcc-include-paths
+ ;; Environment variables for header search paths.
+ ;; Note: See <http://bugs.gnu.org/22186> for why not 'CPATH'.
+ '("C_INCLUDE_PATH"
+ "CPLUS_INCLUDE_PATH"
+ "OBJC_INCLUDE_PATH"
+ "OBJCPLUS_INCLUDE_PATH"))
+
+(define %gcc-cross-include-paths
+ ;; Search path for target headers when cross-compiling.
+ (map (cut string-append "CROSS_" <>) %gcc-include-paths))
+
+(define* (make-cross-binutils-visible #:key outputs inputs target
+ #:allow-other-keys)
+ "Create symlinks for 'as', 'nm', and 'ld' in the \"out\" output, under
+libexec/gcc, so that the cross-GCC can find them."
+ (let* ((out (assoc-ref outputs "out"))
+ (libexec (string-append out "/libexec/gcc/" target))
+ (binutils (string-append (assoc-ref inputs "binutils-cross")
+ "/bin/" target "-"))
+ (wrapper (string-append (assoc-ref inputs "ld-wrapper-cross")
+ "/bin/" target "-ld")))
+ (for-each (lambda (file)
+ (symlink (string-append binutils file)
+ (string-append libexec "/" file)))
+ '("as" "nm"))
+ (symlink wrapper (string-append libexec "/ld"))
+ #t))
+
+(define* (set-cross-path #:key inputs #:allow-other-keys)
+ "Add the cross kernel headers to CROSS_CPATH, and remove them from
+C_INCLUDE_PATH et al."
+ (match (assoc-ref inputs "libc")
+ ((? string? libc)
+ (let ((kernel (assoc-ref inputs "xkernel-headers")))
+ (define (cross? x)
+ ;; Return #t if X is a cross-libc or cross Linux.
+ (or (string-prefix? libc x)
+ (string-prefix? kernel x)))
+
+ (let ((cpath (string-append libc "/include"
+ ":" kernel "/include")))
+ (for-each (cut setenv <> cpath)
+ %gcc-cross-include-paths))
+
+ (setenv "CROSS_LIBRARY_PATH"
+ (string-append libc "/lib:" kernel "/lib")) ;for Hurd's libihash
+
+ (for-each (lambda (var)
+ (and=> (getenv var)
+ (lambda (value)
+ (let* ((path (search-path-as-string->list value))
+ (native-path (list->search-path-as-string
+ (remove cross? path) ":")))
+ (setenv var native-path)))))
+ (cons "LIBRARY_PATH" %gcc-include-paths))
+ #t))
+ (#f
+ ;; We're building the sans-libc cross-compiler, so nothing to do.
+ #t)))
+
+(define* (set-cross-path/mingw #:key inputs #:allow-other-keys)
+ "Add the cross MinGW headers to CROSS_C_*_INCLUDE_PATH, and remove them from
+C_*INCLUDE_PATH."
+ (let ((libc (assoc-ref inputs "libc"))
+ (gcc (assoc-ref inputs "gcc")))
+ (define (cross? x)
+ (and libc (string-prefix? libc x)))
+
+ (define (unpacked-mingw-dir)
+ (match (scandir "." (lambda (name)
+ (string-contains name "mingw-w64")))
+ ((mingw-dir)
+ (string-append
+ (getcwd) "/" mingw-dir "/mingw-w64-headers"))))
+
+ (if libc
+ (let ((cpath (string-append libc "/include"
+ ":" libc "/i686-w64-mingw32/include")))
+ (for-each (cut setenv <> cpath)
+ %gcc-cross-include-paths))
+
+ ;; libc is false, so we are building xgcc-sans-libc.
+ ;; Add essential headers from mingw-w64.
+ (let ((mingw-source (assoc-ref inputs "mingw-source")))
+ (system* "tar" "xvf" mingw-source)
+ (let ((mingw-headers (unpacked-mingw-dir)))
+ ;; We need _mingw.h which will gets built from _mingw.h.in by
+ ;; mingw-w64's configure. We cannot configure mingw-w64 until we
+ ;; have xgcc-sans-libc; substitute to the rescue.
+ (copy-file (string-append mingw-headers "/crt/_mingw.h.in")
+ (string-append mingw-headers "/crt/_mingw.h"))
+
+ (substitute* (string-append mingw-headers "/crt/_mingw.h")
+ (("@MINGW_HAS_SECURE_API@")
+ "#define MINGW_HAS_SECURE_API 1"))
+
+ (let ((cpath (string-append mingw-headers "/include"
+ ":" mingw-headers "/crt"
+ ":" mingw-headers
+ "/defaults/include")))
+ (for-each (cut setenv <> cpath)
+ (cons "CROSS_LIBRARY_PATH"
+ %gcc-cross-include-paths))))))
+
+ (when libc
+ (setenv "CROSS_LIBRARY_PATH"
+ (string-append libc "/lib"
+ ":" libc "/i686-w64-mingw32/lib")))
+
+ (setenv "CPP" (string-append gcc "/bin/cpp"))
+ (for-each (lambda (var)
+ (and=> (getenv var)
+ (lambda (value)
+ (let* ((path (search-path-as-string->list
+ value))
+ (native-path (list->search-path-as-string
+ (remove cross? path) ":")))
+ (setenv var native-path)))))
+ (cons "LIBRARY_PATH" %gcc-include-paths))
+ #t))
+
+(define (install-strip . _)
+ "Install a stripped GCC."
+ ;; Unlike our 'strip' phase, this will do the right thing for
+ ;; cross-compilers.
+ (zero? (system* "make" "install-strip")))
+
+(define* (cross-gcc-build-phases target
+ #:optional (phases %standard-phases))
+ "Modify PHASES to include everything needed to build a cross-GCC for TARGET,
+a target triplet."
+ (modify-phases phases
+ (add-before 'configure 'set-cross-path
+ (if (string-contains target "mingw")
+ set-cross-path/mingw
+ set-cross-path))
+ (add-after 'install 'make-cross-binutils-visible
+ (cut make-cross-binutils-visible #:target target <...>))
+ (replace 'install install-strip)))
+
+;;; cross-toolchain.scm ends here
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 0d55e91978..c121ca5f8b 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 David Craven <david@craven.ch>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -71,67 +72,69 @@
"Bind-mount SOURCE at TARGET."
(mount source target "" MS_BIND))
+(define (read-superblock device offset size magic?)
+ "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
+superblock on success, and #f if no valid superblock was found. MAGIC?
+takes a bytevector and returns #t when it's a valid superblock."
+ (call-with-input-file device
+ (lambda (port)
+ (seek port offset SEEK_SET)
+
+ (let ((block (make-bytevector size)))
+ (match (get-bytevector-n! port block 0 (bytevector-length block))
+ ((? eof-object?)
+ #f)
+ ((? number? len)
+ (and (= len (bytevector-length block))
+ (and (magic? block)
+ block))))))))
+
+(define (sub-bytevector bv start size)
+ "Return a copy of the SIZE bytes of BV starting from offset START."
+ (let ((result (make-bytevector size)))
+ (bytevector-copy! bv start result 0 size)
+ result))
+
+(define (null-terminated-latin1->string bv)
+ "Return the volume name of SBLOCK as a string of at most 256 characters, or
+#f if SBLOCK has no volume name."
+ ;; This is a Latin-1, nul-terminated string.
+ (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
+ (if (null? bytes)
+ #f
+ (list->string (map integer->char bytes)))))
+
;;;
;;; Ext2 file systems.
;;;
+;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
+;; TODO: Use "packed structs" from Guile-OpenGL or similar.
+
(define-syntax %ext2-endianness
;; Endianness of ext2 file systems.
(identifier-syntax (endianness little)))
-;; Offset in bytes of interesting parts of an ext2 superblock. See
-;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
-;; TODO: Use "packed structs" from Guile-OpenGL or similar.
-(define-syntax %ext2-sblock-magic (identifier-syntax 56))
-(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
-(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
-(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
+(define (ext2-superblock? sblock)
+ "Return #t when SBLOCK is an ext2 superblock."
+ (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
+ (= magic #xef53)))
(define (read-ext2-superblock device)
"Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
- (define %ext2-magic
- ;; The magic bytes that identify an ext2 file system.
- #xef53)
-
- (define superblock-size
- ;; Size of the interesting part of an ext2 superblock.
- 264)
-
- (define block
- ;; The superblock contents.
- (make-bytevector superblock-size))
-
- (call-with-input-file device
- (lambda (port)
- (seek port 1024 SEEK_SET)
-
- ;; Note: work around <http://bugs.gnu.org/17466>.
- (and (eqv? superblock-size (get-bytevector-n! port block 0
- superblock-size))
- (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
- %ext2-endianness)))
- (and (= magic %ext2-magic)
- block))))))
+ (read-superblock device 1024 264 ext2-superblock?))
(define (ext2-superblock-uuid sblock)
"Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
- (let ((uuid (make-bytevector 16)))
- (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
- uuid))
+ (sub-bytevector sblock 104 16))
(define (ext2-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
- (let ((bv (make-bytevector 16)))
- (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
+ (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
- ;; This is a Latin-1, nul-terminated string.
- (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
- (if (null? bytes)
- #f
- (list->string (map integer->char bytes))))))
;;;
@@ -146,37 +149,22 @@ if DEVICE does not contain an ext2 file system."
;; Endianness of LUKS headers.
(identifier-syntax (endianness big)))
-(define-syntax %luks-header-size
- ;; Size in bytes of the LUKS header, including key slots.
- (identifier-syntax 592))
-
-(define %luks-magic
- ;; The 'LUKS_MAGIC' constant.
- (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
- (list #xba #xbe))))
-
-(define (sub-bytevector bv start size)
- "Return a copy of the SIZE bytes of BV starting from offset START."
- (let ((result (make-bytevector size)))
- (bytevector-copy! bv start result 0 size)
- result))
+(define (luks-superblock? sblock)
+ "Return #t when SBLOCK is a luks superblock."
+ (define %luks-magic
+ ;; The 'LUKS_MAGIC' constant.
+ (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
+ (list #xba #xbe))))
+ (let ((magic (sub-bytevector sblock 0 6))
+ (version (bytevector-u16-ref sblock 6 %luks-endianness)))
+ (and (bytevector=? magic %luks-magic)
+ (= version 1))))
(define (read-luks-header file)
"Read a LUKS header from FILE. Return the raw header on success, and #f if
not valid header was found."
- (call-with-input-file file
- (lambda (port)
- (let ((header (make-bytevector %luks-header-size)))
- (match (get-bytevector-n! port header 0 (bytevector-length header))
- ((? eof-object?)
- #f)
- ((? number? len)
- (and (= len (bytevector-length header))
- (let ((magic (sub-bytevector header 0 6)) ;XXX: inefficient
- (version (bytevector-u16-ref header 6 %luks-endianness)))
- (and (bytevector=? magic %luks-magic)
- (= version 1)
- header)))))))))
+ ;; Size in bytes of the LUKS header, including key slots.
+ (read-superblock file 0 592 luks-superblock?))
(define (luks-header-uuid header)
"Return the LUKS UUID from HEADER, as a 16-byte bytevector."
@@ -267,7 +255,7 @@ returns #t if that partition's volume name is LABEL."
ext2-superblock-uuid
bytevector=?))
-(define partition-luks-uuid-predicate
+(define luks-partition-uuid-predicate
(partition-predicate read-luks-header
luks-header-uuid
bytevector=?))
@@ -289,7 +277,7 @@ or #f if none was found."
(define (find-partition-by-luks-uuid uuid)
"Return the first LUKS partition whose unique identifier is UUID (a bytevector),
or #f if none was found."
- (and=> (find (partition-luks-uuid-predicate uuid)
+ (and=> (find (luks-partition-uuid-predicate uuid)
(disk-partitions))
(cut string-append "/dev/" <>)))
@@ -464,6 +452,27 @@ form:
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
run a file system check."
+
+ (define (mount-nfs source mount-point type flags options)
+ (let* ((idx (string-rindex source #\:))
+ (host-part (string-take source idx))
+ ;; Strip [] from around host if present
+ (host (match (string-split host-part (string->char-set "[]"))
+ (("" h "") h)
+ ((h) h)))
+ (aa (match (getaddrinfo host "nfs") ((x . _) x)))
+ (sa (addrinfo:addr aa))
+ (inet-addr (inet-ntop (sockaddr:fam sa)
+ (sockaddr:addr sa))))
+
+ ;; Mounting an NFS file system requires passing the address
+ ;; of the server in the addr= option
+ (mount source mount-point type flags
+ (string-append "addr="
+ inet-addr
+ (if options
+ (string-append "," options)
+ "")))))
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
@@ -481,7 +490,11 @@ run a file system check."
(call-with-output-file mount-point (const #t)))
(mkdir-p mount-point))
- (mount source mount-point type flags options)
+ (cond
+ ((string-prefix? "nfs" type)
+ (mount-nfs source mount-point type flags options))
+ (else
+ (mount source mount-point type flags options)))
;; For read-only bind mounts, an extra remount is needed, as per
;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index cc5cf45362..60ee18ebe0 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -79,12 +79,9 @@ it via /dev/hda.
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."
- (define image-file
- (string-append "image." disk-image-format))
-
(when make-disk-image?
(unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
- image-file
+ output
(number->string disk-image-size)))
(error "qemu-img failed")))
@@ -115,7 +112,7 @@ the #:references-graphs parameter of 'derivation'."
builder)
(append
(if make-disk-image?
- `("-drive" ,(string-append "file=" image-file
+ `("-drive" ,(string-append "file=" output
",if=virtio"))
'())
;; Only enable kvm if we see /dev/kvm exists.
@@ -126,11 +123,10 @@ the #:references-graphs parameter of 'derivation'."
'()))))
(error "qemu failed" qemu))
- (if make-disk-image?
- (copy-file image-file output)
- (begin
- (mkdir output)
- (copy-recursively "xchg" output))))
+ ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
+ (unless make-disk-image?
+ (mkdir output)
+ (copy-recursively "xchg" output)))
;;;
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-08 16:53:24 +0000