guix-devel/guix/build/compile.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@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 (guix build compile)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (system base target)
  #:use-module (system base compile)
  #:use-module (system base message)
  #:use-module (guix modules)
  #:use-module (guix build utils)
  #:use-module (language tree-il optimize)
  #:use-module (language cps optimize)
  #:export (%default-optimizations
            %lightweight-optimizations
            compile-files))

;;; Commentary:
;;;
;;; Support code to compile Guile code as efficiently as possible (with 2.2).
;;;
;;; Code:

(define %default-optimizations
  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
  (append (if (defined? 'tree-il-default-optimization-options)
              (tree-il-default-optimization-options) ;Guile 2.2
              (tree-il-optimizations))               ;Guile 3
          (if (defined? 'cps-default-optimization-options)
              (cps-default-optimization-options)  ;Guile 2.2
              (cps-optimizations))))              ;Guile 3

(define %lightweight-optimizations
  ;; Lightweight optimizations (like -O0, but with partial evaluation).
  (let loop ((opts %default-optimizations)
             (result '()))
    (match opts
      (() (reverse result))
      ((#:partial-eval? _ rest ...)
       (loop rest `(#t #:partial-eval? ,@result)))
      ((kw _ rest ...)
       (loop rest `(#f ,kw ,@result))))))

(define %warnings
  ;; FIXME: 'format' is missing because it reports "non-literal format
  ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
  ;; help from Guile to solve this.
  '(unsupported-warning unbound-variable arity-mismatch
    macro-use-before-definition                   ;new in 2.2
    shadowed-toplevel))                           ;new in 2.2.5

(define (optimization-options file)
  "Return the default set of optimizations options for FILE."
  (if (string-contains file "gnu/packages/")
      %lightweight-optimizations                  ;build faster
      '()))

(define (scm->go file)
  "Strip the \".scm\" suffix from FILE, and append \".go\"."
  (string-append (string-drop-right file 4) ".go"))

(define (relative-file directory file)
  "Return FILE relative to DIRECTORY, if possible."
  (if (string-prefix? (string-append directory "/") file)
      (string-drop file (+ 1 (string-length directory)))
      file))

(define* (load-files directory files
                     #:key
                     (report-load (const #f))
                     (debug-port (%make-void-port "w")))
  "Load FILES, a list of relative file names, from DIRECTORY."
  (define total
    (length files))

  (let loop ((files files)
             (completed 0))
    (match files
      (()
       (unless (zero? total)
         (report-load #f total completed))
       *unspecified*)
      ((file files ...)
       (let ((file (relative-file directory file)))
         (report-load file total completed)
         (format debug-port "~%loading '~a'...~%" file)

         (resolve-interface (file-name->module-name file))

         (loop files (+ 1 completed)))))))

(define-syntax-rule (with-augmented-search-path path item body ...)
  "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
front."
  (let ((initial-value path))
    (dynamic-wind
      (lambda ()
        (set! path (cons item path)))
      (lambda ()
        body ...)
      (lambda ()
        (set! path initial-value)))))

(define (call/exit-on-exception thunk)
  "Evaluate THUNK and exit right away if an exception is thrown."
  (catch #t
    thunk
    (const #f)
    (lambda (key . args)
      (false-if-exception
       ;; Duplicate stderr to avoid thread-safety issues.
       (let* ((port  (duplicate-port (current-error-port) "w0"))
              (stack (make-stack #t))
              (depth (stack-length stack))
              (frame (and (> depth 1) (stack-ref stack 1))))
         (false-if-exception (display-backtrace stack port))
         (print-exception port frame key args)))

      ;; Don't go any further.
      (primitive-exit 1))))

(define-syntax-rule (exit-on-exception exp ...)
  "Evaluate EXP and exit if an exception is thrown."
  (call/exit-on-exception (lambda () exp ...)))

(define* (compile-files source-directory build-directory files
                        #:key
                        (host %host-type)
                        (workers (current-processor-count))
                        (optimization-options optimization-options)
                        (warning-options `(#:warnings ,%warnings))
                        (report-load (const #f))
                        (report-compilation (const #f))
                        (debug-port (%make-void-port "w")))
  "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to
BUILD-DIRECTORY, using up to WORKERS parallel workers.  The resulting object
files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
  (define progress-lock (make-mutex))
  (define total (length files))
  (define completed 0)

  (define (build file)
    (with-mutex progress-lock
      (report-compilation file total completed))

    ;; Exit as soon as something goes wrong.
    (exit-on-exception
     (with-target host
       (lambda ()
         (let ((relative (relative-file source-directory file)))
           (compile-file file
                         #:output-file (string-append build-directory "/"
                                                      (scm->go relative))
                         #:opts (append warning-options
                                        (optimization-options relative)))))))
    (with-mutex progress-lock
      (set! completed (+ 1 completed))))

  (with-augmented-search-path %load-path source-directory
    (with-augmented-search-path %load-compiled-path build-directory
      (with-fluids ((*current-warning-prefix* ""))

        ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
        ;; of FILES.
        (load-files source-directory files
                    #:report-load report-load
                    #:debug-port debug-port)

        ;; Make sure compilation related modules are loaded before starting to
        ;; compile files in parallel.
        (compile #f)

        ;; XXX: Don't use too many workers to work around the insane memory
        ;; requirements of the compiler in Guile 2.2.2:
        ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
        (n-par-for-each (min workers 8) build files)

        (unless (zero? total)
          (report-compilation #f total total))))))

(eval-when (eval load)
  (when (and (string=? "2" (major-version))
             (or (string=? "0" (minor-version))
                 (and (string=? (minor-version) "2")
                      (< (string->number (micro-version)) 4))))
    ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4.
    ;; Serialize 'try-module-autoload' calls.
    (set! (@ (guile) try-module-autoload)
      (let ((mutex (make-mutex 'recursive))
            (real  (@ (guile) try-module-autoload)))
        (lambda* (module #:optional version)
          (with-mutex mutex
            (real module version)))))))

;;; Local Variables:
;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
;;; eval: (put 'with-target 'scheme-indent-function 1)
;;; End: