From 3dbeecd2ffb912d0a114593038e3a9f987d3eb38 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 16 Dec 2013 23:07:17 +0100 Subject: [PATCH] pull: Move build code to (guix build pull). * guix/build/pull.scm: New file. * Makefile.am (MODULES): Add it. * guix/scripts/pull.scm (unpack): Use it. --- Makefile.am | 1 + guix/build/pull.scm | 148 ++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pull.scm | 132 +++---------------------------------- 3 files changed, 158 insertions(+), 123 deletions(-) create mode 100644 guix/build/pull.scm diff --git a/Makefile.am b/Makefile.am index 13088ff525..eb278a76e9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -60,6 +60,7 @@ MODULES = \ guix/build/python-build-system.scm \ guix/build/utils.scm \ guix/build/union.scm \ + guix/build/pull.scm \ guix/build/rpath.scm \ guix/packages.scm \ guix/snix.scm \ diff --git a/guix/build/pull.scm b/guix/build/pull.scm new file mode 100644 index 0000000000..4bad88fe42 --- /dev/null +++ b/guix/build/pull.scm @@ -0,0 +1,148 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix build pull) + #:use-module (guix build utils) + #:use-module (system base compile) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:export (build-guix)) + +;;; Commentary: +;;; +;;; Helpers for the 'guix pull' command to unpack and build Guix. +;;; +;;; Code: + +(define (call-with-process thunk) + "Run THUNK in a separate process that will return 0 if THUNK terminates +normally, and 1 if an exception is raised." + (match (primitive-fork) + (0 + (catch #t + (lambda () + (thunk) + (primitive-exit 0)) + (lambda (key . args) + (print-exception (current-error-port) #f key args) + (primitive-exit 1)))) + (pid + #t))) + +(define* (p-for-each proc lst + #:optional (max-processes (current-processor-count))) + "Invoke PROC for each element of LST in a separate process, using up to +MAX-PROCESSES processes in parallel. Raise an error if one of the processes +exit with non-zero." + (define (wait-for-one-process) + (match (waitpid WAIT_ANY) + ((_ . status) + (unless (zero? (status:exit-val status)) + (error "process failed" proc status))))) + + (let loop ((lst lst) + (running 0)) + (match lst + (() + (or (zero? running) + (begin + (wait-for-one-process) + (loop lst (- running 1))))) + ((head . tail) + (if (< running max-processes) + (begin + (call-with-process (cut proc head)) + (loop tail (+ running 1))) + (begin + (wait-for-one-process) + (loop lst (- running 1)))))))) + +(define* (build-guix out tarball + #:key tar gzip gcrypt) + "Build and install Guix in directory OUT using source from TARBALL." + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (setenv "PATH" (string-append tar "/bin:" gzip "/bin")) + + (system* "tar" "xvf" tarball) + (match (scandir "." (lambda (name) + (and (not (member name '("." ".."))) + (file-is-directory? name)))) + ((dir) + (chdir dir)) + (x + (error "tarball did not produce a single source directory" x))) + + (format #t "copying and compiling Guix to `~a'...~%" out) + + ;; Copy everything under guix/ and gnu/ plus guix.scm. + (copy-recursively "guix" (string-append out "/guix")) + (copy-recursively "gnu" (string-append out "/gnu")) + (copy-file "guix.scm" (string-append out "/guix.scm")) + + ;; Add a fake (guix config) module to allow the other modules to be + ;; compiled. The user's (guix config) is the one that will be used. + (copy-file "guix/config.scm.in" + (string-append out "/guix/config.scm")) + (substitute* (string-append out "/guix/config.scm") + (("@LIBGCRYPT@") + (string-append gcrypt "/lib/libgcrypt"))) + + ;; Augment the search path so Scheme code can be compiled. + (set! %load-path (cons out %load-path)) + (set! %load-compiled-path (cons out %load-compiled-path)) + + ;; Compile the .scm files. Do that in independent processes, à la + ;; 'make -j', to work around (FIXME). + ;; This ensures correctness, but is overly conservative and slow. + ;; The solution initially implemented (and described in the bug + ;; above) was slightly faster but consumed memory proportional to the + ;; number of modules, which quickly became unacceptable. + (p-for-each (lambda (file) + (let ((go (string-append (string-drop-right file 4) + ".go"))) + (format (current-error-port) + "compiling '~a'...~%" file) + (compile-file file + #:output-file go + #:opts + %auto-compilation-options))) + + (filter (cut string-suffix? ".scm" <>) + + ;; Build guix/*.scm before gnu/*.scm to speed + ;; things up. + (sort (find-files out "\\.scm") + (let ((guix (string-append out "/guix")) + (gnu (string-append out "/gnu"))) + (lambda (a b) + (or (and (string-prefix? guix a) + (string-prefix? gnu b)) + (string (FIXME). - ;; This ensures correctness, but is overly conservative and slow. - ;; The solution initially implemented (and described in the bug - ;; above) was slightly faster but consumed memory proportional to the - ;; number of modules, which quickly became unacceptable. - (p-for-each (lambda (file) - (let ((go (string-append (string-drop-right file 4) - ".go"))) - (format (current-error-port) - "compiling '~a'...~%" file) - (compile-file file - #:output-file go - #:opts - %auto-compilation-options))) - - (filter (cut string-suffix? ".scm" <>) - - ;; Build guix/*.scm before gnu/*.scm to speed - ;; things up. - (sort (find-files out "\\.scm") - (let ((guix (string-append out "/guix")) - (gnu (string-append out "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (stringderivation store "guix-latest" builder #:inputs @@ -172,7 +57,8 @@ files." ("gcrypt" ,(package-derivation store libgcrypt)) ("tarball" ,tarball)) - #:modules '((guix build utils)))) + #:modules '((guix build pull) + (guix build utils)))) ;;;