ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

serialization: Micro-optimize string literal output in 'write-file-tree'.

Browse source 
This reduces allocations and bit twiddling in the loop.

* guix/serialization.scm (write-literal-strings): New macro.
(write-file-tree): Use it in lieu of 'write-string' calls where applicable.
This commit is contained in:
Ludovic Courtès 2021-02-25 15:46:22 +01:00
parent 9ce78f27a0
commit f293705d7e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 40 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

56
guix/serialization.scm
View file

@ -199,6 +199,37 @@ (define (read-store-path p)
(define write-store-path-list write-string-list)
(define read-store-path-list read-string-list)
(define-syntax write-literal-strings
(lambda (s)
"Write the given literal strings to PORT in an optimized fashion, without
any run-time allocations or computations."
(define (padding len)
(let ((m (modulo len 8)))
(if (zero? m)
0
(- 8 m))))
(syntax-case s ()
((_ port strings ...)
(let* ((bytes (map string->utf8 (syntax->datum #'(strings ...))))
(len (fold (lambda (bv size)
(+ size 8 (bytevector-length bv)
(padding (bytevector-length bv))))
0
bytes))
(bv (make-bytevector len))
(zeros (make-bytevector 8 0)))
(fold (lambda (str offset)
(let ((len (bytevector-length str)))
(bytevector-u32-set! bv offset len (endianness little))
(bytevector-copy! str 0 bv (+ 8 offset) len)
(bytevector-copy! zeros 0 bv (+ 8 offset len)
(padding len))
(+ offset 8 len (padding len))))
0
bytes)
#`(put-bytevector port #,bv))))))
(define-condition-type &nar-read-error &nar-error
nar-read-error?
@ -332,14 +363,12 @@ (define p port)
(define-values (type size)
(file-type+size f))
(write-string "(" p)
(write-literal-strings p "(")
(case type
((regular executable)
(write-string "type" p)
(write-string "regular" p)
(write-literal-strings p "type" "regular")
(when (eq? 'executable type)
(write-string "executable" p)
(write-string "" p))
(write-literal-strings p "executable" ""))
(let ((input (file-port f)))
(dynamic-wind
(const #t)
@ -348,28 +377,23 @@ (define-values (type size)
(lambda ()
(close-port input)))))
((directory)
(write-string "type" p)
(write-string "directory" p)
(write-literal-strings p "type" "directory")
(let ((entries (postprocess-entries (directory-entries f))))
(for-each (lambda (e)
(let* ((f (string-append f "/" e)))
(write-string "entry" p)
(write-string "(" p)
(write-string "name" p)
(write-literal-strings p "entry" "(" "name")
(write-string e p)
(write-string "node" p)
(write-literal-strings p "node")
(dump f)
(write-string ")" p)))
(write-literal-strings p ")")))
entries)))
((symlink)
(write-string "type" p)
(write-string "symlink" p)
(write-string "target" p)
(write-literal-strings p "type" "symlink" "target")
(write-string (symlink-target f) p))
(else
(raise (condition (&message (message "unsupported file type"))
(&nar-error (file f) (port port))))))
(write-string ")" p)))
(write-literal-strings p ")")))
(define port-conversion-strategy
(fluid->parameter %default-port-conversion-strategy))