bug#31594: Code causes guild compile to hang

[Mark H Weaver]

Hi,

Tommi Höynälänmaa <address@hidden> writes:

> The following code causes command "guild compile" to hang:
> ---cut here---
> (define (select-nearest-methods binder
>                 index v-fixed-args v-rest-arg vb-included)
>   (dwl4 "select-nearest-methods")
>   (assert (is-binder? binder))
>   (let ((n (vector-length vb-included)))
>     (do ((i 0 (+ i 1))) ((>= i n))
>       (if (vector-ref vb-included i)
>       (let ((t1 (get-item-at-index
>              (vector-ref v-fixed-args i)
>              (vector-ref v-rest-arg i)
>              index)))
>         (do ((j 0 (+ j 1))) ((>= j n))
>           (if (and (not (= i j))
>                (vector-ref vb-included j))
>           (let ((t2 (get-item-at-index
>                  (vector-ref v-fixed-args j)
>                  (vector-ref v-rest-arg j)
>                  index)))
>             (if (is-t-subtype? binder t1 t2)
>             ;; t2 is excluded
>             (vector-set! vb-included j #f))))))))))
> ---cut here---

I can reproduce this with Guile-2.2.3 on my system running GuixSD.
Simply pasting the above code into a pristine Guile REPL causes it to
hang.  I'm able to compile it to cps, but compiling it to bytecode gets
stuck in what appears to be an infinite loop in 'specialize-operations'
in (language cps specialize-numbers).

The backtrace printer also gets stuck in a loop while trying to print
one of the stack frames in (language cps specialize-numbers).

See below for a transcript.

Thanks for the report.  To be continued...

     Mark


--8<---------------cut here---------------start------------->8---
GNU Guile 2.2.3
Copyright (C) 1995-2017 Free Software Foundation, Inc.

Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.

Enter `,help' for help.
scheme@(guile-user)> (define (select-nearest-methods binder
                index v-fixed-args v-rest-arg vb-included)
  (dwl4 "select-nearest-methods")
  (assert (is-binder? binder))
  (let ((n (vector-length vb-included)))
    (do ((i 0 (+ i 1))) ((>= i n))
      (if (vector-ref vb-included i)
      (let ((t1 (get-item-at-index
             (vector-ref v-fixed-args i)
             (vector-ref v-rest-arg i)
             index)))
        (do ((j 0 (+ j 1))) ((>= j n))
          (if (and (not (= i j))
               (vector-ref vb-included j))
          (let ((t2 (get-item-at-index
                 (vector-ref v-fixed-args j)
                 (vector-ref v-rest-arg j)
                 index)))
            (if (is-t-subtype? binder t1 t2)
            ;; t2 is excluded
            (vector-set! vb-included j #f))))))))))

;;; <stdin>:6:2: warning: possibly unbound variable `dwl4'
;;; <stdin>:7:2: warning: possibly unbound variable `assert'
;;; <stdin>:7:10: warning: possibly unbound variable `is-binder?'
;;; <stdin>:11:16: warning: possibly unbound variable `get-item-at-index'
;;; <stdin>:18:20: warning: possibly unbound variable `get-item-at-index'
;;; <stdin>:22:16: warning: possibly unbound variable `is-t-subtype?'
While compiling expression:
User interrupt
scheme@(guile-user)> ,use (system base compile)
scheme@(guile-user)> (define code '(define (select-nearest-methods binder
                index v-fixed-args v-rest-arg vb-included)
  (dwl4 "select-nearest-methods")
  (assert (is-binder? binder))
  (let ((n (vector-length vb-included)))
    (do ((i 0 (+ i 1))) ((>= i n))
      (if (vector-ref vb-included i)
      (let ((t1 (get-item-at-index
             (vector-ref v-fixed-args i)
             (vector-ref v-rest-arg i)
             index)))
        (do ((j 0 (+ j 1))) ((>= j n))
          (if (and (not (= i j))
               (vector-ref vb-included j))
          (let ((t2 (get-item-at-index
                 (vector-ref v-fixed-args j)
                 (vector-ref v-rest-arg j)
                 index)))
            (if (is-t-subtype? binder t1 t2)
            ;; t2 is excluded
            (vector-set! vb-included j #f)))))))))))
scheme@(guile-user)> ,pp code
$2 = (define (select-nearest-methods
         binder
         index
         v-fixed-args
         v-rest-arg
         vb-included)
  (dwl4 "select-nearest-methods")
  (assert (is-binder? binder))
  (let ((n (vector-length vb-included)))
    (do ((i 0 (+ i 1)))
        ((>= i n))
      (if (vector-ref vb-included i)
        (let ((t1 (get-item-at-index
                    (vector-ref v-fixed-args i)
                    (vector-ref v-rest-arg i)
                    index)))
          (do ((j 0 (+ j 1)))
              ((>= j n))
            (if (and (not (= i j)) (vector-ref vb-included j))
              (let ((t2 (get-item-at-index
                          (vector-ref v-fixed-args j)
                          (vector-ref v-rest-arg j)
                          index)))
                (if (is-t-subtype? binder t1 t2)
                  (vector-set! vb-included j #f))))))))))
scheme@(guile-user)> (define v (compile code #:from 'scheme #:to 'cps))
scheme@(guile-user)> v
$3 = #<intmap 0-122>
scheme@(guile-user)> (define intmap->alist (@@ (language cps intmap) 
intmap->alist))
scheme@(guile-user)> ,pp (intmap->alist v)
$4 = ((0 . #<cps (kfun () 0 1 122)>)
 (1 . #<cps (ktail)>)
 (2 . #<cps (kargs (unspecified) (14) (continue 1 (values 14)))>)
 (3 . #<cps (kargs () () (continue 2 (unspecified)))>)
 (4 . #<cps (kargs (box) (15) (continue 3 (primcall box-set! 15 13)))>)
 (5 . #<cps (kargs (name) (16) (continue 4 (primcall define! 16)))>)
 (6 . #<cps (kargs (arg) (13) (continue 5 (const select-nearest-methods)))>)
 (7 . #<cps (ktail)>)
 (8 . #<cps (kargs (arg) (18) (continue 7 (call 7 18)))>)
 (9 . #<cps (kargs (loop) (7) (continue 8 (const 0)))>)
 (10 . #<cps (ktail)>)
 (11 . #<cps (kargs (val) (20) (continue 10 (values 20)))>)
 (12 . #<cps (kargs (arg) (21) (continue 10 (call 7 21)))>)
 (13 . #<cps (kargs (arg) (22) (continue 12 (primcall add 8 22)))>)
 (14 . #<cps (kargs (vals) (23) (continue 13 (const 1)))>)
 (15 . #<cps (kreceive () vals 14)>)
 (16 . #<cps (kargs (arg) (24) (continue 15 (call 10 24)))>)
 (17 . #<cps (kargs (loop) (10) (continue 16 (const 0)))>)
 (18 . #<cps (ktail)>)
 (19 . #<cps (kargs (val) (26) (continue 18 (values 26)))>)
 (20 . #<cps (kargs (arg) (27) (continue 18 (call 10 27)))>)
 (21 . #<cps (kargs (arg) (28) (continue 20 (primcall add 11 28)))>)
 (22 . #<cps (kargs (vals) (29) (continue 21 (const 1)))>)
 (23 . #<cps (kreceive () vals 22)>)
 (24 . #<cps (kargs () () (continue 22 (const ())))>)
 (25 . #<cps (kargs (unboxed) (31) (continue 24 (primcall vector-set! 1 31 
30)))>)
 (26 . #<cps (kargs (arg) (30) (continue 25 (primcall scm->u64 11)))>)
 (27 . #<cps (kargs (nil) (33) (continue 22 (primcall cons 32 33)))>)
 (28 . #<cps (kargs (val) (32) (continue 27 (const ())))>)
 (29 . #<cps (kargs () () (continue 26 (const #f)))>)
 (30 . #<cps (kargs () () (continue 28 (unspecified)))>)
 (31 . #<cps (kargs (arg rest) (34 35) (continue 30 (branch 29 (values 34))))>)
 (32 . #<cps (kreceive (arg) rest 31)>)
 (33 . #<cps (kargs (arg) (36) (continue 32 (call 36 5 9 12)))>)
 (34 . #<cps (kargs (box) (37) (continue 33 (primcall box-ref 37)))>)
 (35 . #<cps (kargs (scope) (40) (continue 34 (primcall cached-toplevel-box 40 
38 39)))>)
 (36 . #<cps (kargs (bound?) (39) (continue 35 (const 0)))>)
 (37 . #<cps (kargs (name) (38) (continue 36 (const #t)))>)
 (38 . #<cps (kargs (t2 rest) (12 41) (continue 37 (const is-t-subtype?)))>)
 (39 . #<cps (kreceive (t2) rest 38)>)
 (40 . #<cps (kargs (arg) (44) (continue 39 (call 42 43 44 4)))>)
 (41 . #<cps (kargs (unboxed) (45) (continue 40 (primcall vector-ref 2 45)))>)
 (42 . #<cps (kargs (arg) (43) (continue 41 (primcall scm->u64 11)))>)
 (43 . #<cps (kargs (unboxed) (46) (continue 42 (primcall vector-ref 3 46)))>)
 (44 . #<cps (kargs (arg) (42) (continue 43 (primcall scm->u64 11)))>)
 (45 . #<cps (kargs (box) (47) (continue 44 (primcall box-ref 47)))>)
 (46 . #<cps (kargs (scope) (50) (continue 45 (primcall cached-toplevel-box 50 
48 49)))>)
 (47 . #<cps (kargs (bound?) (49) (continue 46 (const 0)))>)
 (48 . #<cps (kargs (name) (48) (continue 47 (const #t)))>)
 (49 . #<cps (kargs () () (continue 48 (const get-item-at-index)))>)
 (50 . #<cps (kargs (nil) (52) (continue 22 (primcall cons 51 52)))>)
 (51 . #<cps (kargs (val) (51) (continue 50 (const ())))>)
 (52 . #<cps (kargs () () (continue 49 (rec)))>)
 (53 . #<cps (kargs () () (continue 51 (unspecified)))>)
 (54 . #<cps (kargs (arg) (53) (continue 53 (branch 52 (values 53))))>)
 (55 . #<cps (kargs (arg) (54) (continue 53 (branch 52 (values 54))))>)
 (56 . #<cps (kargs (unboxed) (55) (continue 55 (primcall vector-ref 1 55)))>)
 (57 . #<cps (kargs () () (continue 54 (const #f)))>)
 (58 . #<cps (kargs () () (continue 56 (primcall scm->u64 11)))>)
 (59 . #<cps (kargs () () (continue 19 (unspecified)))>)
 (60 . #<cps (kargs () () (continue 58 (branch 57 (primcall = 8 11))))>)
 (61 . #<cps (kargs (j) (11) (continue 60 (branch 59 (primcall >= 11 6))))>)
 (62 . #<cps (kclause ((j) () #f () #f) 61)>)
 (63 . #<cps (kfun ((name . loop)) 25 18 62)>)
 (64 . #<cps (kargs (nil) (57) (continue 14 (primcall cons 56 57)))>)
 (65 . #<cps (kargs (val) (56) (continue 64 (const ())))>)
 (66 . #<cps (kargs (t1 rest) (9 58) (continue 17 (rec (loop 10 (fun 63)))))>)
 (67 . #<cps (kreceive (t1) rest 66)>)
 (68 . #<cps (kargs (arg) (61) (continue 67 (call 59 60 61 4)))>)
 (69 . #<cps (kargs (unboxed) (62) (continue 68 (primcall vector-ref 2 62)))>)
 (70 . #<cps (kargs (arg) (60) (continue 69 (primcall scm->u64 8)))>)
 (71 . #<cps (kargs (unboxed) (63) (continue 70 (primcall vector-ref 3 63)))>)
 (72 . #<cps (kargs (arg) (59) (continue 71 (primcall scm->u64 8)))>)
 (73 . #<cps (kargs (box) (64) (continue 72 (primcall box-ref 64)))>)
 (74 . #<cps (kargs (scope) (67) (continue 73 (primcall cached-toplevel-box 67 
65 66)))>)
 (75 . #<cps (kargs (bound?) (66) (continue 74 (const 0)))>)
 (76 . #<cps (kargs (name) (65) (continue 75 (const #t)))>)
 (77 . #<cps (kargs () () (continue 76 (const get-item-at-index)))>)
 (78 . #<cps (kargs (nil) (69) (continue 14 (primcall cons 68 69)))>)
 (79 . #<cps (kargs (val) (68) (continue 78 (const ())))>)
 (80 . #<cps (kargs () () (continue 77 (rec)))>)
 (81 . #<cps (kargs () () (continue 79 (unspecified)))>)
 (82 . #<cps (kargs (arg) (70) (continue 81 (branch 80 (values 70))))>)
 (83 . #<cps (kargs (unboxed) (71) (continue 82 (primcall vector-ref 1 71)))>)
 (84 . #<cps (kargs () () (continue 11 (unspecified)))>)
 (85 . #<cps (kargs () () (continue 83 (primcall scm->u64 8)))>)
 (86 . #<cps (kargs (i) (8) (continue 85 (branch 84 (primcall >= 8 6))))>)
 (87 . #<cps (kclause ((i) () #f () #f) 86)>)
 (88 . #<cps (kfun ((name . loop)) 19 10 87)>)
 (89 . #<cps (kargs (val) (72) (continue 7 (values 72)))>)
 (90 . #<cps (kargs (n) (6) (continue 9 (rec (loop 7 (fun 88)))))>)
 (91 . #<cps (kargs (u64) (73) (continue 90 (primcall u64->scm 73)))>)
 (92 . #<cps (kargs () () (continue 91 (primcall vector-length 1)))>)
 (93 . #<cps (kargs (vals) (74) (continue 92 (rec)))>)
 (94 . #<cps (kreceive () vals 93)>)
 (95 . #<cps (kargs (arg rest) (76 77) (continue 94 (call 75 76)))>)
 (96 . #<cps (kreceive (arg) rest 95)>)
 (97 . #<cps (kargs (arg) (78) (continue 96 (call 78 5)))>)
 (98 . #<cps (kargs (box) (79) (continue 97 (primcall box-ref 79)))>)
 (99 . #<cps (kargs (scope) (82) (continue 98 (primcall cached-toplevel-box 82 
80 81)))>)
 (100 . #<cps (kargs (bound?) (81) (continue 99 (const 0)))>)
 (101 . #<cps (kargs (name) (80) (continue 100 (const #t)))>)
 (102 . #<cps (kargs (arg) (75) (continue 101 (const is-binder?)))>)
 (103 . #<cps (kargs (box) (83) (continue 102 (primcall box-ref 83)))>)
 (104 . #<cps (kargs (scope) (86) (continue 103 (primcall cached-toplevel-box 
86 84 85)))>)
 (105 . #<cps (kargs (bound?) (85) (continue 104 (const 0)))>)
 (106 . #<cps (kargs (name) (84) (continue 105 (const #t)))>)
 (107 . #<cps (kargs (vals) (87) (continue 106 (const assert)))>)
 (108 . #<cps (kreceive () vals 107)>)
 (109 . #<cps (kargs (arg) (89) (continue 108 (call 88 89)))>)
 (110 . #<cps (kargs (arg) (88) (continue 109 (const 
"select-nearest-methods")))>)
 (111 . #<cps (kargs (box) (90) (continue 110 (primcall box-ref 90)))>)
 (112 . #<cps (kargs (scope) (93) (continue 111 (primcall cached-toplevel-box 
93 91 92)))>)
 (113 . #<cps (kargs (bound?) (92) (continue 112 (const 0)))>)
 (114 . #<cps (kargs (name) (91) (continue 113 (const #t)))>)
 (115 . #<cps (kargs (binder index v-fixed-args v-rest-arg vb-included) (5 4 3 
2 1) (continue 114 (const dwl4)))>)
 (116 . #<cps (kclause ((binder index v-fixed-args v-rest-arg vb-included) () 
#f () #f) 115)>)
 (117 . #<cps (kfun ((name . select-nearest-methods)) 17 7 116)>)
 (118 . #<cps (kargs () () (continue 6 (fun 117)))>)
 (119 . #<cps (kargs (scope) (95) (continue 118 (primcall cache-current-module! 
94 95)))>)
 (120 . #<cps (kargs (module) (94) (continue 119 (const 0)))>)
 (121 .
  #<cps (kargs () () (continue 120 (primcall current-module)))>)
 (122 . #<cps (kclause (() () #f () #f) 121)>))
scheme@(guile-user)> (define vb (compile code #:from 'scheme #:to 'bytecode))
ERROR: In procedure scm-error:
User interrupt

Entering a new prompt.  Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile-user) [1]> ,bt
In current input:
    82:11 13 (_)
In system/base/compile.scm:
    255:6 12 (compile _ #:from _ #:to _ #:env _ #:opts _)
   183:32 11 (compile-fold _ _ _ ())
In language/cps/compile-bytecode.scm:
   609:12 10 (compile-bytecode _ #<module (#{ g767}#) 11b5460> ())
   603:12  9 (lower-cps _ _)
In language/cps/optimize.scm:
    106:0  8 (optimize-first-order-cps _ _)
In language/cps/specialize-numbers.scm:
   724:23  7 (specialize-numbers _)
   438:10  6 (specialize-operations _)
In language/cps/intmap.scm:
    521:5  5 (visit-branch #(#(#<cps (kfun () 0 12 1)> #<cps (kclause (() () #f 
() #f) 2)> #<cps (kargs () () (continue 3 (primcall current-module…> …) …) …)
    521:5  4 (visit-branch #(#<cps (kfun () 0 12 1)> #<cps (kclause (() () #f 
() #f) 2)> #<cps (kargs () () (continue 3 (primcall current-module)))> # …) …)
In language/cps/specialize-numbers.scm:
--8<---------------cut here---------------end--------------->8---