summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorAndy Patterson <ajpatter@uwaterloo.ca>2016-10-07 17:57:08 -0400
committer宋文武 <iyzsong@gmail.com>2016-10-08 21:20:35 +0800
commita1b30f99a87b497ddc4ee5d6e50dc465ebb13f19 (patch)
treec8311eac0e6dd2c38ac8f43bdd28233294728284 /guix/build
parent53aec0999f5f5e2183d439c356dc1d7df6202a50 (diff)
build-system: Add asdf-build-system.
* guix/build-system/asdf.scm: New file. * guix/build/asdf-build-system.scm: New file. * guix/build/lisp-utils.scm: New file. * Makefile.am (MODULES): Add them. * doc/guix.texi (Build Systems): Document 'asdf-build-system'. Signed-off-by: 宋文武 <iyzsong@gmail.com>
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/asdf-build-system.scm282
-rw-r--r--guix/build/lisp-utils.scm327
2 files changed, 609 insertions, 0 deletions
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
new file mode 100644
index 0000000000..085d073dea
--- /dev/null
+++ b/guix/build/asdf-build-system.scm
@@ -0,0 +1,282 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;;
+;;; 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 (guix build asdf-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (guix build lisp-utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
+ #:export (%standard-phases
+ %standard-phases/source
+ asdf-build
+ asdf-build/source))
+
+;; Commentary:
+;;
+;; System for building ASDF packages; creating executable programs and images
+;; from them.
+;;
+;; Code:
+
+(define %object-prefix "/lib")
+
+(define (source-install-prefix lisp)
+ (string-append %install-prefix "/" lisp "-source"))
+
+(define %system-install-prefix
+ (string-append %install-prefix "/systems"))
+
+(define (output-path->package-name path)
+ (package-name->name+version (strip-store-file-name path)))
+
+(define (outputs->name outputs)
+ (output-path->package-name
+ (assoc-ref outputs "out")))
+
+(define (lisp-source-directory output lisp name)
+ (string-append output (source-install-prefix lisp) "/" name))
+
+(define (source-directory output name)
+ (string-append output %install-prefix "/source/" name))
+
+(define (library-directory output lisp)
+ (string-append output %object-prefix
+ "/" lisp))
+
+(define (output-translation source-path
+ object-output
+ lisp)
+ "Return a translation for the system's source path
+to it's binary output."
+ `((,source-path
+ :**/ :*.*.*)
+ (,(library-directory object-output lisp)
+ :**/ :*.*.*)))
+
+(define (source-asd-file output lisp name asd-file)
+ (string-append (lisp-source-directory output lisp name) "/" asd-file))
+
+(define (copy-files-to-output outputs output name)
+ "Copy all files from OUTPUT to \"out\". Create an extra link to any
+system-defining files in the source to a convenient location. This is done
+before any compiling so that the compiled source locations will be valid."
+ (let* ((out (assoc-ref outputs output))
+ (source (getcwd))
+ (target (source-directory out name))
+ (system-path (string-append out %system-install-prefix)))
+ (copy-recursively source target)
+ (mkdir-p system-path)
+ (for-each
+ (lambda (file)
+ (symlink file
+ (string-append system-path "/" (basename file))))
+ (find-files target "\\.asd$"))
+ #t))
+
+(define* (install #:key outputs #:allow-other-keys)
+ "Copy and symlink all the source files."
+ (copy-files-to-output outputs "out" (outputs->name outputs)))
+
+(define* (copy-source #:key outputs lisp #:allow-other-keys)
+ "Copy the source to \"out\"."
+ (let* ((out (assoc-ref outputs "out"))
+ (name (remove-lisp-from-name (output-path->package-name out) lisp))
+ (install-path (string-append out %install-prefix)))
+ (copy-files-to-output outputs "out" name)
+ ;; Hide the files from asdf
+ (with-directory-excursion install-path
+ (rename-file "source" (string-append lisp "-source"))
+ (delete-file-recursively "systems")))
+ #t)
+
+(define* (build #:key outputs inputs lisp asd-file
+ #:allow-other-keys)
+ "Compile the system."
+ (let* ((out (assoc-ref outputs "out"))
+ (name (remove-lisp-from-name (output-path->package-name out) lisp))
+ (source-path (lisp-source-directory out lisp name))
+ (translations (wrap-output-translations
+ `(,(output-translation source-path
+ out
+ lisp))))
+ (asd-file (and=> asd-file (cut source-asd-file out lisp name <>))))
+
+ (setenv "ASDF_OUTPUT_TRANSLATIONS"
+ (replace-escaped-macros (format #f "~S" translations)))
+
+ ;; We don't need this if we have the asd file, and it can mess with the
+ ;; load ordering we're trying to enforce
+ (unless asd-file
+ (prepend-to-source-registry (string-append source-path "//")))
+
+ (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
+
+ (parameterize ((%lisp (string-append
+ (assoc-ref inputs lisp) "/bin/" lisp)))
+ (compile-system name lisp asd-file))
+
+ ;; As above, ecl will sometimes create this even though it doesn't use it
+
+ (let ((cache-directory (string-append out "/.cache")))
+ (when (directory-exists? cache-directory)
+ (delete-file-recursively cache-directory))))
+ #t)
+
+(define* (check #:key lisp tests? outputs inputs asd-file
+ #:allow-other-keys)
+ "Test the system."
+ (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp))
+ (out (assoc-ref outputs "out"))
+ (asd-file (and=> asd-file (cut source-asd-file out lisp name <>))))
+ (if tests?
+ (parameterize ((%lisp (string-append
+ (assoc-ref inputs lisp) "/bin/" lisp)))
+ (test-system name lisp asd-file))
+ (format #t "test suite not run~%")))
+ #t)
+
+(define* (patch-asd-files #:key outputs
+ inputs
+ lisp
+ special-dependencies
+ test-only-systems
+ #: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 (assoc-ref outputs "out"))
+ (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$")))
+ #t)
+
+(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys)
+ "Create an extra reference to the system in a convenient location."
+ (let* ((out (assoc-ref outputs "out")))
+ (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)
+ (symlink asd-file new-asd-file)
+ ;; Update the source registry for future phases which might want to
+ ;; use the newly compiled system.
+ (prepend-to-source-registry
+ (string-append asd-file-directory "/"))))
+
+ (find-files (string-append out %object-prefix) "\\.asd$"))
+)
+ #t)
+
+(define* (cleanup-files #:key outputs lisp
+ #:allow-other-keys)
+ "Remove any compiled files which are not a part of the final bundle."
+ (let ((out (assoc-ref outputs "out")))
+ (match lisp
+ ("sbcl"
+ (for-each
+ (lambda (file)
+ (unless (string-suffix? "--system.fasl" file)
+ (delete-file file)))
+ (find-files out "\\.fasl$")))
+ ("ecl"
+ (for-each delete-file
+ (append (find-files out "\\.fas$")
+ (find-files out "\\.o$")
+ (find-files out "\\.a$")))))
+
+ (with-directory-excursion (library-directory out lisp)
+ (for-each
+ (lambda (file)
+ (rename-file file
+ (string-append "./" (basename file))))
+ (find-files "."))
+ (for-each delete-file-recursively
+ (scandir "."
+ (lambda (file)
+ (and
+ (directory-exists? file)
+ (string<> "." file)
+ (string<> ".." file)))))))
+ #t)
+
+(define* (strip #:key lisp #:allow-other-keys #:rest args)
+ ;; stripping sbcl binaries removes their entry program and extra systems
+ (or (string=? lisp "sbcl")
+ (apply (assoc-ref gnu:%standard-phases 'strip) args)))
+
+(define %standard-phases/source
+ (modify-phases gnu:%standard-phases
+ (delete 'configure)
+ (delete 'check)
+ (delete 'build)
+ (replace 'install install)))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'configure)
+ (delete 'install)
+ (replace 'build build)
+ (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 'cleanup 'create-symlinks symlink-asd-files)))
+
+(define* (asdf-build #:key inputs
+ (phases %standard-phases)
+ #:allow-other-keys
+ #:rest args)
+ (apply gnu:gnu-build
+ #:inputs inputs
+ #:phases phases
+ args))
+
+(define* (asdf-build/source #:key inputs
+ (phases %standard-phases/source)
+ #:allow-other-keys
+ #:rest args)
+ (apply gnu:gnu-build
+ #:inputs inputs
+ #:phases phases
+ args))
+
+;;; asdf-build-system.scm ends here
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
new file mode 100644
index 0000000000..55a07c7207
--- /dev/null
+++ b/guix/build/lisp-utils.scm
@@ -0,0 +1,327 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;;
+;;; 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 (guix build lisp-utils)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (guix build utils)
+ #:export (%lisp
+ %install-prefix
+ lisp-eval-program
+ compile-system
+ test-system
+ replace-escaped-macros
+ 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))
+
+;;; Commentary:
+;;;
+;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
+;;; systems for executables. Compile, test, and produce images for systems and
+;;; programs, and link them with their dependencies.
+;;;
+;;; Code:
+
+(define %lisp
+ ;; File name of the Lisp compiler.
+ (make-parameter "lisp"))
+
+(define %install-prefix "/share/common-lisp")
+
+(define (bundle-install-prefix lisp)
+ (string-append %install-prefix "/" lisp "-bundle-systems"))
+
+(define (remove-lisp-from-name name lisp)
+ (string-drop name (1+ (string-length lisp))))
+
+(define (wrap-output-translations translations)
+ `(:output-translations
+ ,@translations
+ :inherit-configuration))
+
+(define (lisp-eval-program lisp program)
+ "Evaluate PROGRAM with a given LISP implementation."
+ (unless (zero? (apply system*
+ (lisp-invoke lisp (format #f "~S" program))))
+ (error "lisp-eval-program failed!" lisp program)))
+
+(define (lisp-invoke lisp program)
+ "Return a list of arguments for system* determining how to invoke LISP
+with PROGRAM."
+ (match lisp
+ ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
+ ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
+
+(define (asdf-load-all systems)
+ (map (lambda (system)
+ `(funcall
+ (find-symbol
+ (symbol-name :load-system)
+ (symbol-name :asdf))
+ ,system))
+ systems))
+
+(define (compile-system system lisp asd-file)
+ "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE
+first if SYSTEM is defined there."
+ (lisp-eval-program lisp
+ `(progn
+ (require :asdf)
+ (in-package :asdf)
+ ,@(if asd-file
+ `((load ,asd-file))
+ '())
+ (in-package :cl-user)
+ (funcall (find-symbol
+ (symbol-name :operate)
+ (symbol-name :asdf))
+ (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 (test-system system lisp asd-file)
+ "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first
+if SYSTEM is defined there."
+ (lisp-eval-program lisp
+ `(progn
+ (require :asdf)
+ (in-package :asdf)
+ ,@(if asd-file
+ `((load ,asd-file))
+ '())
+ (in-package :cl-user)
+ (funcall (find-symbol
+ (symbol-name :test-system)
+ (symbol-name :asdf))
+ ,system))))
+
+(define (string->lisp-keyword . strings)
+ "Return a lisp keyword for the concatenation of STRINGS."
+ (string->symbol (apply string-append ":" strings)))
+
+(define (generate-executable-for-system type system lisp)
+ "Use LISP to generate an executable, whose TYPE can be \"image\" or
+\"program\". The latter will always be standalone. Depends on having created
+a \"SYSTEM-exec\" system which contains the entry program."
+ (lisp-eval-program
+ lisp
+ `(progn
+ (require :asdf)
+ (funcall (find-symbol
+ (symbol-name :operate)
+ (symbol-name :asdf))
+ (find-symbol
+ (symbol-name ,(string->lisp-keyword type "-op"))
+ (symbol-name :asdf))
+ ,(string-append system "-exec")))))
+
+(define (generate-executable-wrapper-system system dependencies)
+ "Generates a system which can be used by asdf to produce an image or program
+inside the current directory. The image or program will contain
+DEPENDENCIES."
+ (with-output-to-file (string-append system "-exec.asd")
+ (lambda _
+ (format #t "~y~%"
+ `(defsystem ,(string->lisp-keyword system "-exec")
+ :entry-point ,(string-append system "-exec:main")
+ :depends-on (:uiop
+ ,@(map string->lisp-keyword
+ dependencies))
+ :components ((:file ,(string-append system "-exec"))))))))
+
+(define (generate-executable-entry-point system entry-program)
+ "Generates an entry point program from the list of lisp statements
+ENTRY-PROGRAM for SYSTEM within the current directory."
+ (with-output-to-file (string-append system "-exec.lisp")
+ (lambda _
+ (let ((system (string->lisp-keyword system "-exec")))
+ (format #t "~{~y~%~%~}"
+ `((defpackage ,system
+ (:use :cl)
+ (:export :main))
+
+ (in-package ,system)
+
+ (defun main ()
+ (let ((arguments uiop:*command-line-arguments*))
+ (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 (bundle-asd-file output-path original-asd-file lisp)
+ "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
+OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two
+values: the asd file itself and the directory in which it resides."
+ (let ((bundle-asd-path (string-append output-path
+ (bundle-install-prefix lisp))))
+ (values (string-append bundle-asd-path "/" (basename original-asd-file))
+ bundle-asd-path)))
+
+(define (replace-escaped-macros string)
+ "Replace simple lisp forms that the guile writer escapes, for example by
+replacing #{#p}# with #p. Should only be used to replace truly simple forms
+which are not nested."
+ (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
+ 'pre 2 'post))
+
+(define (prepend-to-source-registry path)
+ (setenv "CL_SOURCE_REGISTRY"
+ (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
+
+(define* (build-program lisp program #:key inputs
+ (dependencies (list (basename program)))
+ entry-program
+ #:allow-other-keys)
+ "Generate an executable program containing all DEPENDENCIES, and which will
+execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it
+will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
+has been bound to the command-line arguments which were passed."
+ (generate-executable lisp program
+ #:inputs inputs
+ #:dependencies dependencies
+ #:entry-program entry-program
+ #:type "program")
+ (let* ((name (basename program))
+ (bin-directory (dirname program)))
+ (with-directory-excursion bin-directory
+ (rename-file (string-append name "-exec")
+ name)))
+ #t)
+
+(define* (build-image lisp image #:key inputs
+ (dependencies (list (basename image)))
+ #:allow-other-keys)
+ "Generate an image, possibly standalone, which contains all DEPENDENCIES,
+placing the result in IMAGE.image."
+ (generate-executable lisp image
+ #:inputs inputs
+ #:dependencies dependencies
+ #:entry-program '(nil)
+ #:type "image")
+ (let* ((name (basename image))
+ (bin-directory (dirname image)))
+ (with-directory-excursion bin-directory
+ (rename-file (string-append name "-exec--all-systems.image")
+ (string-append name ".image"))))
+ #t)
+
+(define* (generate-executable lisp out-file #:key inputs
+ dependencies
+ entry-program
+ type
+ #:allow-other-keys)
+ "Generate an executable by using asdf's TYPE-op, containing whithin the
+image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
+executable."
+ (let* ((bin-directory (dirname out-file))
+ (name (basename out-file)))
+ (mkdir-p bin-directory)
+ (with-directory-excursion bin-directory
+ (generate-executable-wrapper-system name dependencies)
+ (generate-executable-entry-point name entry-program))
+
+ (prepend-to-source-registry
+ (string-append bin-directory "/"))
+
+ (setenv "ASDF_OUTPUT_TRANSLATIONS"
+ (replace-escaped-macros
+ (format
+ #f "~S"
+ (wrap-output-translations
+ `(((,bin-directory :**/ :*.*.*)
+ (,bin-directory :**/ :*.*.*)))))))
+
+ (parameterize ((%lisp (string-append
+ (assoc-ref inputs lisp) "/bin/" lisp)))
+ (generate-executable-for-system type name lisp))
+
+ (delete-file (string-append bin-directory "/" name "-exec.asd"))
+ (delete-file (string-append bin-directory "/" name "-exec.lisp"))))