From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.bugs Subject: bug#33036: Bug with the procedure nil? inside a specific code Date: Thu, 18 Oct 2018 14:33:55 +0200 Message-ID: <87efcno2mk.fsf@pobox.com> References: <2cf0a45c-e973-79f5-6ab8-6794a68495d0@disroot.org> <87va65uyb3.fsf@netris.org> <87r2gtuq9q.fsf@netris.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1539865992 19043 195.159.176.226 (18 Oct 2018 12:33:12 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Thu, 18 Oct 2018 12:33:12 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.1 (gnu/linux) Cc: calcium , 33036@debbugs.gnu.org To: Mark H Weaver Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Thu Oct 18 14:33:08 2018 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 1gD7UA-0004q8-DL for guile-bugs@m.gmane.org; Thu, 18 Oct 2018 14:33:08 +0200 Original-Received: from localhost ([::1]:42125 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gD7WG-00039c-Un for guile-bugs@m.gmane.org; Thu, 18 Oct 2018 08:35:16 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:57759) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gD7W8-00037Q-Rl for bug-guile@gnu.org; Thu, 18 Oct 2018 08:35:10 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gD7W2-0006hJ-Uu for bug-guile@gnu.org; Thu, 18 Oct 2018 08:35:08 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:51954) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gD7W2-0006fr-9f for bug-guile@gnu.org; Thu, 18 Oct 2018 08:35:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gD7W2-0000pW-5i for bug-guile@gnu.org; Thu, 18 Oct 2018 08:35:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Andy Wingo Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Thu, 18 Oct 2018 12:35:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33036 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 33036-submit@debbugs.gnu.org id=B33036.15398660653138 (code B ref 33036); Thu, 18 Oct 2018 12:35:02 +0000 Original-Received: (at 33036) by debbugs.gnu.org; 18 Oct 2018 12:34:25 +0000 Original-Received: from localhost ([127.0.0.1]:56212 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gD7VQ-0000oX-Su for submit@debbugs.gnu.org; Thu, 18 Oct 2018 08:34:25 -0400 Original-Received: from fanzine.igalia.com ([91.117.99.155]:54057) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gD7VN-0000oH-J4 for 33036@debbugs.gnu.org; Thu, 18 Oct 2018 08:34:22 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=igalia.com; s=20170329; h=Content-Type:MIME-Version:Message-ID:In-Reply-To:Date:References:Subject:Cc:To:From; bh=xYYP3HT6QGZPqozgWtbzJK4QorvR2KLTPtKRDZEM5cQ=; b=C9KGHOMnl6AbTUNJdaQyO0p4Y5hflmjamy9iv7/gMo3Zub8c0ACz5MNafIk2ONGtlY7P4D8Me71UMJIpOrwWjS+POubgMTMugxgCYd0ey56dg7CAbsFpuHBgBfO+kxN9OO1CeZo48a9ojTiodggn+h8WTeCCK2hctIeDapouIW22+MQs/k79NxqLUT11LxdRWYeR+s4So5Vx5EOwE7ac0oADYngaGLZkSVeiFoe9kdy1rcQkXIWvQFCAqXRjtl9QZICze+22yNKR61vVCMrejTDeKJ14QoRchIsHOVbhL0XQP7MFIHvwpa3kzNj6tfnibTxzcWo87cGhaxS922RZig==; Original-Received: from dhcp-25-3.ripemtg.ripe.net ([193.0.25.3] helo=sparrow) by fanzine.igalia.com with esmtpsa (Cipher TLS1.0:ECDHE_RSA_AES_256_CBC_SHA1:256) (Exim) id 1gD7VG-0002VT-5N; Thu, 18 Oct 2018 14:34:14 +0200 In-Reply-To: <87r2gtuq9q.fsf@netris.org> (Mark H. Weaver's message of "Sun, 14 Oct 2018 00:05:21 -0400") 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:9211 Archived-At: Hi! Thank you, Mark! That looks great. I note also that this is fixed in master, unless I made another bug. See type-fold.scm:66-87 and types.scm:574-617. Cheers! Andy On Sun 14 Oct 2018 06:05, Mark H Weaver writes: > Mark H Weaver writes: > >> calcium writes: >>> Here is the bug that I found : >>> >>> ;;; -START- code with the bug -START- ;;; >>> >>> (define (strange lst) >>> (let loop ((lst lst) >>> (is-empty '())) >>> (cond ((nil? lst) >>> (if (nil? is-empty) 'works >>> (list 'should-not-occur is-empty))) >>> (else >>> (loop (cdr lst) >>> is-empty))))) >>> >>> (strange '()) >>> => (should-not-occur ()) >>> >>> (strange #nil) >>> => (should-not-occur ()) >> >> Indeed, this certainly indicates a bug. >> >> I believe the bug is in 'local-type-fold' in (language cps type-fold). >> It contains a local procedure 'scalar-value' which, if I understand >> correctly, seems to incorrectly assume that (nil? x) returns #t if and >> only if X is 'eq?' to #nil. > > The bug actually wasn't in 'local-type-fold', but it's true that the > type inferencer assumed in a few places that if (nil? X) returned #t > that X must be #nil, and similarly for 'null?' and (). > > I've attached a proposed fix. > > Andy, does this fix look right to you? > > Thanks, > Mark > > > From d904d5233582e51a4be06d2c08ccdd15a66b8d77 Mon Sep 17 00:00:00 2001 > From: Mark H Weaver > Date: Sat, 13 Oct 2018 23:02:05 -0400 > Subject: [PATCH] Fix type inferencing for 'nil?' and 'null?' predicates. > > Fixes . > Reported by . > > * module/language/cps/types.scm (define-simple-type-inferrer): > Apply (logand (&type val) <>) uniformly. Previously, this was done only > in the false branch. Rename local variable to 'type*', to allow the > macro operand 'type' to be an arbitrary expression. > (*type-inferrers*): Add &nil to the set of possible types. > (*type-inferrers*): Add &false and &null to the set the possible > types. > * module/language/cps/type-fold.scm (*branch-folders*): Add &nil > to the set of possible types. > (*branch-folders*): Add &false and &null to the set the possible > types. > * test-suite/tests/compiler.test: Add tests. > --- > module/language/cps/type-fold.scm | 6 ++-- > module/language/cps/types.scm | 13 ++++---- > test-suite/tests/compiler.test | 51 ++++++++++++++++++++++++++++++- > 3 files changed, 60 insertions(+), 10 deletions(-) > > diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm > index fc37fac50..163ef659d 100644 > --- a/module/language/cps/type-fold.scm > +++ b/module/language/cps/type-fold.scm > @@ -1,5 +1,5 @@ > ;;; Abstract constant folding on CPS > -;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. > +;;; Copyright (C) 2014, 2015, 2018 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 License as > @@ -69,8 +69,8 @@ > > ;; All the cases that are in compile-bytecode. > (define-unary-type-predicate-folder pair? &pair) > -(define-unary-type-predicate-folder null? &null) > -(define-unary-type-predicate-folder nil? &nil) > +(define-unary-type-predicate-folder null? (logior &nil &null)) > +(define-unary-type-predicate-folder nil? (logior &false &nil &null)) > (define-unary-type-predicate-folder symbol? &symbol) > (define-unary-type-predicate-folder variable? &box) > (define-unary-type-predicate-folder vector? &vector) > diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm > index 5c1d71299..61de971fe 100644 > --- a/module/language/cps/types.scm > +++ b/module/language/cps/types.scm > @@ -529,13 +529,14 @@ minimum, and maximum." > > (define-syntax-rule (define-simple-predicate-inferrer predicate type) > (define-predicate-inferrer (predicate val true?) > - (let ((type (if true? > - type > - (logand (&type val) (lognot type))))) > - (restrict! val type -inf.0 +inf.0)))) > + (let ((type* (logand (&type val) > + (if true? > + type > + (lognot type))))) > + (restrict! val type* -inf.0 +inf.0)))) > (define-simple-predicate-inferrer pair? &pair) > -(define-simple-predicate-inferrer null? &null) > -(define-simple-predicate-inferrer nil? &nil) > +(define-simple-predicate-inferrer null? (logior &nil &null)) > +(define-simple-predicate-inferrer nil? (logior &false &nil &null)) > (define-simple-predicate-inferrer symbol? &symbol) > (define-simple-predicate-inferrer variable? &box) > (define-simple-predicate-inferrer vector? &vector) > diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test > index 4f644f339..64bb976fa 100644 > --- a/test-suite/tests/compiler.test > +++ b/test-suite/tests/compiler.test > @@ -1,5 +1,5 @@ > ;;;; compiler.test --- tests for the compiler -*- scheme -*- > -;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. > +;;;; Copyright (C) 2008-2014, 2018 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 > @@ -251,3 +251,52 @@ > > (pass-if-equal "test flonum" 0.0 (test-proc #t)) > (pass-if-equal "test complex" 0.0+0.0i (test-proc #f))) > + > +(with-test-prefix "null? and nil? inference" > + (pass-if-equal "nil? after null?" > + '((f . f) ; 3 > + (f . f) ; #t > + (f . t) ; #f > + (t . t) ; #nil > + (t . t)) ; () > + (map (compile '(lambda (x) > + (if (null? x) > + (cons 't (if (nil? x) 't 'f)) > + (cons 'f (if (nil? x) 't 'f))))) > + '(3 #t #f #nil ()))) > + > + (pass-if-equal "nil? after truth test" > + '((t . f) ; 3 > + (t . f) ; #t > + (f . t) ; #f > + (f . t) ; #nil > + (t . t)) ; () > + (map (compile '(lambda (x) > + (if x > + (cons 't (if (nil? x) 't 'f)) > + (cons 'f (if (nil? x) 't 'f))))) > + '(3 #t #f #nil ()))) > + > + (pass-if-equal "null? after nil?" > + '((f . f) ; 3 > + (f . f) ; #t > + (t . f) ; #f > + (t . t) ; #nil > + (t . t)) ; () > + (map (compile '(lambda (x) > + (if (nil? x) > + (cons 't (if (null? x) 't 'f)) > + (cons 'f (if (null? x) 't 'f))))) > + '(3 #t #f #nil ()))) > + > + (pass-if-equal "truth test after nil?" > + '((f . t) ; 3 > + (f . t) ; #t > + (t . f) ; #f > + (t . f) ; #nil > + (t . t)) ; () > + (map (compile '(lambda (x) > + (if (nil? x) > + (cons 't (if x 't 'f)) > + (cons 'f (if x 't 'f))))) > + '(3 #t #f #nil ()))))