diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/asdf-build-system.scm | 51 | ||||
| -rw-r--r-- | guix/build/lisp-utils.scm | 185 |
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 |