summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/asdf-build-system.scm51
-rw-r--r--guix/build/lisp-utils.scm185
2 files changed, 143 insertions, 93 deletions
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 10873e98d9..a16f11965d 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -21,6 +21,7 @@
#:use-module (guix build utils)
#:use-module (guix build lisp-utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
@@ -161,31 +162,25 @@ valid."
(format #t "test suite not run~%")))
#t)
-(define* (patch-asd-files #:key outputs
+(define* (create-asd-file #:key outputs
inputs
lisp
- special-dependencies
- test-only-systems
+ asd-file
#:allow-other-keys)
- "Patch any asd files created by the compilation process so that they can
-find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only
-included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP
-implementation itself provides."
- (let* ((out (library-output outputs))
- (name (remove-lisp-from-name (output-path->package-name out) lisp))
- (registry (lset-difference
- (lambda (input system)
- (match input
- ((name . path) (string=? name system))))
- (lisp-dependencies lisp inputs)
- test-only-systems))
- (lisp-systems (map first registry)))
-
- (for-each
- (lambda (asd-file)
- (patch-asd-file asd-file registry lisp
- (append lisp-systems special-dependencies)))
- (find-files out "\\.asd$")))
+ "Create a system definition file for the built system."
+ (let*-values (((out) (library-output outputs))
+ ((full-name version) (package-name->name+version
+ (strip-store-file-name out)))
+ ((name) (remove-lisp-from-name full-name lisp))
+ ((new-asd-file) (string-append (library-directory out lisp)
+ "/" name ".asd")))
+
+ (make-asd-file new-asd-file
+ #:lisp lisp
+ #:system name
+ #:version version
+ #:inputs inputs
+ #:system-asd-file asd-file))
#t)
(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys)
@@ -193,9 +188,6 @@ implementation itself provides."
(let* ((out (library-output outputs)))
(for-each
(lambda (asd-file)
- (substitute* asd-file
- ((";;; Built for.*") "") ; remove potential non-determinism
- (("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" end)))
(receive (new-asd-file asd-file-directory)
(bundle-asd-file out asd-file lisp)
(mkdir-p asd-file-directory)
@@ -205,12 +197,11 @@ implementation itself provides."
(prepend-to-source-registry
(string-append asd-file-directory "/"))))
- (find-files (string-append out %object-prefix) "\\.asd$"))
-)
+ (find-files (string-append out %object-prefix) "\\.asd$")))
#t)
(define* (cleanup-files #:key outputs lisp
- #:allow-other-keys)
+ #:allow-other-keys)
"Remove any compiled files which are not a part of the final bundle."
(let ((out (library-output outputs)))
(match lisp
@@ -261,8 +252,8 @@ implementation itself provides."
(add-before 'build 'copy-source copy-source)
(replace 'check check)
(replace 'strip strip)
- (add-after 'check 'link-dependencies patch-asd-files)
- (add-after 'link-dependencies 'cleanup cleanup-files)
+ (add-after 'check 'create-asd-file create-asd-file)
+ (add-after 'create-asd-file 'cleanup cleanup-files)
(add-after 'cleanup 'create-symlinks symlink-asd-files)))
(define* (asdf-build #:key inputs
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 47399bc187..4f1565b55c 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -18,6 +18,7 @@
(define-module (guix build lisp-utils)
#:use-module (ice-9 format)
+ #:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
@@ -32,15 +33,14 @@
generate-executable-wrapper-system
generate-executable-entry-point
generate-executable-for-system
- patch-asd-file
bundle-install-prefix
- lisp-dependencies
bundle-asd-file
remove-lisp-from-name
wrap-output-translations
prepend-to-source-registry
build-program
- build-image))
+ build-image
+ make-asd-file))
;;; Commentary:
;;;
@@ -64,6 +64,23 @@
(define (remove-lisp-from-name name lisp)
(string-drop name (1+ (string-length lisp))))
+(define (inputs->asd-file-map inputs lisp)
+ "Produce a hash table of the form (system . asd-file), where system is the
+name of an ASD system, and asd-file is the full path to its definition."
+ (alist->hash-table
+ (filter-map
+ (match-lambda
+ ((_ . path)
+ (let ((prefix (string-append path (bundle-install-prefix lisp))))
+ (and (directory-exists? prefix)
+ (match (find-files prefix "\\.asd$")
+ ((asd-file)
+ (cons
+ (string-drop-right (basename asd-file) 4) ; drop ".asd"
+ asd-file))
+ (_ #f))))))
+ inputs)))
+
(define (wrap-output-translations translations)
`(:output-translations
,@translations
@@ -80,7 +97,8 @@
with PROGRAM."
(match lisp
("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
- ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
+ ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))
+ (_ (error "The LISP provided is not supported at this time."))))
(define (asdf-load-all systems)
(map (lambda (system)
@@ -108,15 +126,61 @@ first if SYSTEM is defined there."
(find-symbol
(symbol-name :compile-bundle-op)
(symbol-name :asdf))
- ,system)
- (funcall (find-symbol
- (symbol-name :operate)
- (symbol-name :asdf))
- (find-symbol
- (symbol-name :deliver-asd-op)
- (symbol-name :asdf))
,system))))
+(define (system-dependencies lisp system asd-file)
+ "Return the dependencies of SYSTEM, as reported by
+asdf:system-depends-on. First load the system's ASD-FILE, if necessary."
+ (define deps-file ".deps.sexp")
+ (define program
+ `(progn
+ (require :asdf)
+ ,@(if asd-file
+ `((let ((*package* (find-package :asdf)))
+ (load ,asd-file)))
+ '())
+ (with-open-file
+ (stream ,deps-file :direction :output)
+ (format stream
+ "~s~%"
+ (funcall
+ (find-symbol
+ (symbol-name :system-depends-on)
+ (symbol-name :asdf))
+
+ (funcall
+ (find-symbol
+ (symbol-name :find-system)
+ (symbol-name :asdf))
+
+ ,system))))))
+
+ (dynamic-wind
+ (lambda _
+ (lisp-eval-program lisp program))
+ (lambda _
+ (call-with-input-file deps-file read))
+ (lambda _
+ (when (file-exists? deps-file)
+ (delete-file deps-file)))))
+
+(define (compiled-system system lisp)
+ (match lisp
+ ("sbcl" (string-append system "--system"))
+ (_ system)))
+
+(define* (generate-system-definition lisp system
+ #:key version dependencies)
+ `(asdf:defsystem
+ ,system
+ :class asdf/bundle:prebuilt-system
+ :version ,version
+ :depends-on ,dependencies
+ :components ((:compiled-file ,(compiled-system system lisp)))
+ ,@(if (string=? "ecl" lisp)
+ `(:lib ,(string-append system ".a"))
+ '())))
+
(define (test-system system lisp asd-file)
"Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first
if SYSTEM is defined there."
@@ -185,58 +249,53 @@ ENTRY-PROGRAM for SYSTEM within the current directory."
(declare (ignorable arguments))
,@entry-program))))))))
-(define (wrap-perform-method lisp registry dependencies file-name)
- "Creates a wrapper method which allows the system to locate its dependent
-systems from REGISTRY, an alist of the same form as %outputs, which contains
-lisp systems which the systems is dependent on. All DEPENDENCIES which the
-system depends on will the be loaded before this system."
- (let* ((system (string-drop-right (basename file-name) 4))
- (system-symbol (string->lisp-keyword system)))
-
- `(defmethod asdf:perform :before
- (op (c (eql (asdf:find-system ,system-symbol))))
- (asdf/source-registry:ensure-source-registry)
- ,@(map (match-lambda
- ((name . path)
- (let ((asd-file (string-append path
- (bundle-install-prefix lisp)
- "/" name ".asd")))
- `(setf
- (gethash ,name
- asdf/source-registry:*source-registry*)
- ,(string->symbol "#p")
- ,(bundle-asd-file path asd-file lisp)))))
- registry)
- ,@(map (lambda (system)
- `(asdf:load-system ,(string->lisp-keyword system)))
- dependencies))))
-
-(define (patch-asd-file asd-file registry lisp dependencies)
- "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD."
- (chmod asd-file #o644)
- (let ((port (open-file asd-file "a")))
- (dynamic-wind
- (lambda _ #t)
- (lambda _
- (display
- (replace-escaped-macros
- (format #f "~%~y~%"
- (wrap-perform-method lisp registry
- dependencies asd-file)))
- port))
- (lambda _ (close-port port))))
- (chmod asd-file #o444))
-
-(define (lisp-dependencies lisp inputs)
- "Determine which inputs are lisp system dependencies, by using the convention
-that a lisp system dependency will resemble \"system-LISP\"."
- (filter-map (match-lambda
- ((name . value)
- (and (string-prefix? lisp name)
- (string<> lisp name)
- `(,(remove-lisp-from-name name lisp)
- . ,value))))
- inputs))
+(define (generate-dependency-links lisp registry system)
+ "Creates a program which populates asdf's source registry from REGISTRY, an
+alist of dependency names to corresponding asd files. This allows the system
+to locate its dependent systems."
+ `(progn
+ (asdf/source-registry:ensure-source-registry)
+ ,@(map (match-lambda
+ ((name . asd-file)
+ `(setf
+ (gethash ,name
+ asdf/source-registry:*source-registry*)
+ ,(string->symbol "#p")
+ ,asd-file)))
+ registry)))
+
+(define* (make-asd-file asd-file
+ #:key lisp system version inputs
+ (system-asd-file #f))
+ "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
+system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
+ (define dependencies
+ (parameterize ((%lisp (string-append (assoc-ref inputs lisp) "/bin/" lisp)))
+ (system-dependencies lisp system system-asd-file)))
+
+ (define lisp-input-map
+ (inputs->asd-file-map inputs lisp))
+
+ (define registry
+ (filter-map hash-get-handle
+ (make-list (if (eq? 'NIL dependencies)
+ 0
+ (length dependencies))
+ lisp-input-map)
+ (if (eq? 'NIL dependencies)
+ '()
+ dependencies)))
+
+ (call-with-output-file asd-file
+ (lambda (port)
+ (display
+ (replace-escaped-macros
+ (format #f "~y~%~y~%"
+ (generate-system-definition lisp system
+ #:version version
+ #:dependencies dependencies)
+ (generate-dependency-links lisp registry system)))
+ port))))
(define (bundle-asd-file output-path original-asd-file lisp)
"Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in