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 <ludo@gnu.org> 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’.
>
>
>
>