From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:8:6d80::]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id c9trCGmfZ2DBRwEAgWs5BA (envelope-from ) for ; Sat, 03 Apr 2021 00:49:13 +0200 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id WNEvAWmfZ2DkGQAAbx9fmQ (envelope-from ) for ; Fri, 02 Apr 2021 22:49:13 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 3363C14647 for ; Sat, 3 Apr 2021 00:49:12 +0200 (CEST) Received: from localhost ([::1]:35602 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lSSbF-0001QU-QS for larch@yhetil.org; Fri, 02 Apr 2021 18:49:09 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:45906) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lSSb8-0001QM-Lh for bug-guix@gnu.org; Fri, 02 Apr 2021 18:49:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:49678) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lSSb8-0005dp-E9 for bug-guix@gnu.org; Fri, 02 Apr 2021 18:49:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lSSb8-0006Oa-Aw for bug-guix@gnu.org; Fri, 02 Apr 2021 18:49:02 -0400 X-Loop: help-debbugs@gnu.org Subject: bug#33848: Store references in SBCL-compiled code are "invisible" Resent-From: Mark H Weaver Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Fri, 02 Apr 2021 22:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33848 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: Pierre Neidhardt , Guillaume Le Vaillant Received: via spool by 33848-submit@debbugs.gnu.org id=B33848.161740371824554 (code B ref 33848); Fri, 02 Apr 2021 22:49:02 +0000 Received: (at 33848) by debbugs.gnu.org; 2 Apr 2021 22:48:38 +0000 Received: from localhost ([127.0.0.1]:32991 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lSSaj-0006Ny-S8 for submit@debbugs.gnu.org; Fri, 02 Apr 2021 18:48:38 -0400 Received: from world.peace.net ([64.112.178.59]:36528) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lSSah-0006Nl-NB for 33848@debbugs.gnu.org; Fri, 02 Apr 2021 18:48:36 -0400 Received: from mhw by world.peace.net with esmtpsa (TLS1.3:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1lSSaa-0003hD-Uc; Fri, 02 Apr 2021 18:48:29 -0400 From: Mark H Weaver In-Reply-To: <871rbtc3j5.fsf@netris.org> References: <87r2e8jpfx.fsf@gnu.org> <8736qji7c1.fsf@ambrevar.xyz> <87tvizvzgk.fsf@netris.org> <87o9979gfn.fsf@gnu.org> <87tvizgghs.fsf@ambrevar.xyz> <87k1juaomo.fsf@gnu.org> <87muoqhk62.fsf@ambrevar.xyz> <87zhsq8wkj.fsf@gnu.org> <87d0pmhbgn.fsf@ambrevar.xyz> <87r2e28tkv.fsf@gnu.org> <874laygkiy.fsf@ambrevar.xyz> <87lfa5eymf.fsf@ambrevar.xyz> <87tuoscsk9.fsf@gnu.org> <87im57b8u7.fsf@ambrevar.xyz> <87czvebky2.fsf@netris.org> <87eefu30a4.fsf@gnu.org> <87im56l6es.fsf@yamatai> <87wntm8j18.fsf@ambrevar.xyz> <87a6qil4b1.fsf@yamatai> <87a6qiz5b3.fsf@ambrevar.xyz> <871rbtc3j5.fsf@netris.org> Date: Fri, 02 Apr 2021 18:46:41 -0400 Message-ID: <87r1js9udv.fsf@netris.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guix@gnu.org List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: 33848@debbugs.gnu.org Errors-To: bug-guix-bounces+larch=yhetil.org@gnu.org Sender: "bug-Guix" X-Migadu-Flow: FLOW_IN ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1617403752; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type:resent-cc:resent-from:resent-sender: resent-message-id:in-reply-to:in-reply-to:references:references: list-id:list-help:list-unsubscribe:list-subscribe:list-post; bh=eFTNZylSsun5VnG90O3LYPBhMVYxUbN3I+z4jN5kXQ0=; b=NriQV1Pz0wwLzWiemfgG8U5XTvSjPiIe6sEzYYfKOzWmF6LXl9tEjBny95pVMP1jG41egm iz5omPK104w/X+w05mVyWHYh9LiwheT54Jmk4VAMzk47uKqWQWIOcKNRjhd9fnsFTvxmoa fvrNea8PWVV4NjQM2adzh8z3vGv0gx5s+3IVPOUs2r7utDMXI7gSrmxcAyB6TIR0oExhTa D84XJ60B2rvpfq/33ECrzV81Qe8c8EkfmBmrydnXQvapIqg6bgpz/N6ZCbpS8NFFGO7Dsk ZpXKWFLwSxjRPqNdlOFLr/jHVuDxI3z0Mr/rvur0vJPizkRJQjPyo6UhA0+ilA== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1617403752; a=rsa-sha256; cv=none; b=Lxv108j5DXf66nCl3Kd46Vk6KoZTEnw2GNgvPsUM1F+dwOLA0y0CGfzOAgV8LMgaGUyR1P lnwbLZBFm9ze0PNxKe+sqtAwe68ER8wlqFKauWn8ZXTWhhqAai5GIHNPbP+JC01ivAIzv0 jwXrvI8ky8U9twtk0g4oT0G57Uq3XEdny9uywrXbqszSMZwEzebKqS3gIXhl5zahK3z1v7 6xBBHs0uhQQNiNN0rwvhEt9f+oKP3sqUiYuQyBritKNKLZTDFgE7jbwQWFirKVTkkXWrsv bZAeZl1kX4HGbf8aPQcTFwBES+yO/sDKoa/ZTCqvYxZihspd3Q/o+5EdbODhWQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of bug-guix-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=bug-guix-bounces@gnu.org X-Migadu-Spam-Score: -2.43 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of bug-guix-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=bug-guix-bounces@gnu.org X-Migadu-Queue-Id: 3363C14647 X-Spam-Score: -2.43 X-Migadu-Scanner: scn0.migadu.com X-TUID: g7Mcc4fPdcXc --=-=-= Content-Type: text/plain Here's a preliminary draft patch to add support for UTF-32 and UTF-16 references to our grafting code. I haven't yet measured the efficiency impact of these changes, but I suspect it's not too bad. I'd be curious to know whether it fixes the Nyxt graft. Mark --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=0001-DRAFT-grafts-Add-support-for-UTF-16-and-UTF-32-store.patch Content-Transfer-Encoding: quoted-printable Content-Description: [PATCH] DRAFT: grafts: Add support for UTF-16 and UTF-32 store references >From 0fcfd804570fd1c07ffb1f6c176d6ec3430907df Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 2 Apr 2021 18:36:23 -0400 Subject: [PATCH] DRAFT: grafts: Add support for UTF-16 and UTF-32 store references. --- guix/build/graft.scm | 138 +++++++++++++++++++++++++++++-------------- tests/grafts.scm | 68 +++++++++++++++++++++ 2 files changed, 162 insertions(+), 44 deletions(-) diff --git a/guix/build/graft.scm b/guix/build/graft.scm index c119ee71d1..6e7f3859cb 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright =C2=A9 2014, 2015, 2016, 2018 Ludovic Court=C3=A8s -;;; Copyright =C2=A9 2016 Mark H Weaver +;;; Copyright =C2=A9 2016, 2021 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,6 +55,36 @@ (string->char-set "0123456789abcdfghijklmnpqrsvwxyz") <>)) =20 +(define (nix-base32-char-or-nul? byte) + (or (nix-base32-char? byte) + (char=3D? byte #\nul))) + +(define (has-utf16-zeroes? buffer i) + (let loop ((j (+ 1 (- i (* 2 hash-length))))) + (or (>=3D j i) + (and (zero? (bytevector-u8-ref buffer j)) + (loop (+ j 2)))))) + +(define (has-utf32-zeroes? buffer i) + (let loop ((j (+ 1 (- i (* 4 hash-length))))) + (or (>=3D j i) + (and (zero? (bytevector-u8-ref buffer j)) + (zero? (bytevector-u8-ref buffer (+ j 1))) + (zero? (bytevector-u8-ref buffer (+ j 2))) + (loop (+ j 4)))))) + +(define (expand-bytevector bv char-size) + (let* ((len (bytevector-length bv)) + (bv* (make-bytevector (+ 1 (* char-size + (- len 1))) + 0))) + (let loop ((i 0)) + (when (< i len) + (bytevector-u8-set! bv* (* i char-size) + (bytevector-u8-ref bv i)) + (loop (+ i 1)))) + bv*)) + (define* (replace-store-references input output replacement-table #:optional (store (%store-directory))) "Read data from INPUT, replacing store references according to @@ -76,15 +106,16 @@ bytevectors to the same value." (list->vector (map pred (iota 256))) <>)) =20 - (define nix-base32-byte? + (define nix-base32-byte-or-nul? (optimize-u8-predicate - (compose nix-base32-char? + (compose nix-base32-char-or-nul? integer->char))) =20 (define (dash? byte) (=3D byte 45)) =20 (define request-size (expt 2 20)) ; 1 MiB =20 + ;; XXX This comment is no longer accurate! ;; We scan the file for the following 33-byte pattern: 32 bytes of ;; nix-base32 characters followed by a dash. To accommodate large files, ;; we do not read the entire file, but instead work on buffers of up to @@ -116,43 +147,61 @@ bytevectors to the same value." ;; written. (if (< i end) (let ((byte (bytevector-u8-ref buffer i))) - (cond ((and (dash? byte) - ;; We've found a dash. Note that we do not k= now - ;; whether the preceeding 32 bytes are nix-ba= se32 - ;; characters, but we do not need to know. If - ;; they are not, the following lookup will fa= il. - (lookup-replacement - (string-tabulate (lambda (j) - (integer->char - (bytevector-u8-ref buffer - (+ j (- i hash-length))= ))) - hash-length))) - =3D> (lambda (replacement) - ;; We've found a hash that needs to be replac= ed. - ;; First, write out all bytes preceding the h= ash - ;; that have not yet been written. - (put-bytevector output buffer written - (- i hash-length written)) - ;; Now write the replacement string. - (put-bytevector output replacement) - ;; Since the byte at position 'i' is a dash, - ;; which is not a nix-base32 char, the earlie= st - ;; position where the next hash might start is - ;; i+1, and the earliest position where the - ;; following dash might start is (+ i 1 - ;; hash-length). Also, increase the write - ;; position to account for REPLACEMENT. - (let ((len (bytevector-length replacement))) - (scan-from (+ i 1 len) - (+ i (- len hash-length)))))) - ;; If the byte at position 'i' is a nix-base32 char, + (cond ((dash? byte) + (let* ((char-size + (if (zero? (bytevector-u8-ref buffer (- i = 1))) + (if (zero? (bytevector-u8-ref buffer (= - i 2))) + (if (and (<=3D (* 4 hash-length) + (- i written)) + (has-utf32-zeroes? buffer= i)) + 4 + 1) + (if (and (<=3D (* 2 hash-length) + (- i written)) + (has-utf16-zeroes? buffer= i)) + 2 + 1)) + 1)) + (replacement* + (lookup-replacement + (string-tabulate (lambda (j) + (integer->char + (bytevector-u8-ref bu= ffer + (- i (* char-size + (- hash-leng= th j)))))) + hash-length))) + (replacement + (and replacement* + (expand-bytevector replacement* + char-size)))) + (if replacement + (begin + ;; We've found a hash that needs to be rep= laced. + ;; First, write out all bytes preceding th= e hash + ;; that have not yet been written. + (put-bytevector output buffer written + (- i (* char-size hash-len= gth) written)) + ;; Now write the replacement string. + (put-bytevector output replacement) + ;; Now compute the new value of 'written' = and + ;; the new value of 'i', and iterate. + (let ((written (+ (- i (* char-size hash-l= ength)) + (bytevector-length repla= cement)))) + (scan-from (+ written hash-length) writt= en))) + ;; The byte at position 'i' is a dash, which= is + ;; not a nix-base32 char, so the earliest + ;; position where the next hash might start = is + ;; i+1, with the following dash at position = (+ i + ;; 1 hash-length). + (scan-from (+ i 1 hash-length) written)))) + ;; If the byte at position 'i' is a nix-base32 char= or nul, ;; then the dash we're looking for might be as earl= y as ;; the following byte, so we can only advance by 1. - ((nix-base32-byte? byte) + ((nix-base32-byte-or-nul? byte) (scan-from (+ i 1) written)) - ;; If the byte at position 'i' is NOT a nix-base32 - ;; char, then the earliest position where the next = hash - ;; might start is i+1, with the following dash at + ;; If the byte at position 'i' is NOT a nix-base32 = char + ;; or nul, then the earliest position where the next + ;; hash might start is i+1, with the following dash= at ;; position (+ i 1 hash-length). (else (scan-from (+ i 1 hash-length) written)))) @@ -162,18 +211,19 @@ bytevectors to the same value." ;; "unget". If 'end' is less than 'request-size' then we r= ead ;; less than we asked for, which indicates that we are at E= OF, ;; so we needn't unget anything. Otherwise, we unget up to - ;; 'hash-length' bytes (32 bytes). However, we must be car= eful - ;; not to unget bytes that have already been written, becau= se - ;; that would cause them to be written again from the next - ;; buffer. In practice, this case occurs when a replacemen= t is - ;; made near or beyond the end of the buffer. When REPLACE= MENT - ;; went beyond END, we consume the extra bytes from INPUT. + ;; (* 4 hash-length) bytes. However, we must be careful no= t to + ;; unget bytes that have already been written, because that + ;; would cause them to be written again from the next buffe= r. + ;; In practice, this case occurs when a replacement is made + ;; near or beyond the end of the buffer. When REPLACEMENT = went + ;; beyond END, we consume the extra bytes from INPUT. (begin (if (> written end) (get-bytevector-n! input buffer 0 (- written end)) (let* ((unwritten (- end written)) (unget-size (if (=3D end request-size) - (min hash-length unwritten) + (min (* 4 hash-length) + unwritten) 0)) (write-size (- unwritten unget-size))) (put-bytevector output buffer written write-size) diff --git a/tests/grafts.scm b/tests/grafts.scm index a12c6a5911..0e1c7355b1 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright =C2=A9 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Court=C3= =A8s +;;; Copyright =C2=A9 2021 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -468,4 +469,71 @@ replacement "/gnu/store"))))) =20 +(define (nul-expand str char-size) + (string-join (map string (string->list str)) + (make-string (- char-size 1) #\nul))) + +(for-each + (lambda (char-size1) + (for-each + (lambda (char-size2) + (for-each + (lambda (gap) + (for-each + (lambda (offset) + (test-equal (format #f "replace-store-references, char-sizes ~a= ~a, gap ~s, offset ~a" + char-size1 char-size2 gap offset) + (string-append (make-string offset #\=3D) + (nul-expand (string-append "/gnu/store/" + (make-string 32 #\6) + "-BlahBlaH") + char-size1) + gap + (nul-expand (string-append "/gnu/store/" + (make-string 32 #\8) + "-SoMeTHiNG") + char-size2) + (list->string (map integer->char (iota 77 33))= )) + + ;; Create input data where the right-hand-size of the dash ("= -something" + ;; here) goes beyond the end of the internal buffer of + ;; 'replace-store-references'. + (let* ((content (string-append (make-string offset #\=3D) + (nul-expand (string-append= "/gnu/store/" + = (make-string 32 #\5) + = "-blahblah") + char-size1) + gap + (nul-expand (string-append= "/gnu/store/" + = (make-string 32 #\7) + = "-something") + char-size2) + (list->string + (map integer->char (iota = 77 33))))) + (replacement (alist->vhash + `((,(make-string 32 #\5) + . ,(string->utf8 (string-append + (make-string 32 #\6) + "-BlahBlaH"))) + (,(make-string 32 #\7) + . ,(string->utf8 (string-append + (make-string 32 #\8) + "-SoMeTHiNG"))))))) + (call-with-output-string + (lambda (output) + ((@@ (guix build graft) replace-store-references) + (open-input-string content) output + replacement + "/gnu/store")))))) + ;; offsets to test + (map (lambda (i) (- buffer-size (* 40 char-size1) i)) + (iota 30)))) + ;; gaps + '("" "-" " " "a"))) + ;; char-size2 values to test + '(1 2))) + ;; char-size1 values to test + '(1 2 4)) + + (test-end) --=20 2.31.1 --=-=-=--