Hello!
As reported on guix-devel, ‘guix weather’ has become extremely slow.
Specifically, in the narinfo-fetching phase, it runs at 100% CPU, even
though that part should be network-bound (pipelined HTTP GETs).
A profile of the ‘report-server-coverage’ call would show this:
--8<---------------cut here---------------start------------->8---
% cumulative self
time seconds seconds procedure
62.50 1.06 1.06 fluid-ref*
6.25 0.11 0.11 regexp-exec
3.13 0.05 0.05 ice-9/boot-9.scm:1738:4:throw
2.08 0.04 0.04 string-index
2.08 0.04 0.04 write
1.04 568.08 0.02 ice-9/boot-9.scm:1673:4:with-exception-handler
1.04 0.02 0.02 %read-line
1.04 0.02 0.02 guix/ci.scm:78:0:json->build
1.04 0.02 0.02 string-append
--8<---------------cut here---------------end--------------->8---
More than half of the time spent in ‘fluid-ref*’—sounds fishy.
Where does that that call come from? There seems to be a single caller,
in boot-9.scm:
(define* (raise-exception exn #:key (continuable? #f))
(define (capture-current-exception-handlers)
;; FIXME: This is quadratic.
(let lp ((depth 0))
(let ((h (fluid-ref* %exception-handler depth)))
(if h
(cons h (lp (1+ depth)))
(list fallback-exception-handler)))))
;; …
)
We must be abusing exceptions somewhere…
Indeed, there’s one place on the hot path where we install exception
handlers: in ‘http-multiple-get’ (from commit
205833b72c5517915a47a50dbe28e7024dc74e57). I don’t think it’s needed,
is it? (But if it is, let’s find another approach, this one is
prohibitively expensive.)
A simple performance test is:
rm -rf ~/.cache/guix/substitute/
time ./pre-inst-env guix weather $(guix package -A|head -500| cut -f1)
After removing this ‘catch’ in ‘http-multiple-get’, the profile is
flatter:
--8<---------------cut here---------------start------------->8---
% cumulative self
time seconds seconds procedure
8.33 0.07 0.07 string-index
8.33 0.07 0.07 regexp-exec
5.56 0.05 0.05 anon #x154af88
5.56 0.05 0.05 write
5.56 0.05 0.05 string-tokenize
5.56 0.05 0.05 read-char
5.56 0.05 0.05 set-certificate-credentials-x509-trust-data!
5.56 0.05 0.05 %read-line
--8<---------------cut here---------------end--------------->8---
There’s also this ‘call-with-connection-error-handling’ call in (guix
substitute), around an ‘http-multiple-get’ call, that may not be
justified.
Attached is a diff of the tweaks I made to test this.
WDYT, Chris?
Ludo’.
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 4b4c14ed0b..a28523201e 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -219,42 +219,21 @@ returning."
(remainder
(connect p remainder result))))
((head tail ...)
- (catch #t
- (lambda ()
- (let* ((resp (read-response p))
- (body (response-body-port resp))
- (result (proc head resp body result)))
- ;; The server can choose to stop responding at any time,
- ;; in which case we have to try again. Check whether
- ;; that is the case. Note that even upon "Connection:
- ;; close", we can read from BODY.
- (match (assq 'connection (response-headers resp))
- (('connection 'close)
- (close-port p)
- (connect #f ;try again
- (drop requests (+ 1 processed))
- result))
- (_
- (loop tail (+ 1 processed) result))))) ;keep going
- (lambda (key . args)
- ;; If PORT was cached and the server closed the connection
- ;; in the meantime, we get EPIPE. In that case, open a
- ;; fresh connection and retry. We might also get
- ;; 'bad-response or a similar exception from (web response)
- ;; later on, once we've sent the request, or a
- ;; ERROR/INVALID-SESSION from GnuTLS.
- (if (or (and (eq? key 'system-error)
- (= EPIPE (system-error-errno `(,key ,@args))))
- (and (eq? key 'gnutls-error)
- (eq? (first args) error/invalid-session))
- (memq key
- '(bad-response bad-header bad-header-component)))
- (begin
- (close-port p)
- (connect #f ; try again
- (drop requests (+ 1 processed))
- result))
- (apply throw key args))))))))))
+ (let* ((resp (read-response p))
+ (body (response-body-port resp))
+ (result (proc head resp body result)))
+ ;; The server can choose to stop responding at any time,
+ ;; in which case we have to try again. Check whether
+ ;; that is the case. Note that even upon "Connection:
+ ;; close", we can read from BODY.
+ (match (assq 'connection (response-headers resp))
+ (('connection 'close)
+ (close-port p)
+ (connect #f ;try again
+ (drop requests (+ 1 processed))
+ result))
+ (_
+ (loop tail (+ 1 processed) result))))))))))
;;;
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 5164fe0494..3d8d50d5e3 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -184,9 +184,10 @@ Return the coverage ratio, an exact number between 0 and 1."
(let/time ((time narinfos requests-made
(lookup-narinfos
server items
- #:make-progress-reporter
- (lambda* (total #:key url #:allow-other-keys)
- (progress-reporter/bar total)))))
+ ;; #:make-progress-reporter
+ ;; (lambda* (total #:key url #:allow-other-keys)
+ ;; (progress-reporter/bar total))
+ )))
(format #t "~a~%" server)
(let ((obtained (length narinfos))
(requested (length items))
@@ -504,6 +505,7 @@ SERVER. Display information for packages with at least THRESHOLD dependents."
;;; Entry point.
;;;
+(use-modules (statprof))
(define-command (guix-weather . args)
(synopsis "report on the availability of pre-built package binaries")
@@ -551,9 +553,11 @@ SERVER. Display information for packages with at least THRESHOLD dependents."
(exit
(every* (lambda (server)
(define coverage
- (report-server-coverage server items
- #:display-missing?
- (assoc-ref opts 'display-missing?)))
+ (statprof
+ (lambda ()
+ (report-server-coverage server items
+ #:display-missing?
+ (assoc-ref opts 'display-missing?)))))
(match (assoc-ref opts 'coverage)
(#f #f)
(threshold
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index 08f8c24efd..04bf70caaa 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -59,8 +59,6 @@
#:use-module (guix http-client)
#:export (%narinfo-cache-directory
- call-with-connection-error-handling
-
lookup-narinfos
lookup-narinfos/diverse))
@@ -235,14 +233,11 @@ if file doesn't exist, and the narinfo otherwise."
(let* ((requests (map (cut narinfo-request url <>) paths))
(result (begin
(start-progress-reporter! progress-reporter)
- (call-with-connection-error-handling
- uri
- (lambda ()
- (http-multiple-get uri
- handle-narinfo-response '()
- requests
- #:open-connection open-connection
- #:verify-certificate? #f))))))
+ (http-multiple-get uri
+ handle-narinfo-response '()
+ requests
+ #:open-connection open-connection
+ #:verify-certificate? #f))))
(stop-progress-reporter! progress-reporter)
result))
((file #f)
