From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: ludo@gnu.org (Ludovic =?UTF-8?Q?Court=C3=A8s?=) Newsgroups: gmane.lisp.guile.bugs Subject: bug#20272: Support reproducible builds Date: Wed, 21 Dec 2016 00:00:47 +0100 Message-ID: <87eg12fbog.fsf@gnu.org> References: <87bmxxnjd7.fsf@gnu.org> <87shqtwxcb.fsf@gnu.org> <87twa6iikd.fsf@gnu.org> <87vaumgk80.fsf@gnu.org> <87mvfygjs1.fsf@gnu.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1482274949 26980 195.159.176.226 (20 Dec 2016 23:02:29 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Tue, 20 Dec 2016 23:02:29 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.1 (gnu/linux) Cc: 20272@debbugs.gnu.org To: Jan Nieuwenhuizen Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Wed Dec 21 00:02:21 2016 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cJTQH-00052Z-7J for guile-bugs@m.gmane.org; Wed, 21 Dec 2016 00:02:17 +0100 Original-Received: from localhost ([::1]:53875 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cJTQL-0006qZ-NF for guile-bugs@m.gmane.org; Tue, 20 Dec 2016 18:02:21 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:33720) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cJTQ5-0006kF-8U for bug-guile@gnu.org; Tue, 20 Dec 2016 18:02:10 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cJTQ2-0003zE-2W for bug-guile@gnu.org; Tue, 20 Dec 2016 18:02:05 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:34034) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cJTQ1-0003z3-V7 for bug-guile@gnu.org; Tue, 20 Dec 2016 18:02:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1cJTQ1-0008RV-N1 for bug-guile@gnu.org; Tue, 20 Dec 2016 18:02:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: ludo@gnu.org (Ludovic =?UTF-8?Q?Court=C3=A8s?=) Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Tue, 20 Dec 2016 23:02:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 20272 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch Original-Received: via spool by 20272-submit@debbugs.gnu.org id=B20272.148227487532361 (code B ref 20272); Tue, 20 Dec 2016 23:02:01 +0000 Original-Received: (at 20272) by debbugs.gnu.org; 20 Dec 2016 23:01:15 +0000 Original-Received: from localhost ([127.0.0.1]:49423 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cJTPG-0008Pt-IQ for submit@debbugs.gnu.org; Tue, 20 Dec 2016 18:01:15 -0500 Original-Received: from eggs.gnu.org ([208.118.235.92]:42292) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cJTPF-0008Pe-0p for 20272@debbugs.gnu.org; Tue, 20 Dec 2016 18:01:13 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cJTP6-0003PW-Rx for 20272@debbugs.gnu.org; Tue, 20 Dec 2016 18:01:08 -0500 Original-Received: from fencepost.gnu.org ([2001:4830:134:3::e]:38699) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cJTOt-0003G4-3j; Tue, 20 Dec 2016 18:00:51 -0500 Original-Received: from reverse-83.fdn.fr ([80.67.176.83]:58850 helo=pluto) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1cJTOr-0006XV-TV; Tue, 20 Dec 2016 18:00:50 -0500 In-Reply-To: <87mvfygjs1.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Thu, 15 Dec 2016 00:42:22 +0100") X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: "bug-guile" Xref: news.gmane.org gmane.lisp.guile.bugs:8482 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable ludo@gnu.org (Ludovic Court=C3=A8s) skribis: > To demonstrate non-reproducibility (with the attached patch, which is a > rebased version of Mark=E2=80=99s), just build the same module twice: onc= e with > its dependency evaluated, and then with its dependency compiled. The > results differ: [...] > In gnu.go.v2 the integers appended to generated symbols are lower > because fewer symbols had to be generated. This is fixed by introducing a =E2=80=9Cper-module gensym=E2=80=9D (patch a= ttached; to be applied on top of the previous one). That way, the sequence number in generated identifiers only depends on the module being compiled, not on whether other modules are being interpreted or not. The =E2=80=98module-gensym=E2=80=99 procedure I added adds a hash of the mo= dule name in the identifier, to distinguish from symbols introduced by =E2=80=98gensym= =E2=80=99. This makes symbols 3=E2=80=934 characters longer; perhaps we could avoid it. Thoughts? Thanks, Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch Content-Disposition: inline diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 8ef7e5f..5d0e727 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -390,6 +390,7 @@ If there is no handler at all, Guile prints an error and then exits." (let ((i next-id)) (set! next-id (+ i 1)) i)))) +(define module-gensym gensym) (define (resolve-module . args) #f) @@ -2731,6 +2732,20 @@ VALUE." (nested-define-module! (resolve-module '() #f) name mod) (accessor mod)))))) +(define* (module-gensym #:optional (id " mg") (m (current-module))) + "Return a fresh symbol in the context of module M, based on ID (a +string or symbol). As long as M is a valid module, this procedure is +deterministic." + (define (->string number) + (number->string number 16)) + + (if m + (string->symbol + (string-append id "-" + (->string (hash (module-name m) 10000)) "-" + (->string (module-generate-unique-id! m)))) + (gensym id))) + (define (make-modules-in module name) (or (nested-ref-module module name) (let ((m (make-module 31))) @@ -4322,7 +4337,6 @@ when none is available, reading FILE-NAME with READER." syntax-locally-bound-identifiers syntax-session-id))) - ;;; Place the user in the guile-user module. diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index c81b69e..e46951d 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1483,7 +1483,8 @@ s mod get-formals - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-a89 tmp-c0a-a88 tmp-c0a-a87) + (cons tmp-c0a-a87 (cons tmp-c0a-a88 tmp-c0a-a89))) e2* e1* args*))) @@ -1515,7 +1516,7 @@ (gen-var (lambda (id) (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (gensym (string-append (symbol->string id) "-"))))) + (module-gensym (symbol->string id))))) (lambda-var-list (lambda (vars) (let lvl ((vars vars) (ls '()) (w '(()))) @@ -1777,7 +1778,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-c54 tmp-c0a-c53 tmp-c0a-c52) + (cons tmp-c0a-c52 (cons tmp-c0a-c53 tmp-c0a-c54))) e2 e1 args))) @@ -1789,7 +1791,8 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-c6a tmp-c0a-c69 tmp-c0a-c68) + (cons tmp-c0a-c68 (cons tmp-c0a-c69 tmp-c0a-c6a))) e2 e1 args))) @@ -1812,7 +1815,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-c8a tmp-c0a-c89 tmp-c0a-c88) + (cons tmp-c0a-c88 (cons tmp-c0a-c89 tmp-c0a-c8a))) e2 e1 args))) @@ -1824,7 +1828,8 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-c0a-ca0 tmp-c0a-c9f tmp-c0a-c9e) + (cons tmp-c0a-c9e (cons tmp-c0a-c9f tmp-c0a-ca0))) e2 e1 args))) @@ -2340,7 +2345,7 @@ (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x))) (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls)))) + (map (lambda (x) (wrap (module-gensym "t-") '((top)) mod)) ls)))) (set! free-identifier=? (lambda (x y) (let ((x x)) @@ -2710,7 +2715,8 @@ #f k '() - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-1 tmp-c0a tmp-c0a-10ff) + (list (cons tmp-c0a-10ff tmp-c0a) tmp-c0a-1)) template pattern keyword))) @@ -2726,7 +2732,8 @@ #f k (list docstring) - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-111a tmp-c0a-1 tmp-c0a) + (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-111a)) template pattern keyword))) @@ -2741,7 +2748,8 @@ dots k '() - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-2 tmp-c0a-1 tmp-c0a) + (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-2)) template pattern keyword))) @@ -2757,7 +2765,8 @@ dots k (list docstring) - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-c0a-2 tmp-c0a-1 tmp-c0a) + (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-2)) template pattern keyword))) @@ -2876,7 +2885,7 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-c0a-11b7) (list "value" tmp-c0a-11b7)) p) (quasi q lev)) (quasicons (quasicons @@ -2894,7 +2903,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-c0a-11bc) (list "value" tmp-c0a-11bc)) + p) (quasi q lev)) (quasicons (quasicons @@ -2927,7 +2937,9 @@ (if tmp (apply (lambda (p) (if (= lev 0) - (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev)) + (quasilist* + (map (lambda (tmp-c0a-11d2) (list "value" tmp-c0a-11d2)) p) + (vquasi q lev)) (quasicons (quasicons '("quote" #(syntax-object unquote ((top)) (hygiene guile))) @@ -2943,7 +2955,7 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-c0a-11d7) (list "value" tmp-c0a-11d7)) p) (vquasi q lev)) (quasicons (quasicons @@ -3031,7 +3043,7 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) (cons "vector" t)) tmp) + (apply (lambda (t--c0a) (cons "vector" t--c0a)) tmp) (syntax-violation #f "source expression failed to match any pattern" @@ -3039,7 +3051,8 @@ (let ((tmp y)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 - (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y))) + (apply (lambda (y) + (k (map (lambda (tmp-c0a-122c) (list "quote" tmp-c0a-122c)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (if tmp-1 @@ -3048,7 +3061,8 @@ (if tmp-1 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) - (let ((tmp x)) (let ((t tmp)) (list "list->vector" t))))))))))))))))) + (let ((tmp x)) + (let ((t--c0a-123b tmp)) (list "list->vector" t--c0a-123b))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3061,7 +3075,8 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t)) + (apply (lambda (t--c0a-124a) + (cons '#(syntax-object list ((top)) (hygiene guile)) t--c0a-124a)) tmp) (syntax-violation #f @@ -3077,8 +3092,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-1 t) - (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t)) + (apply (lambda (t--c0a-125e t--c0a-125d) + (list '#(syntax-object cons ((top)) (hygiene guile)) + t--c0a-125e + t--c0a-125d)) tmp) (syntax-violation #f @@ -3091,8 +3108,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) - (cons '#(syntax-object append ((top)) (hygiene guile)) t)) + (apply (lambda (t--c0a-126a) + (cons '#(syntax-object append ((top)) (hygiene guile)) + t--c0a-126a)) tmp) (syntax-violation #f @@ -3105,8 +3123,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) - (cons '#(syntax-object vector ((top)) (hygiene guile)) t)) + (apply (lambda (t--c0a) + (cons '#(syntax-object vector ((top)) (hygiene guile)) + t--c0a)) tmp) (syntax-violation #f @@ -3117,8 +3136,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t tmp)) - (list '#(syntax-object list->vector ((top)) (hygiene guile)) t)))) + (let ((t--c0a tmp)) + (list '#(syntax-object list->vector ((top)) (hygiene guile)) + t--c0a)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 7d12469..13e15be 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,7 +1,7 @@ ;;;; -*-scheme-*- ;;;; ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, -;;;; 2012, 2013 Free Software Foundation, Inc. +;;;; 2012, 2013, 2016 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -460,9 +460,10 @@ (make-letrec src in-order? ids vars val-exps body-exp))))) - ;; FIXME: use a faster gensym (define-syntax-rule (build-lexical-var src id) - (gensym (string-append (symbol->string id) "-"))) + ;; Use a per-module counter instead of the global counter of + ;; 'gensym' so that the generated identifier is reproducible. + (module-gensym (symbol->string id))) (define-structure (syntax-object expression wrap module)) @@ -2598,7 +2599,9 @@ (lambda (ls) (arg-check list? ls 'generate-temporaries) (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls)))) + (map (lambda (x) + (wrap (module-gensym "t-") top-wrap mod)) + ls)))) (set! free-identifier=? (lambda (x y) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 60c87e3..23d37a8 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -1,6 +1,6 @@ ;;; transformation of letrec into simpler forms -;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2016 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -267,7 +267,9 @@ ;; bindings, in a `let' to indicate that order doesn't ;; matter, and bind to their variables. (list - (let ((tmps (map (lambda (x) (gensym)) c))) + (let ((tmps (map (lambda (x) + (module-gensym "fixlr")) + c))) (make-let #f (map cadr c) tmps (map caddr c) (make-sequence diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 249961d..d280869 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,6 +1,6 @@ ;;; Guile VM specific syntaxes and utilities -;; Copyright (C) 2001, 2009 Free Software Foundation, Inc +;; Copyright (C) 2001, 2009, 2016 Free Software Foundation, Inc ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -72,7 +72,7 @@ '() (cons (car slots) (lp (cdr slots)))))) (opts (list-tail slots (length reqs))) - (tail (gensym))) + (tail (module-gensym "defrec"))) `(define (,(symbol-append 'make- stem) ,@reqs . ,tail) (let ,(map (lambda (o) `(,(car o) (cond ((null? ,tail) ,(cadr o)) @@ -243,8 +243,8 @@ ;; code looks good. (define-macro (transform-record type-and-common record . clauses) - (let ((r (gensym)) - (rtd (gensym)) + (let ((r (module-gensym "rec")) + (rtd (module-gensym "rtd")) (type-stem (trim-brackets (car type-and-common)))) (define (make-stem s) (symbol-append type-stem '- s)) --=-=-=--