transformations.scm 46 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
  4. ;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com>
  5. ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
  6. ;;;
  7. ;;; This file is part of GNU Guix.
  8. ;;;
  9. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10. ;;; under the terms of the GNU General Public License as published by
  11. ;;; the Free Software Foundation; either version 3 of the License, or (at
  12. ;;; your option) any later version.
  13. ;;;
  14. ;;; GNU Guix is distributed in the hope that it will be useful, but
  15. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17. ;;; GNU General Public License for more details.
  18. ;;;
  19. ;;; You should have received a copy of the GNU General Public License
  20. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  21. (define-module (guix transformations)
  22. #:use-module ((guix config) #:select (%system))
  23. #:use-module (guix i18n)
  24. #:use-module (guix store)
  25. #:use-module (guix packages)
  26. #:use-module (guix build-system)
  27. #:use-module (guix profiles)
  28. #:use-module (guix diagnostics)
  29. #:autoload (guix download) (download-to-store)
  30. #:autoload (guix git-download) (git-reference? git-reference-url)
  31. #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
  32. #:autoload (guix upstream) (package-latest-release
  33. upstream-source-version
  34. upstream-source-signature-urls)
  35. #:autoload (guix cpu) (current-cpu
  36. cpu->gcc-architecture
  37. gcc-architecture->micro-architecture-level)
  38. #:autoload (guix parameters) (package-parameter-alist parameterize-package)
  39. #:use-module (guix utils)
  40. #:use-module (guix memoization)
  41. #:use-module (guix gexp)
  42. ;; Use the procedure that destructures "NAME-VERSION" forms.
  43. #:use-module ((guix build utils)
  44. #:select ((package-name->name+version
  45. . hyphen-package-name->name+version)))
  46. #:use-module (srfi srfi-1)
  47. #:use-module (srfi srfi-9)
  48. #:use-module (srfi srfi-26)
  49. #:use-module (srfi srfi-34)
  50. #:use-module (srfi srfi-35)
  51. #:use-module (srfi srfi-37)
  52. #:use-module (srfi srfi-71)
  53. #:use-module (ice-9 match)
  54. #:use-module (ice-9 vlist)
  55. #:export (options->transformation
  56. manifest-entry-with-transformations
  57. tunable-package?
  58. tuned-package
  59. show-transformation-options-help
  60. transformation-option-key?
  61. %transformation-options))
  62. ;;; Commentary:
  63. ;;;
  64. ;;; This module implements "package transformation options"---tools for
  65. ;;; package graph rewriting. It contains the graph rewriting logic, but also
  66. ;;; the tip of its user interface: command-line option handling.
  67. ;;;
  68. ;;; Code:
  69. (module-autoload! (current-module) '(gnu packages)
  70. '(specification->package))
  71. (define (numeric-extension? file-name)
  72. "Return true if FILE-NAME ends with digits."
  73. (string-every char-set:hex-digit (file-extension file-name)))
  74. (define (tarball-base-name file-name)
  75. "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
  76. extensions."
  77. ;; TODO: Factorize.
  78. (cond ((not (file-extension file-name))
  79. file-name)
  80. ((numeric-extension? file-name)
  81. file-name)
  82. ((string=? (file-extension file-name) "tar")
  83. (file-sans-extension file-name))
  84. ((file-extension file-name)
  85. =>
  86. (match-lambda
  87. ("scm" file-name)
  88. (_ (tarball-base-name (file-sans-extension file-name)))))
  89. (else
  90. file-name)))
  91. ;; Files to be downloaded.
  92. (define-record-type <downloaded-file>
  93. (downloaded-file uri recursive?)
  94. downloaded-file?
  95. (uri downloaded-file-uri)
  96. (recursive? downloaded-file-recursive?))
  97. (define download-to-store*
  98. (store-lift download-to-store))
  99. (define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
  100. system target)
  101. "Download FILE and return the result as a store item."
  102. (match file
  103. (($ <downloaded-file> uri recursive?)
  104. (download-to-store* uri #:recursive? recursive?))))
  105. (define* (package-with-source p uri #:optional version)
  106. "Return a package based on P but with its source taken from URI. Extract
  107. the new package's version number from URI."
  108. (let ((base (tarball-base-name (basename uri))))
  109. (let ((_ version* (hyphen-package-name->name+version base)))
  110. (package (inherit p)
  111. (version (or version version*
  112. (package-version p)))
  113. ;; Use #:recursive? #t to allow for directories.
  114. (source (downloaded-file uri #t))))))
  115. ;;;
  116. ;;; Transformations.
  117. ;;;
  118. (define (evaluate-source-replacement-specs specs)
  119. "Parse SPECS, a list of strings like \"guile=/tmp/guile-4.2.tar.gz\" or just
  120. \"/tmp/guile-4.2.tar.gz\" and return a list of package spec/procedure pairs as
  121. expected by 'package-input-rewriting/spec'. Raise an error if an element of
  122. SPECS uses invalid syntax."
  123. (define not-equal
  124. (char-set-complement (char-set #\=)))
  125. (map (lambda (spec)
  126. (match (string-tokenize spec not-equal)
  127. ((uri)
  128. (let* ((base (tarball-base-name (basename uri)))
  129. (name (hyphen-package-name->name+version base)))
  130. (cons name
  131. (lambda (old)
  132. (package-with-source old uri)))))
  133. ((spec uri)
  134. (let ((name version (package-name->name+version spec)))
  135. ;; Note: Here VERSION is used as the version string of the new
  136. ;; package rather than as part of the spec of the package being
  137. ;; targeted.
  138. (cons name
  139. (lambda (old)
  140. (package-with-source old uri version)))))
  141. (_
  142. (raise (formatted-message
  143. (G_ "invalid source replacement specification: ~s")
  144. spec)))))
  145. specs))
  146. (define (transform-package-source replacement-specs)
  147. "Return a transformation procedure that replaces package sources with the
  148. matching URIs given in REPLACEMENT-SPECS."
  149. (let* ((replacements (evaluate-source-replacement-specs replacement-specs))
  150. (rewrite (package-input-rewriting/spec replacements)))
  151. (lambda (obj)
  152. (if (package? obj)
  153. (rewrite obj)
  154. obj))))
  155. (define (evaluate-replacement-specs specs proc)
  156. "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
  157. of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
  158. PROC is called with the package to be replaced and its replacement according
  159. to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
  160. package it refers to could not be found."
  161. (define not-equal
  162. (char-set-complement (char-set #\=)))
  163. (map (lambda (spec)
  164. (match (string-tokenize spec not-equal)
  165. ((spec new)
  166. (cons spec
  167. (let ((new (specification->package new)))
  168. (lambda (old)
  169. (proc old new)))))
  170. (x
  171. (raise (formatted-message
  172. (G_ "invalid replacement specification: ~s")
  173. spec)))))
  174. specs))
  175. (define (transform-package-inputs replacement-specs)
  176. "Return a procedure that, when passed a package, replaces its direct
  177. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  178. strings like \"guile=guile@2.1\" meaning that, any dependency on a package
  179. called \"guile\" must be replaced with a dependency on a version 2.1 of
  180. \"guile\"."
  181. (let* ((replacements (evaluate-replacement-specs replacement-specs
  182. (lambda (old new)
  183. new)))
  184. (rewrite (package-input-rewriting/spec replacements)))
  185. (lambda (obj)
  186. (if (package? obj)
  187. (rewrite obj)
  188. obj))))
  189. (define (transform-package-inputs/graft replacement-specs)
  190. "Return a procedure that, when passed a package, replaces its direct
  191. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  192. strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
  193. current 'gnutls' package, after which version 3.5.4 is grafted onto them."
  194. (define (set-replacement old new)
  195. (package (inherit old) (replacement new)))
  196. (let* ((replacements (evaluate-replacement-specs replacement-specs
  197. set-replacement))
  198. (rewrite (package-input-rewriting/spec replacements)))
  199. (lambda (obj)
  200. (if (package? obj)
  201. (rewrite obj)
  202. obj))))
  203. (define %not-equal
  204. (char-set-complement (char-set #\=)))
  205. (define (package-git-url package)
  206. "Return the URL of the Git repository for package, or raise an error if
  207. the source of PACKAGE is not fetched from a Git repository."
  208. (let ((source (package-source package)))
  209. (cond ((and (origin? source)
  210. (git-reference? (origin-uri source)))
  211. (git-reference-url (origin-uri source)))
  212. ((git-checkout? source)
  213. (git-checkout-url source))
  214. (else
  215. (raise
  216. (formatted-message (G_ "the source of ~a is not a Git reference")
  217. (package-full-name package)))))))
  218. (define (evaluate-git-replacement-specs specs proc)
  219. "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
  220. of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
  221. replacement package. Raise an error if an element of SPECS uses invalid
  222. syntax, or if a package it refers to could not be found."
  223. (map (lambda (spec)
  224. (match (string-tokenize spec %not-equal)
  225. ((spec branch-or-commit)
  226. (define (replace old)
  227. (let* ((source (package-source old))
  228. (url (package-git-url old)))
  229. (proc old url branch-or-commit)))
  230. (cons spec replace))
  231. (_
  232. (raise
  233. (formatted-message (G_ "invalid replacement specification: ~s")
  234. spec)))))
  235. specs))
  236. (define (transform-package-source-branch replacement-specs)
  237. "Return a procedure that, when passed a package, replaces its direct
  238. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  239. strings like \"guile-next=stable-3.0\" meaning that packages are built using
  240. 'guile-next' from the latest commit on its 'stable-3.0' branch."
  241. (define (replace old url branch)
  242. (package
  243. (inherit old)
  244. (version (string-append "git." (string-map (match-lambda
  245. (#\/ #\-)
  246. (chr chr))
  247. branch)))
  248. (source (git-checkout (url url) (branch branch)
  249. (recursive? #t)))))
  250. (let* ((replacements (evaluate-git-replacement-specs replacement-specs
  251. replace))
  252. (rewrite (package-input-rewriting/spec replacements)))
  253. (lambda (obj)
  254. (if (package? obj)
  255. (rewrite obj)
  256. obj))))
  257. (define (commit->version-string commit)
  258. "Return a string suitable for use in the 'version' field of a package based
  259. on the given COMMIT."
  260. (cond ((and (> (string-length commit) 1)
  261. (string-prefix? "v" commit)
  262. (char-set-contains? char-set:digit
  263. (string-ref commit 1)))
  264. ;; Probably a tag like "v1.0" or a 'git describe' identifier.
  265. (string-drop commit 1))
  266. ((not (string-every char-set:hex-digit commit))
  267. ;; Pass through tags and 'git describe' style IDs directly.
  268. commit)
  269. (else
  270. (string-append "git."
  271. (if (< (string-length commit) 7)
  272. commit
  273. (string-take commit 7))))))
  274. (define (transform-package-source-commit replacement-specs)
  275. "Return a procedure that, when passed a package, replaces its direct
  276. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  277. strings like \"guile-next=cabba9e\" meaning that packages are built using
  278. 'guile-next' from commit 'cabba9e'."
  279. (define (replace old url commit)
  280. (package
  281. (inherit old)
  282. (version (commit->version-string commit))
  283. (source (git-checkout (url url) (commit commit)
  284. (recursive? #t)))))
  285. (let* ((replacements (evaluate-git-replacement-specs replacement-specs
  286. replace))
  287. (rewrite (package-input-rewriting/spec replacements)))
  288. (lambda (obj)
  289. (if (package? obj)
  290. (rewrite obj)
  291. obj))))
  292. (define (transform-package-source-git-url replacement-specs)
  293. "Return a procedure that, when passed a package, replaces its dependencies
  294. according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
  295. \"guile-json=https://gitthing.com/…\" meaning that packages are built using
  296. a checkout of the Git repository at the given URL."
  297. (define replacements
  298. (map (lambda (spec)
  299. (match (string-tokenize spec %not-equal)
  300. ((spec url)
  301. (cons spec
  302. (lambda (old)
  303. (package
  304. (inherit old)
  305. (source (git-checkout (url url)
  306. (recursive? #t)))))))
  307. (_
  308. (raise
  309. (formatted-message
  310. (G_ "~a: invalid Git URL replacement specification")
  311. spec)))))
  312. replacement-specs))
  313. (define rewrite
  314. (package-input-rewriting/spec replacements))
  315. (lambda (obj)
  316. (if (package? obj)
  317. (rewrite obj)
  318. obj)))
  319. (define (evaluate-parameter-specs specs)
  320. "Parse SPECS, a list of strings like \"bitlbee=purple=true\", and return a
  321. list of spec/procedure pairs, where (PROC PACKAGE PARAMETER VALUE) is called
  322. to return the replacement package. Raise an error if an element of SPECS uses
  323. invalid syntax, or if a package it refers to could not be found."
  324. (let [(package-assq '())]
  325. (map (lambda (spec)
  326. (match (string-tokenize spec %not-equal)
  327. ((pkg name value)
  328. (set! package-assq
  329. (assq-set! package-assq pkg
  330. (cons (cons (string->symbol name)
  331. (string->symbol value))
  332. (or (assq-ref package-assq pkg)
  333. '())))))
  334. (_
  335. (raise
  336. (formatted-message
  337. (G_ "invalid package parameter specification: ~s")
  338. spec)))))
  339. specs)
  340. (map (lambda (x) ; (<pkg> <plist>)
  341. (let ((package-name (car x))
  342. (parameter-lst (cdr x)))
  343. (cons package-name
  344. (lambda (x)
  345. (let* [(original-lst (map (lambda (x)
  346. (cons (car x) (cdr x)))
  347. (package-parameter-alist x)))
  348. (final-lst
  349. (fold (lambda (z y)
  350. (assq-set! y
  351. (car z)
  352. (cdr z)))
  353. original-lst
  354. parameter-lst))]
  355. (parameterize-package x final-lst))))))
  356. package-assq)))
  357. (define (transform-package-parameters replacement-specs)
  358. "Return a procedure that, when passed a package, replaces its direct
  359. dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
  360. strings like \"guile-next=stable-3.0\" meaning that packages are built using
  361. 'guile-next' from the latest commit on its 'stable-3.0' branch."
  362. ;; we'll apply per-package parameterization and then return
  363. (let* ((replacements (evaluate-parameter-specs replacement-specs))
  364. (rewrite (package-input-rewriting/spec replacements)))
  365. (lambda (obj)
  366. (if (package? obj)
  367. (rewrite obj)
  368. obj))))
  369. (define (package-dependents/spec top bottom)
  370. "Return the list of dependents of BOTTOM, a spec string, that are also
  371. dependencies of TOP, a package."
  372. (define-values (name version)
  373. (package-name->name+version bottom))
  374. (define dependent?
  375. (mlambda (p)
  376. (and (package? p)
  377. (or (and (string=? name (package-name p))
  378. (or (not version)
  379. (version-prefix? version (package-version p))))
  380. (match (bag-direct-inputs (package->bag p))
  381. (((labels dependencies . _) ...)
  382. (any dependent? dependencies)))))))
  383. (filter dependent? (package-closure (list top))))
  384. (define (package-toolchain-rewriting p bottom toolchain)
  385. "Return a procedure that, when passed a package that's either BOTTOM or one
  386. of its dependents up to P so, changes it so it is built with TOOLCHAIN.
  387. TOOLCHAIN must be an input list."
  388. (define rewriting-property
  389. (gensym " package-toolchain-rewriting"))
  390. (match (package-dependents/spec p bottom)
  391. (() ;P does not depend on BOTTOM
  392. identity)
  393. (set
  394. ;; SET is the list of packages "between" P and BOTTOM (included) whose
  395. ;; toolchain needs to be changed.
  396. (package-mapping (lambda (p)
  397. (if (or (assq rewriting-property
  398. (package-properties p))
  399. (not (memq p set)))
  400. p
  401. (let ((p (package-with-c-toolchain p toolchain)))
  402. (package/inherit p
  403. (properties `((,rewriting-property . #t)
  404. ,@(package-properties p)))))))
  405. (lambda (p)
  406. (or (assq rewriting-property (package-properties p))
  407. (not (memq p set))))
  408. #:deep? #t))))
  409. (define (transform-package-toolchain replacement-specs)
  410. "Return a procedure that, when passed a package, changes its toolchain or
  411. that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
  412. a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
  413. the left of the equal sign must be built with the toolchain to the right of
  414. the equal sign."
  415. (define split-on-commas
  416. (cute string-tokenize <> (char-set-complement (char-set #\,))))
  417. (define (specification->input spec)
  418. (let ((package (specification->package spec)))
  419. (list (package-name package) package)))
  420. (define replacements
  421. (map (lambda (spec)
  422. (match (string-tokenize spec %not-equal)
  423. ((spec (= split-on-commas toolchain))
  424. (cons spec (map specification->input toolchain)))
  425. (_
  426. (raise
  427. (formatted-message
  428. (G_ "~a: invalid toolchain replacement specification")
  429. spec)))))
  430. replacement-specs))
  431. (lambda (obj)
  432. (if (package? obj)
  433. (or (any (match-lambda
  434. ((bottom . toolchain)
  435. ((package-toolchain-rewriting obj bottom toolchain) obj)))
  436. replacements)
  437. obj)
  438. obj)))
  439. (define tuning-compiler
  440. (mlambda (micro-architecture)
  441. "Return a compiler wrapper that passes '-march=MICRO-ARCHITECTURE' to the
  442. actual compiler."
  443. (define wrapper
  444. #~(begin
  445. (use-modules (ice-9 match))
  446. (define psabi #$(gcc-architecture->micro-architecture-level
  447. micro-architecture))
  448. (define* (search-next command
  449. #:optional
  450. (path (string-split (getenv "PATH")
  451. #\:)))
  452. ;; Search the next COMMAND on PATH, a list of
  453. ;; directories representing the executable search path.
  454. (define this
  455. (stat (car (command-line))))
  456. (let loop ((path path))
  457. (match path
  458. (()
  459. (match command
  460. ("cc" (search-next "gcc"))
  461. (_ #f)))
  462. ((directory rest ...)
  463. (let* ((file (string-append
  464. directory "/" command))
  465. (st (stat file #f)))
  466. (if (and st (not (equal? this st)))
  467. file
  468. (loop rest)))))))
  469. (match (command-line)
  470. ((command arguments ...)
  471. (match (search-next (basename command))
  472. (#f (exit 127))
  473. (next
  474. (if (and (search-next "go")
  475. (string=? next (search-next "go")))
  476. (cond
  477. ((string-prefix? "arm" psabi)
  478. (setenv "GOARM" (string-take-right psabi 1)))
  479. ((string-prefix? "powerpc" psabi)
  480. (setenv "GOPPC64" psabi))
  481. ((string-prefix? "x86_64" psabi)
  482. (setenv "GOAMD" (string-take-right psabi 2)))
  483. (else #t))
  484. '())
  485. (apply
  486. execl next
  487. (append (cons next arguments)
  488. (if (and (search-next "go")
  489. (string=? next (search-next "go")))
  490. '()
  491. (list (string-append "-march="
  492. #$micro-architecture)))))))))))
  493. (define program
  494. (program-file (string-append "tuning-compiler-wrapper-" micro-architecture)
  495. wrapper))
  496. (computed-file (string-append "tuning-compiler-" micro-architecture)
  497. (with-imported-modules '((guix build utils))
  498. #~(begin
  499. (use-modules (guix build utils))
  500. (define bin (string-append #$output "/bin"))
  501. (mkdir-p bin)
  502. (for-each (lambda (program)
  503. (symlink #$program
  504. (string-append bin "/" program)))
  505. '("cc" "gcc" "clang" "g++" "c++" "clang++"
  506. "go")))))))
  507. (define (build-system-with-tuning-compiler bs micro-architecture)
  508. "Return a variant of BS, a build system, that ensures that the compiler that
  509. BS uses (usually an implicit input) can generate code for MICRO-ARCHITECTURE,
  510. which names a specific CPU of the target architecture--e.g., when targeting
  511. 86_64 MICRO-ARCHITECTURE might be \"skylake\". If it does, return a build
  512. system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
  513. (define %not-hyphen
  514. (char-set-complement (char-set #\-)))
  515. (define lower
  516. (build-system-lower bs))
  517. (define (lower* . args)
  518. ;; The list of CPU names supported by the '-march' option of C/C++
  519. ;; compilers is specific to each compiler and version thereof. Rather
  520. ;; than pass '-march=MICRO-ARCHITECTURE' as is to the compiler, possibly
  521. ;; leading to an obscure build error, check whether the compiler is known
  522. ;; to support MICRO-ARCHITECTURE. If not, bail out.
  523. (let* ((lowered (apply lower args))
  524. (target (or (bag-target lowered)
  525. (bag-system lowered)))
  526. (architecture (match (string-tokenize target %not-hyphen)
  527. ((arch _ ...) arch)))
  528. (compiler (any (match-lambda
  529. ((label (? package? p) . _)
  530. (and (assoc-ref (package-properties p)
  531. 'compiler-cpu-architectures)
  532. p))
  533. (_ #f))
  534. (bag-build-inputs lowered)))
  535. (psabi (gcc-architecture->micro-architecture-level
  536. micro-architecture)))
  537. (unless compiler
  538. (raise (formatted-message
  539. (G_ "failed to determine which compiler is used"))))
  540. (let ((lst (assoc-ref (package-properties compiler)
  541. 'compiler-cpu-architectures)))
  542. (unless lst
  543. (raise (formatted-message
  544. (G_ "failed to determine whether ~a supports ~a")
  545. (package-full-name compiler)
  546. micro-architecture)))
  547. (unless (or (member micro-architecture
  548. (or (assoc-ref lst architecture) '()))
  549. (and (string=? (package-name compiler) "go")
  550. (member psabi
  551. (or (assoc-ref lst architecture) '()))))
  552. (raise
  553. (make-compound-condition
  554. (formatted-message
  555. (G_ "compiler ~a does not support micro-architecture ~a")
  556. (package-full-name compiler)
  557. micro-architecture)
  558. (condition
  559. (&fix-hint
  560. (hint (match (assoc-ref lst architecture)
  561. (#f (format #f (G_ "Compiler ~a does not support
  562. micro-architectures of ~a.")
  563. (package-full-name compiler "@@")
  564. architecture))
  565. (lst
  566. (format #f (G_ "Compiler ~a supports the following ~a
  567. micro-architectures:
  568. @quotation
  569. ~a
  570. @end quotation")
  571. (package-full-name compiler "@@")
  572. architecture
  573. (string-join lst ", ")))))))))))
  574. (bag
  575. (inherit lowered)
  576. (build-inputs
  577. ;; Arrange so that the compiler wrapper comes first in $PATH.
  578. `(("tuning-compiler" ,(tuning-compiler micro-architecture))
  579. ,@(bag-build-inputs lowered))))))
  580. (build-system
  581. (inherit bs)
  582. (lower lower*)))
  583. (define (tuned-package p micro-architecture)
  584. "Return package P tuned for MICRO-ARCHITECTURE."
  585. (package
  586. (inherit p)
  587. (build-system
  588. (build-system-with-tuning-compiler (package-build-system p)
  589. micro-architecture))
  590. (arguments
  591. ;; The machine building this package may or may not be able to run code
  592. ;; for MICRO-ARCHITECTURE. Because of that, skip tests; they are run for
  593. ;; the "baseline" variant anyway.
  594. (substitute-keyword-arguments (package-arguments p)
  595. ((#:tests? _ #f) #f)))
  596. (properties
  597. `((cpu-tuning . ,micro-architecture)
  598. ;; Remove the 'tunable?' property so that 'package-tuning' does not
  599. ;; call 'tuned-package' again on this one.
  600. ,@(alist-delete 'tunable? (package-properties p))))))
  601. (define (tunable-package? package)
  602. "Return true if package PACKAGE is \"tunable\"--i.e., if tuning it for the
  603. host CPU is worthwhile."
  604. (assq 'tunable? (package-properties package)))
  605. (define package-tuning
  606. (mlambda (micro-architecture)
  607. "Return a procedure that maps the given package to its counterpart tuned
  608. for MICRO-ARCHITECTURE, a string suitable for GCC's '-march'."
  609. (define rewriting-property
  610. (gensym " package-tuning"))
  611. (package-mapping (lambda (p)
  612. (cond ((assq rewriting-property (package-properties p))
  613. p)
  614. ((assq 'tunable? (package-properties p))
  615. (info (G_ "tuning ~a for CPU ~a~%")
  616. (package-full-name p) micro-architecture)
  617. (package/inherit p
  618. (replacement (tuned-package p micro-architecture))
  619. (properties `((,rewriting-property . #t)
  620. ,@(package-properties p)))))
  621. (else
  622. p)))
  623. (lambda (p)
  624. (assq rewriting-property (package-properties p)))
  625. #:deep? #t)))
  626. (define (transform-package-tuning micro-architectures)
  627. "Return a procedure that, when "
  628. (match micro-architectures
  629. ((micro-architecture _ ...)
  630. (let ((rewrite (package-tuning micro-architecture)))
  631. (lambda (obj)
  632. (if (package? obj)
  633. (rewrite obj)
  634. obj))))))
  635. (define (transform-package-with-debug-info specs)
  636. "Return a procedure that, when passed a package, set its 'replacement' field
  637. to the same package but with #:strip-binaries? #f in its 'arguments' field."
  638. (define (non-stripped p)
  639. (package
  640. (inherit p)
  641. (arguments
  642. (substitute-keyword-arguments (package-arguments p)
  643. ((#:strip-binaries? _ #f) #f)))))
  644. (define (package-with-debug-info p)
  645. (if (member "debug" (package-outputs p))
  646. p
  647. (let loop ((p p))
  648. (match (package-replacement p)
  649. (#f
  650. (package
  651. (inherit p)
  652. (replacement (non-stripped p))))
  653. (next
  654. (package
  655. (inherit p)
  656. (replacement (loop next))))))))
  657. (define rewrite
  658. (package-input-rewriting/spec (map (lambda (spec)
  659. (cons spec package-with-debug-info))
  660. specs)))
  661. (lambda (obj)
  662. (if (package? obj)
  663. (rewrite obj)
  664. obj)))
  665. (define (transform-package-tests specs)
  666. "Return a procedure that, when passed a package, sets #:tests? #f in its
  667. 'arguments' field."
  668. (define (package-without-tests p)
  669. (package/inherit p
  670. (arguments
  671. (substitute-keyword-arguments (package-arguments p)
  672. ((#:tests? _ #f) #f)))))
  673. (define rewrite
  674. (package-input-rewriting/spec (map (lambda (spec)
  675. (cons spec package-without-tests))
  676. specs)))
  677. (lambda (obj)
  678. (if (package? obj)
  679. (rewrite obj)
  680. obj)))
  681. (define (transform-package-configure-flag specs)
  682. "Return a procedure that, when passed a package and a flag, adds the flag to
  683. #:configure-flags in the package's 'arguments' field."
  684. (define (package-with-configure-flag p extra-flag)
  685. (package/inherit p
  686. (arguments
  687. (substitute-keyword-arguments (package-arguments p)
  688. ((#:configure-flags flags #~'())
  689. ;; Add EXTRA-FLAG to the end so it can potentially override FLAGS.
  690. #~(append #$flags '(#$extra-flag)))))))
  691. (define configure-flags
  692. ;; Spec/flag alist.
  693. (map (lambda (spec)
  694. ;; Split SPEC on the first equal sign (the configure flag might
  695. ;; contain equal signs, as in '-DINTSIZE=32').
  696. (let ((equal (string-index spec #\=)))
  697. (match (and equal
  698. (list (string-take spec equal)
  699. (string-drop spec (+ 1 equal))))
  700. ((spec flag)
  701. (cons spec flag))
  702. (_
  703. (raise (formatted-message
  704. (G_ "~a: invalid package configure flag specification")
  705. spec))))))
  706. specs))
  707. (define rewrite
  708. (package-input-rewriting/spec
  709. (map (match-lambda
  710. ((spec . flags)
  711. (cons spec (cut package-with-configure-flag <> flags))))
  712. configure-flags)))
  713. (lambda (obj)
  714. (if (package? obj)
  715. (rewrite obj)
  716. obj)))
  717. (define (patched-source name source patches)
  718. "Return a file-like object with the given NAME that applies PATCHES to
  719. SOURCE. SOURCE must itself be a file-like object of any type, including
  720. <git-checkout>, <local-file>, etc."
  721. (define patch
  722. (module-ref (resolve-interface '(gnu packages base)) 'patch))
  723. (computed-file name
  724. (with-imported-modules '((guix build utils))
  725. #~(begin
  726. (use-modules (guix build utils))
  727. (setenv "PATH" #+(file-append patch "/bin"))
  728. ;; XXX: Assume SOURCE is a directory. This is true in
  729. ;; most practical cases, where it's a <git-checkout>.
  730. (copy-recursively #+source #$output)
  731. (chdir #$output)
  732. (for-each (lambda (patch)
  733. (invoke "patch" "-p1" "--batch"
  734. "-i" patch))
  735. '(#+@patches))))))
  736. (define (transform-package-patches specs)
  737. "Return a procedure that, when passed a package, returns a package with
  738. additional patches."
  739. (define (package-with-extra-patches p patches)
  740. (let ((patches (map (lambda (file)
  741. (local-file file))
  742. patches)))
  743. (if (origin? (package-source p))
  744. (package/inherit p
  745. (source (origin
  746. (inherit (package-source p))
  747. (patches (append patches
  748. (origin-patches (package-source p)))))))
  749. (package/inherit p
  750. (source (patched-source (string-append (package-full-name p "-")
  751. "-source")
  752. (package-source p) patches))))))
  753. (define (coalesce-alist alist)
  754. ;; Coalesce multiple occurrences of the same key in ALIST.
  755. (let loop ((alist alist)
  756. (keys '())
  757. (mapping vlist-null))
  758. (match alist
  759. (()
  760. (map (lambda (key)
  761. (cons key (vhash-fold* cons '() key mapping)))
  762. (delete-duplicates (reverse keys))))
  763. (((key . value) . rest)
  764. (loop rest
  765. (cons key keys)
  766. (vhash-cons key value mapping))))))
  767. (define patches
  768. ;; Spec/patch alist.
  769. (coalesce-alist
  770. (map (lambda (spec)
  771. (match (string-tokenize spec %not-equal)
  772. ((spec patch)
  773. (cons spec (canonicalize-path patch)))
  774. (_
  775. (raise (formatted-message
  776. (G_ "~a: invalid package patch specification")
  777. spec)))))
  778. specs)))
  779. (define rewrite
  780. (package-input-rewriting/spec
  781. (map (match-lambda
  782. ((spec . patches)
  783. (cons spec (cut package-with-extra-patches <> patches))))
  784. patches)))
  785. (lambda (obj)
  786. (if (package? obj)
  787. (rewrite obj)
  788. obj)))
  789. (define* (package-with-upstream-version p #:optional version)
  790. "Return package P changed to use the given upstream VERSION or, if VERSION
  791. is #f, the latest known upstream version."
  792. (let ((source (package-latest-release p #:version version)))
  793. (cond ((not source)
  794. (if version
  795. (warning
  796. (G_ "could not find version ~a of '~a' upstream~%")
  797. version (package-name p))
  798. (warning
  799. (G_ "could not determine latest upstream release of '~a'~%")
  800. (package-name p)))
  801. p)
  802. ((string=? (upstream-source-version source)
  803. (package-version p))
  804. (unless version
  805. (info (G_ "~a is already the latest version of '~a'~%")
  806. (package-version p) (package-name p)))
  807. p)
  808. (else
  809. (when (version>? (package-version p)
  810. (upstream-source-version source))
  811. (warning (G_ "using ~a ~a, which is older than the packaged \
  812. version (~a)~%")
  813. (package-name p)
  814. (upstream-source-version source)
  815. (package-version p)))
  816. (unless (pair? (upstream-source-signature-urls source))
  817. (warning (G_ "cannot authenticate source of '~a', version ~a~%")
  818. (package-name p)
  819. (upstream-source-version source)))
  820. ;; TODO: Take 'upstream-source-input-changes' into account.
  821. (package
  822. (inherit p)
  823. (version (upstream-source-version source))
  824. (source source))))))
  825. (define (transform-package-latest specs)
  826. "Return a procedure that rewrites package graphs such that those in SPECS
  827. are replaced by their latest upstream version."
  828. (define rewrite
  829. (package-input-rewriting/spec
  830. (map (lambda (spec)
  831. (cons spec package-with-upstream-version))
  832. specs)))
  833. (lambda (obj)
  834. (if (package? obj)
  835. (rewrite obj)
  836. obj)))
  837. (define (transform-package-version specs)
  838. "Return a procedure that rewrites package graphs such that those in SPECS
  839. are replaced by the specified upstream version."
  840. (define rewrite
  841. (package-input-rewriting/spec
  842. (map (lambda (spec)
  843. (match (string-tokenize spec %not-equal)
  844. ((spec version)
  845. (cons spec (cut package-with-upstream-version <> version)))
  846. (_
  847. (raise (formatted-message
  848. (G_ "~a: invalid upstream version specification")
  849. spec)))))
  850. specs)))
  851. (lambda (obj)
  852. (if (package? obj)
  853. (rewrite obj)
  854. obj)))
  855. (define %transformations
  856. ;; Transformations that can be applied to things to build. The car is the
  857. ;; key used in the option alist, and the cdr is the transformation
  858. ;; procedure; it is called with two arguments: the store, and a list of
  859. ;; things to build.
  860. `((with-source . ,transform-package-source)
  861. (with-input . ,transform-package-inputs)
  862. (with-graft . ,transform-package-inputs/graft)
  863. (with-branch . ,transform-package-source-branch)
  864. (with-commit . ,transform-package-source-commit)
  865. (with-git-url . ,transform-package-source-git-url)
  866. (with-parameter . ,transform-package-parameters)
  867. (with-c-toolchain . ,transform-package-toolchain)
  868. (tune . ,transform-package-tuning)
  869. (with-debug-info . ,transform-package-with-debug-info)
  870. (without-tests . ,transform-package-tests)
  871. (with-configure-flag . ,transform-package-configure-flag)
  872. (with-patch . ,transform-package-patches)
  873. (with-latest . ,transform-package-latest)
  874. (with-version . ,transform-package-version)))
  875. (define (transformation-procedure key)
  876. "Return the transformation procedure associated with KEY, a symbol such as
  877. 'with-source', or #f if there is none."
  878. (any (match-lambda
  879. ((k . proc)
  880. (and (eq? k key) proc)))
  881. %transformations))
  882. (define (transformation-option-key? key)
  883. "Return true if KEY is an option key (as returned while parsing options with
  884. %TRANSFORMATION-OPTIONS) corresponding to a package transformation option.
  885. For example, (transformation-option-key? 'with-input) => #t."
  886. (->bool (transformation-procedure key)))
  887. ;;;
  888. ;;; Command-line handling.
  889. ;;;
  890. (define %transformation-options
  891. ;; The command-line interface to the above transformations.
  892. (let ((parser (lambda (symbol)
  893. (lambda (opt name arg result . rest)
  894. (apply values
  895. (alist-cons symbol arg result)
  896. rest)))))
  897. (list (option '("with-source") #t #f
  898. (parser 'with-source))
  899. (option '("with-input") #t #f
  900. (parser 'with-input))
  901. (option '("with-graft") #t #f
  902. (parser 'with-graft))
  903. (option '("with-branch") #t #f
  904. (parser 'with-branch))
  905. (option '("with-commit") #t #f
  906. (parser 'with-commit))
  907. (option '("with-git-url") #t #f
  908. (parser 'with-git-url))
  909. (option '("with-parameter") #t #f
  910. (parser 'with-parameter))
  911. (option '("with-c-toolchain") #t #f
  912. (parser 'with-c-toolchain))
  913. (option '("tune") #f #t
  914. (lambda (opt name arg result . rest)
  915. (define micro-architecture
  916. (match arg
  917. ((or #f "native")
  918. (unless (string=? (or (assoc-ref result 'system)
  919. (%current-system))
  920. %system)
  921. (leave (G_ "\
  922. building for ~a instead of ~a, so tuning cannot be guessed~%")
  923. (assoc-ref result 'system) %system))
  924. (cpu->gcc-architecture (current-cpu)))
  925. ("generic" #f)
  926. (_ arg)))
  927. (apply values
  928. (if micro-architecture
  929. (alist-cons 'tune micro-architecture
  930. result)
  931. (alist-delete 'tune result))
  932. rest)))
  933. (option '("with-debug-info") #t #f
  934. (parser 'with-debug-info))
  935. (option '("without-tests") #t #f
  936. (parser 'without-tests))
  937. (option '("with-configure-flag") #t #f
  938. (parser 'with-configure-flag))
  939. (option '("with-patch") #t #f
  940. (parser 'with-patch))
  941. (option '("with-latest") #t #f
  942. (parser 'with-latest))
  943. (option '("with-version") #t #f
  944. (parser 'with-version))
  945. (option '("help-transform") #f #f
  946. (lambda _
  947. (format #t
  948. (G_ "Available package transformation options:~%"))
  949. (show-transformation-options-help/detailed)
  950. (newline)
  951. (exit 0))))))
  952. (define (show-transformation-options-help/detailed)
  953. (display (G_ "
  954. --with-source=[PACKAGE=]SOURCE
  955. use SOURCE when building the corresponding package"))
  956. (display (G_ "
  957. --with-input=PACKAGE=REPLACEMENT
  958. replace dependency PACKAGE by REPLACEMENT"))
  959. (display (G_ "
  960. --with-graft=PACKAGE=REPLACEMENT
  961. graft REPLACEMENT on packages that refer to PACKAGE"))
  962. (display (G_ "
  963. --with-branch=PACKAGE=BRANCH
  964. build PACKAGE from the latest commit of BRANCH"))
  965. (display (G_ "
  966. --with-commit=PACKAGE=COMMIT
  967. build PACKAGE from COMMIT"))
  968. (display (G_ "
  969. --with-git-url=PACKAGE=URL
  970. build PACKAGE from the repository at URL"))
  971. (display (G_ "
  972. --with-patch=PACKAGE=FILE
  973. add FILE to the list of patches of PACKAGE"))
  974. (display (G_ "
  975. --tune[=CPU] tune relevant packages for CPU--e.g., \"skylake\""))
  976. (display (G_ "
  977. --with-configure-flag=PACKAGE=FLAG
  978. append FLAG to the configure flags of PACKAGE"))
  979. (display (G_ "
  980. --with-latest=PACKAGE
  981. use the latest upstream release of PACKAGE"))
  982. (display (G_ "
  983. --with-version=PACKAGE=VERSION
  984. use the given upstream VERSION of PACKAGE"))
  985. (display (G_ "
  986. --with-c-toolchain=PACKAGE=TOOLCHAIN
  987. build PACKAGE and its dependents with TOOLCHAIN"))
  988. (display (G_ "
  989. --with-debug-info=PACKAGE
  990. build PACKAGE and preserve its debug info"))
  991. (display (G_ "
  992. --without-tests=PACKAGE
  993. build PACKAGE without running its tests")))
  994. (define (show-transformation-options-help)
  995. "Show basic help for package transformation options."
  996. (display (G_ "
  997. --help-transform list package transformation options not shown here")))
  998. (define (options->transformation opts)
  999. "Return a procedure that, when passed an object to build (package,
  1000. derivation, etc.), applies the transformations specified by OPTS and returns
  1001. the resulting objects. OPTS must be a list of symbol/string pairs such as:
  1002. ((with-branch . \"guile-gcrypt=master\")
  1003. (without-tests . \"libgcrypt\"))
  1004. Each symbol names a transformation and the corresponding string is an argument
  1005. to that transformation."
  1006. (define applicable
  1007. ;; List of applicable transformations as symbol/procedure pairs in the
  1008. ;; order in which they appear on the command line.
  1009. (filter-map (match-lambda
  1010. ((key . value)
  1011. (match (transformation-procedure key)
  1012. (#f
  1013. #f)
  1014. (transform
  1015. ;; XXX: We used to pass TRANSFORM a list of several
  1016. ;; arguments, but we now pass only one, assuming that
  1017. ;; transform composes well.
  1018. (list key value (transform (list value)))))))
  1019. (reverse opts)))
  1020. (define (package-with-transformation-properties p)
  1021. (package/inherit p
  1022. (properties `((transformations
  1023. . ,(map (match-lambda
  1024. ((key value _)
  1025. (cons key value)))
  1026. (reverse applicable))) ;preserve order
  1027. ,@(package-properties p)))))
  1028. (lambda (obj)
  1029. (define (tagged-object new)
  1030. (if (and (not (eq? obj new))
  1031. (package? new) (not (null? applicable)))
  1032. (package-with-transformation-properties new)
  1033. new))
  1034. (tagged-object
  1035. (fold (match-lambda*
  1036. (((name value transform) obj)
  1037. (let ((new (transform obj)))
  1038. (when (eq? new obj)
  1039. (warning (G_ "transformation '~a' had no effect on ~a~%")
  1040. name
  1041. (if (package? obj)
  1042. (package-full-name obj)
  1043. obj)))
  1044. new)))
  1045. obj
  1046. applicable))))
  1047. (define (package-transformations package)
  1048. "Return the transformations applied to PACKAGE according to its properties."
  1049. (match (assq-ref (package-properties package) 'transformations)
  1050. (#f '())
  1051. (transformations transformations)))
  1052. (define (manifest-entry-with-transformations entry)
  1053. "Return ENTRY with an additional 'transformations' property if it's not
  1054. already there."
  1055. (let ((properties (manifest-entry-properties entry)))
  1056. (if (assq 'transformations properties)
  1057. entry
  1058. (let ((item (manifest-entry-item entry)))
  1059. (manifest-entry
  1060. (inherit entry)
  1061. (properties
  1062. (match (and (package? item)
  1063. (package-transformations item))
  1064. ((or #f '())
  1065. properties)
  1066. (transformations
  1067. `((transformations . ,transformations)
  1068. ,@properties)))))))))