You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

136 lines
5.5 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
  3. ;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (use-modules (ice-9 format)
  20. (ice-9 match)
  21. (ice-9 threads)
  22. (srfi srfi-1)
  23. (guix build compile)
  24. (guix build utils))
  25. (define host (getenv "host"))
  26. (define srcdir (getenv "srcdir"))
  27. (define (relative-file file)
  28. (if (string-prefix? (string-append srcdir "/") file)
  29. (string-drop file (+ 1 (string-length srcdir)))
  30. file))
  31. (define (file-mtime<? f1 f2)
  32. (< (stat:mtime (stat f1))
  33. (stat:mtime (stat f2))))
  34. (define (scm->go file)
  35. (let* ((relative (relative-file file))
  36. (without-extension (string-drop-right relative 4)))
  37. (string-append without-extension ".go")))
  38. (define (file-needs-compilation? file)
  39. (let ((go (scm->go file)))
  40. (or (not (file-exists? go))
  41. (file-mtime<? go file))))
  42. (define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS")))
  43. "Return the number of parallel jobs as determined by FLAGS, the flags passed
  44. to 'make'."
  45. (match flags
  46. (#f (current-processor-count))
  47. (flags
  48. (let ((initial-flags (string-tokenize flags)))
  49. (let loop ((flags initial-flags))
  50. (match flags
  51. (()
  52. ;; Note: GNU make prior to version 4.2 would hide "-j" flags from
  53. ;; $MAKEFLAGS. Thus, check for a "--jobserver" flag here and
  54. ;; assume we're using all cores if specified.
  55. (if (any (lambda (flag)
  56. (string-prefix? "--jobserver" flag))
  57. initial-flags)
  58. (current-processor-count) ;GNU make < 4.2
  59. 1)) ;sequential make
  60. (("-j" (= string->number count) _ ...)
  61. (if (integer? count)
  62. count
  63. (current-processor-count)))
  64. ((head tail ...)
  65. (if (string-prefix? "-j" head)
  66. (match (string-drop head 2)
  67. (""
  68. (current-processor-count))
  69. ((= string->number count)
  70. (if (integer? count)
  71. count
  72. (current-processor-count))))
  73. (loop tail)))))))))
  74. (define (% completed total)
  75. "Return the completion percentage of COMPLETED over TOTAL as an integer."
  76. (inexact->exact (round (* 100. (/ completed total)))))
  77. ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
  78. ;; opportunity to run upon SIGINT and to remove temporary output files.
  79. (sigaction SIGINT
  80. (lambda args
  81. (exit 1)))
  82. (match (command-line)
  83. ((_ . files)
  84. (catch #t
  85. (lambda ()
  86. (compile-files srcdir (getcwd)
  87. (filter file-needs-compilation? files)
  88. #:workers (parallel-job-count)
  89. #:host host
  90. #:report-load (lambda (file total completed)
  91. (when file
  92. (format #t "[~3d%] LOAD ~a~%"
  93. (% (+ 1 completed) (* 2 total))
  94. file)
  95. (force-output)))
  96. #:report-compilation (lambda (file total completed)
  97. (when file
  98. (format #t "[~3d%] GUILEC ~a~%"
  99. (% (+ total completed 1)
  100. (* 2 total))
  101. (scm->go file))
  102. (force-output)))))
  103. (lambda _
  104. (primitive-exit 1))
  105. (lambda args
  106. ;; Try to report the error in an intelligible way.
  107. (let* ((stack (make-stack #t))
  108. (frame (if (> (stack-length stack) 1)
  109. (stack-ref stack 1) ;skip the 'throw' frame
  110. (stack-ref stack 0)))
  111. (ui (false-if-exception
  112. (resolve-module '(guix ui))))
  113. (report (and ui
  114. (false-if-exception
  115. (module-ref ui 'report-load-error)))))
  116. (if report
  117. ;; In Guile <= 2.2.5, 'current-load-port' was not exported.
  118. (let ((load-port ((module-ref (resolve-module '(ice-9 ports))
  119. 'current-load-port))))
  120. (report (or (and=> load-port port-filename) "?.scm")
  121. args frame))
  122. (begin
  123. (print-exception (current-error-port) frame
  124. (car args) (cdr args))
  125. (display-backtrace stack (current-error-port)))))))))