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 <[email protected]> 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’.
>
>
>
>
