From: Andy Wingo <wingo@pobox.com>
To: Mark H Weaver <mhw@netris.org>
Cc: calcium <calcium@disroot.org>, 33036@debbugs.gnu.org
Subject: bug#33036: Bug with the procedure nil? inside a specific code
Date: Thu, 18 Oct 2018 14:33:55 +0200 [thread overview]
Message-ID: <87efcno2mk.fsf@pobox.com> (raw)
In-Reply-To: <87r2gtuq9q.fsf@netris.org> (Mark H. Weaver's message of "Sun, 14 Oct 2018 00:05:21 -0400")
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 <mhw@netris.org> writes:
> Mark H Weaver <mhw@netris.org> writes:
>
>> calcium <calcium@disroot.org> 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 <mhw@netris.org>
> Date: Sat, 13 Oct 2018 23:02:05 -0400
> Subject: [PATCH] Fix type inferencing for 'nil?' and 'null?' predicates.
>
> Fixes <https://bugs.gnu.org/33036>.
> Reported by <calcium@disroot.org>.
>
> * 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*)<null?>: Add &nil to the set of possible types.
> (*type-inferrers*)<nil?>: Add &false and &null to the set the possible
> types.
> * module/language/cps/type-fold.scm (*branch-folders*)<null?>: Add &nil
> to the set of possible types.
> (*branch-folders*)<nil?>: 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 ()))))
next prev parent reply other threads:[~2018-10-18 12:33 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-10-13 16:17 bug#33036: Bug with the procedure nil? inside a specific code calcium
2018-10-14 1:11 ` Mark H Weaver
2018-10-14 4:05 ` Mark H Weaver
2018-10-18 12:33 ` Andy Wingo [this message]
2018-10-20 1:13 ` Mark H Weaver
2018-10-14 5:41 ` Mark H Weaver
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87efcno2mk.fsf@pobox.com \
--to=wingo@pobox.com \
--cc=33036@debbugs.gnu.org \
--cc=calcium@disroot.org \
--cc=mhw@netris.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).