bug#12883: [2.0.6] CSE bug

[Stefan Israelsson Tampe]

Hey, the unroll code looks really weird in find-dominating-lexical, I know it's difficult to 
just come in and propose a change, but hey it can only help :-)

With this code,

(define (find-dominating-lexical exp effects env db)
    (define (entry-matches? v1 v2)
      (match (if (vector? v1) v1 v2)
        (#(exp* name sym db)
         (tree-il=? exp exp*))
        (_ #f)))
      
    (define (unroll db base n)
      (log 'unroll db base n)                                                            ;; logging the code
      (or (zero? n)
          (and (< base (vlist-length db))
               (match (vlist-ref db base)
                 (('lambda . h*)
                  ;; See note in find-dominating-_expression_.
                  (and (not (depends-on-effects? effects &all-effects))
                       (unroll db (1+ base) (1- n))))
                 ((#(exp* effects* ctx*) . h*)
                  (and (effects-commute? effects effects*)
                       (unroll db (1+ base) (1- n))))))))

    (let ((h (tree-il-hash exp)))
      (and (effect-free? (exclude-effects effects &type-check))
           (vhash-assoc exp env entry-matches? (hasher h))
           (let ((env-len (vlist-length env))
                 (db-len (vlist-length db)))
             (let lp ((n 0) (m 0))
               (and (< n env-len)
                    (match (vlist-ref env n)
                      ((#(exp* name sym db-len*) . h*)
                       (log 'lp name db-len* n m (- db-len db-len*))              ;; logging the code
                       (let ((niter (- (- db-len db-len*) m)))                           ;; niter added here (stis)
                         (and (unroll db m niter)
                              (if (and (= h h*) (tree-il=? exp* exp))
                                  (make-lexical-ref (tree-il-src exp) name sym)
                                  (lp (1+ n) (- db-len db-len*)))))))))))))

I get the log
log lp x 20 0 0 2)

(log unroll #<vhash 1df5ee0 22 pairs> 0 2)

(log unroll #<vhash 1df5ee0 22 pairs> 1 1)

(log unroll #<vhash 1df5ee0 22 pairs> 2 0)

(log lp x 17 1 2 5)

(log unroll #<vhash 1df5ee0 22 pairs> 2 3)

(log unroll #<vhash 1df5ee0 22 pairs> 3 2)

(log unroll #<vhash 1df5ee0 22 pairs> 4 1)

(log unroll #<vhash 1df5ee0 22 pairs> 5 0)

(log lp x 14 2 5 8)

(log unroll #<vhash 1df5ee0 22 pairs> 5 3)

(log unroll #<vhash 1df5ee0 22 pairs> 6 2)

(log unroll #<vhash 1df5ee0 22 pairs> 7 1)

(log unroll #<vhash 1df5ee0 22 pairs> 8 0)

(log lp w 12 3 8 10)

(log unroll #<vhash 1df5ee0 22 pairs> 8 2)

(log unroll #<vhash 1df5ee0 22 pairs> 9 1)

(log unroll #<vhash 1df5ee0 22 pairs> 10 0)

(log lp failure 9 4 10 13)

(log unroll #<vhash 1df5ee0 22 pairs> 10 3)

(log unroll #<vhash 1df5ee0 22 pairs> 11 2)

(log unroll #<vhash 1df5ee0 22 pairs> 12 1)

(log unroll #<vhash 1df5ee0 22 pairs> 13 0)


This looks better no? am I surfing at a differnt planet?
(We could even remove the duplicate checks if we like but it's unimportant for the end result)

/Stefan

On Wed, Nov 14, 2012 at 4:26 PM, Ludovic Courtès <address@hidden> wrote:

Hello,

This piece of code triggers a CSE bug:

--8<---------------cut here---------------start------------->8---
(use-modules (ice-9 match))

(define (snix-derivation->guix-package derivation)
  (match derivation
    (((_ _ _))
     #t)))
--8<---------------cut here---------------end--------------->8---

Or just:

--8<---------------cut here---------------start------------->8---
(define (snix-derivation->guix-package v)
  (let ((failure
         (lambda ()
           (error 'match "no matching pattern"))))
    (if (and (pair? v)
             (null? (cdr v)))
        (let ((w foo)
              (x (cdr w)))
          (if (and (pair? x)
                   (null? (cdr x)))
              #t
              (failure)))
        (failure))))
--8<---------------cut here---------------end--------------->8---

Details:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user) [1]> ,bt
In geiser/evaluation.scm:
    59:13 26 (call-with-result #<procedure ev ()>)
In unknown file:
          25 (call-with-output-string #<procedure 33727c0 at ice-9/r4rs.scm:236:3 (p)>)
In ice-9/r4rs.scm:
    176:4 24 (with-output-to-port #<variable 3374bb0 value: #<output: file /dev/pts/3>> #<procedure 4725360 at geiser/evaluation…>)
In geiser/evaluation.scm:
    63:19 23 (#<procedure 4725360 at geiser/evaluation.scm:60:15 ()>)
In ice-9/r4rs.scm:
    180:4 22 (with-error-to-port #<variable 33748f0 value: #<output: file /dev/pts/3>> #<procedure 4725300 at geiser/evaluation.…>)
In geiser/evaluation.scm:
    64:45 21 (#<procedure 4725300 at geiser/evaluation.scm:64:21 ()>)
    75:21 20 (ev)
In system/base/compile.scm:
    231:6 19 (compile (define (snix-derivation->guix-package v) (let ((failure (lambda () (error (quote match) "no …")))) (…))) # …)
   177:32 18 (lp (#<procedure compile-glil (x e opts)> #<procedure compile-asm (x e opts)> #<procedure compile-bytecode (ass…> …) …)
In language/tree-il/compile-glil.scm:
     65:2 17 (compile-glil #<tree-il (define snix-derivation->guix-package (lambda ((name . snix-derivation->guix-package)) (la…> …)
In language/tree-il/optimize.scm:
     44:6 16 (optimize! #<tree-il (lambda () (lambda-case ((() #f #f #f () ()) (define snix-derivation->guix-package (lambda ((…> …)
In language/tree-il/cse.scm:
   537:31 15 (visit #<tree-il (lambda () (lambda-case ((() #f #f #f () ()) (define snix-derivation->guix-package (lambda ((name…> …)
   543:33 14 (visit #<tree-il (lambda-case ((() #f #f #f () ()) (define snix-derivation->guix-package (lambda ((name . snix-der…> …)
   483:32 13 (visit #<tree-il (define snix-derivation->guix-package (lambda ((name . snix-derivation->guix-package)) (lambda-ca…> …)
   537:31 12 (visit #<tree-il (lambda ((name . snix-derivation->guix-package)) (lambda-case (((v) #f #f #f () (v-66965)) (let (…> …)
   543:33 11 (visit #<tree-il (lambda-case (((v) #f #f #f () (v-66965)) (let (failure) (failure-66977) ((lambda () (lambda-case…> …)
   430:34 10 (visit #<tree-il (let (failure) (failure-66977) ((lambda () (lambda-case ((() #f #f #f () ()) (apply (primitive er…> …)
   496:31  9 (visit #<tree-il (if (apply (primitive pair?) (lexical v v-66965)) (if (apply (primitive null?) (apply (primitive …> …)
   496:31  8 (visit #<tree-il (if (apply (primitive null?) (apply (primitive cdr) (lexical v v-66965))) (let (x) (x-66968) ((ap…> …)
   430:34  7 (visit #<tree-il (let (x) (x-66968) ((apply (primitive cdr) (toplevel w))) (begin (toplevel foo) (let (failure) (f…> …)
   553:39  6 (lp (#<tree-il (let (failure) (failure-66973) ((lambda () (lambda-case ((() #f #f #f () ()) (apply (primitive err…>) …)
   429:33  5 (visit #<tree-il (let (failure) (failure-66973) ((lambda () (lambda-case ((() #f #f #f () ()) (apply (primitive er…> …)
   370:41  4 (lp (#<tree-il (lambda () (lambda-case ((() #f #f #f () ()) (apply (primitive error) (const match) (const "no mat…>) …)
   403:15  3 (return #<tree-il (lambda () (lambda-case ((() #f #f #f () ()) (apply (primitive error) (const match) (const "no m…> …)
   333:28  2 (find-dominating-lexical #<tree-il (lambda () (lambda-case ((() #f #f #f () ()) (apply (primitive error) (const ma…> …)
   315:10  1 (unroll #<vhash 2c63040 8 pairs> 8 1)
In ice-9/vlist.scm:
    303:8  0 (vlist-ref #<vhash 2c63040 8 pairs> 8)
scheme@(guile-user) [1]> ,locals
  Local variables:
  $11 = vlist = #<vhash 2c63040 8 pairs>
  $12 = index = 8
  $13 = index = 0
  $14 = base = #(#() #f 0 0 0)
  $15 = offset = 0
  $16 = content = #()
  $17 = offset = 0
scheme@(guile-user) [1]> ,error
ice-9/vlist.scm:303:8: In procedure vlist-ref:
ice-9/vlist.scm:303:8: Value out of range: 0
--8<---------------cut here---------------end--------------->8---

Ludo’.