Segfault when running fibc benchmark in current trunk

Segfault when running fibc benchmark in current trunk

[Juhani Rantanen]

[-- Attachment #1: Type: text/plain, Size: 703 bytes --]

Hi,

I noticed that vm is now in the trunk, so I decided to run some benchmarks
to test it for robustness. While doing this, I found a problem that seems
to be related to continuations, although guile crashes in gc. I have
attached a minimal and self-contained testcase here. Note that iterating
50 or so times is required to trigger the segfault so that is not "extra
code".

I have also found problems with other tests from the same benchmark, and
at least one of them is using call-with-current-continuation also (others
I have not looked at yet). I will report them as well, but right now I
don't have reduced testcases for them and they are likely duplicates.

Best Regards,
Juhani

[-- Attachment #2: fibc_bug.scm --]
[-- Type: application/octet-stream, Size: 1133 bytes --]

(define (run-bench name count ok? run)
  (let loop ((i count) (result '(undefined)))
    (if (< 0 i)
      (loop (- i 1) (run))
      result)))

(define (run-benchmark name count ok? run-maker . args)
  (newline)
  (let* ((run (apply run-maker args))
         (result (run-bench name count ok? run)))
    (if (not (ok? result))
      (begin
        (display "*** wrong result ***")
        (newline)
        (display "*** got: ")
        (write result)
        (newline)))))

(define (_1+ n) (+ n 1))
(define (_1- n) (- n 1))

;;; fib with peano arithmetic (using numbers) with call/cc

(define (addc x y k)
  (if (zero? y)
    (k x)
    (addc (_1+ x) (_1- y) k)))

(define (fibc x c)
  (if (zero? x)
    (c 0)
    (if (zero? (_1- x))
      (c 1)
      (addc (call-with-current-continuation (lambda (c) (fibc (_1- x) c)))
            (call-with-current-continuation (lambda (c) (fibc (_1- (_1- x)) c)))
            c))))

(define fibc-iters         50)

(define (main)
  (run-benchmark
    "fibc"
    fibc-iters
    (lambda (result) (equal? result 2584))
    (lambda (x c) (lambda () (fibc x c)))
    18
    (lambda (n) n)))
(main)

Re: Segfault when running fibc benchmark in current trunk

[Andy Wingo]

Hi Juhani,

On Fri 17 Apr 2009 02:37, "Juhani Rantanen" <misty@aj-group.net> writes:

> I noticed that vm is now in the trunk, so I decided to run some benchmarks
> to test it for robustness. While doing this, I found a problem that seems
> to be related to continuations, although guile crashes in gc.

Thanks for the test, Juhani. I can reproduce the issue here. I'll take a
look at it as soon as I can.

Cheers,

Andy
-- 
http://wingolog.org/

Re: Segfault when running fibc benchmark in current trunk

[Andy Wingo]

On Fri 17 Apr 2009 02:37, "Juhani Rantanen" <misty@aj-group.net> writes:

> I found a problem that seems to be related to continuations, although
> guile crashes in gc.

I think I fixed this problem in master. Can you try again?

> I have attached a minimal and self-contained
> testcase here.

Is this your code? I'd like to get it into Guile's test cases, but I
think we'd need copyright assignment or a disclaimer.

> I have also found problems with other tests from the same benchmark

I look forward to the next bug report :)

Cheers,

Andy
-- 
http://wingolog.org/

Re: Segfault when running fibc benchmark in current trunk

[Juhani Rantanen]

Hi,

I have a bad case of flu right now, sorry for the delay in answering.

>> I found a problem that seems to be related to continuations, although
>> guile crashes in gc.
>
> I think I fixed this problem in master. Can you try again?

Works:
guile -s fibc_bug.scm

Works:
guile-tools compile fibc_bug.scm
guile
> (load-compiled "fibc_bug.go")

Segfaults:
guile-tools compile fibc_bug.scm
guile -e "(load-compiled \"fibc_bug.go\")"

Last case is how the "bench" shell script used to run the benchmarks first..

>> I have attached a minimal and self-contained
>> testcase here.
>
> Is this your code? I'd like to get it into Guile's test cases, but I
> think we'd need copyright assignment or a disclaimer.

These benchmarks are from Gambit Scheme distribution package, located in
misc/bench.tgz . I ported these benchmarks to run in guile but other than
that, they are from several sources (Gabriel, K&R and miscellaneous). It
seems to be useful to have them around however..

>> I have also found problems with other tests from the same benchmark
>
> I look forward to the next bug report :)

These benchmarks still expose several different bugs in current mainline
(although many were fixed by your changes!) so I put my version of the
benchmarks to

http://aj-group.net/~misty/bench_misty_hack.tar.bz2

You can run all the tests (-c false leaves temporary files in sys/guile):

./bench -c false guile all

or a single test:

./bench -c false guile ctak

Ctak allocates 1.6GB of memory while running, I don't know whether it is
normal or not.

Check functions guile_comp and guile_exec in the bench script to see how
it compiles and runs the benchmarks or run it with no parameters to find
out more about them.

Best Regards,
Juhani

Re: Segfault when running fibc benchmark in current trunk

[Juhani Rantanen]

[-- Attachment #1: Type: text/plain, Size: 1038 bytes --]

> I look forward to the next bug report :)

Here are some more files that don't need the benchmark suite to run. I
also ran all of the tests with Gambit and there wasn't any errors.

Testing maze under Guile-r5rs
Compiling...
Running...
ERROR: In procedure zero?:
ERROR: Wrong type argument in position 1: #f

Testing trav2 under Guile-r5rs
Compiling...
Running...
ERROR: In procedure memoization:
ERROR: Non-list result for unquote-splicing (#(node () () 1 #f #f #f #f #f
#f ...) . #0#) in expression ((unquote-splicing (#<variable b7f5ff18
value: #<primitive-procedure cdr>> (#<variable b7f5ff48 value:
#<primitive-procedure car>> #@0+1)))).

Testing trav1 under Guile-r5rs
Compiling...
Running...

ERROR: In procedure memoization:
ERROR: Non-list result for unquote-splicing (#(node () () 1 #f #f #f #f #f
#f ...) . #0#) in expression ((unquote-splicing (#<variable b7f44f18
value: #<primitive-procedure cdr>> (#<variable b7f44f48 value:
#<primitive-procedure car>> #@0+1)))).



Best Regards,
Juhani

[-- Attachment #2: maze_bug.scm --]
[-- Type: application/octet-stream, Size: 25246 bytes --]

(define (run-bench name count ok? run)
  (let loop ((i count) (result '(undefined)))
    (if (< 0 i)
      (loop (- i 1) (run))
      result)))

(define (run-benchmark name count ok? run-maker . args)
  (newline)
  (let* ((run (apply run-maker args))
         (result (run-bench name count ok? run)))
    (if (not (ok? result))
      (begin
        (display "*** wrong result ***")
        (newline)
        (display "*** got: ")
        (write result)
        (newline)))))

(define (fatal-error . args)
  (for-each display args)
  (newline)
  (exit 1))

 (define (call-with-output-file/truncate filename proc)
   (call-with-output-file filename proc))

(define maze-iters        400)
;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.

;------------------------------------------------------------------------------
; Was file "rand.scm".

; Minimal Standard Random Number Generator
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
; better constants, as proposed by Park.
; By Ozan Yigit

;;; Rehacked by Olin 4/1995.

(define (random-state n)
  (cons n #f))

(define (rand state)
  (let ((seed (car state))
        (A 2813) ; 48271
        (M 8388607) ; 2147483647
        (Q 2787) ; 44488
        (R 2699)) ; 3399
    (let* ((hi (quotient seed Q))
           (lo (modulo seed Q))
           (test (- (* A lo) (* R hi)))
           (val (if (> test 0) test (+ test M))))
      (set-car! state val)
      val)))

(define (random-int n state)
  (modulo (rand state) n))

;------------------------------------------------------------------------------
; Was file "uf.scm".

;;; Tarjan's amortised union-find data structure.
;;; Copyright (c) 1995 by Olin Shivers.

;;; This data structure implements disjoint sets of elements.
;;; Four operations are supported. The implementation is extremely
;;; fast -- any sequence of N operations can be performed in time
;;; so close to linear it's laughable how close it is. See your
;;; intro data structures book for more. The operations are:
;;;
;;; - (base-set nelts) -> set
;;;   Returns a new set, of size NELTS.
;;;
;;; - (set-size s) -> integer
;;;   Returns the number of elements in set S.
;;;
;;; - (union! set1 set2)
;;;   Unions the two sets -- SET1 and SET2 are now considered the same set
;;;   by SET-EQUAL?.
;;;
;;; - (set-equal? set1 set2)
;;;   Returns true <==> the two sets are the same.

;;; Representation: a set is a cons cell. Every set has a "representative"
;;; cons cell, reached by chasing cdr links until we find the cons with
;;; cdr = (). Set equality is determined by comparing representatives using
;;; EQ?. A representative's car contains the number of elements in the set.

;;; The speed of the algorithm comes because when we chase links to find 
;;; representatives, we collapse links by changing all the cells in the path
;;; we followed to point directly to the representative, so that next time
;;; we walk the cdr-chain, we'll go directly to the representative in one hop.


(define (base-set nelts) (cons nelts '()))

;;; Sets are chained together through cdr links. Last guy in the chain
;;; is the root of the set.

(define (get-set-root s)
  (let lp ((r s))                       ; Find the last pair
    (let ((next (cdr r)))               ; in the list. That's
      (cond ((pair? next) (lp next))    ; the root r.

            (else
             (if (not (eq? r s))        ; Now zip down the list again,
                 (let lp ((x s))        ; changing everyone's cdr to r.
                   (let ((next (cdr x)))        
                     (cond ((not (eq? r next))
                            (set-cdr! x r)
                            (lp next))))))
             r)))))                     ; Then return r.

(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))

(define (set-size s) (car (get-set-root s)))

(define (union! s1 s2)
  (let* ((r1 (get-set-root s1))
         (r2 (get-set-root s2))
         (n1 (set-size r1))
         (n2 (set-size r2))
         (n  (+ n1 n2)))

    (cond ((> n1 n2)
           (set-cdr! r2 r1)
           (set-car! r1 n))
          (else
           (set-cdr! r1 r2)
           (set-car! r2 n)))))

;------------------------------------------------------------------------------
; Was file "maze.scm".

;;; Building mazes with union/find disjoint sets.
;;; Copyright (c) 1995 by Olin Shivers.

;;; This is the algorithmic core of the maze constructor.
;;; External dependencies:
;;; - RANDOM-INT
;;; - Union/find code
;;; - bitwise logical functions

; (define-record wall
;   owner         ; Cell that owns this wall.
;   neighbor      ; The other cell bordering this wall.
;   bit)          ; Integer -- a bit identifying this wall in OWNER's cell.

; (define-record cell
;   reachable     ; Union/find set -- all reachable cells.
;   id            ; Identifying info (e.g., the coords of the cell).
;   (walls -1)    ; A bitset telling which walls are still standing.
;   (parent #f)   ; For DFS spanning tree construction.
;   (mark #f))    ; For marking the solution path.

(define (make-wall owner neighbor bit)
  (vector 'wall owner neighbor bit))

(define (wall:owner o)          (vector-ref o 1))
(define (set-wall:owner o v)    (vector-set! o 1 v))
(define (wall:neighbor o)       (vector-ref o 2))
(define (set-wall:neighbor o v) (vector-set! o 2 v))
(define (wall:bit o)            (vector-ref o 3))
(define (set-wall:bit o v)      (vector-set! o 3 v))

(define (make-cell reachable id)
  (vector 'cell reachable id -1 #f #f))

(define (cell:reachable o)       (vector-ref o 1))
(define (set-cell:reachable o v) (vector-set! o 1 v))
(define (cell:id o)              (vector-ref o 2))
(define (set-cell:id o v)        (vector-set! o 2 v))
(define (cell:walls o)           (vector-ref o 3))
(define (set-cell:walls o v)     (vector-set! o 3 v))
(define (cell:parent o)          (vector-ref o 4))
(define (set-cell:parent o v)    (vector-set! o 4 v))
(define (cell:mark o)            (vector-ref o 5))
(define (set-cell:mark o v)      (vector-set! o 5 v))

;;; Iterates in reverse order.

(define (vector-for-each proc v)
  (let lp ((i (- (vector-length v) 1)))
    (cond ((>= i 0)
           (proc (vector-ref v i))
           (lp (- i 1))))))


;;; Randomly permute a vector.

(define (permute-vec! v random-state)
  (let lp ((i (- (vector-length v) 1)))
    (cond ((> i 1)
           (let ((elt-i (vector-ref v i))
                 (j (random-int i random-state)))       ; j in [0,i)
             (vector-set! v i (vector-ref v j))
             (vector-set! v j elt-i))
           (lp (- i 1)))))
  v)


;;; This is the core of the algorithm.

(define (dig-maze walls ncells)
  (call-with-current-continuation
    (lambda (quit)
      (vector-for-each
       (lambda (wall)                   ; For each wall,
         (let* ((c1   (wall:owner wall)) ; find the cells on
                (set1 (cell:reachable c1))

                (c2   (wall:neighbor wall)) ; each side of the wall
                (set2 (cell:reachable c2)))

           ;; If there is no path from c1 to c2, knock down the
           ;; wall and union the two sets of reachable cells.
           ;; If the new set of reachable cells is the whole set
           ;; of cells, quit.
           (if (not (set-equal? set1 set2))
               (let ((walls (cell:walls c1))    
                     (wall-mask (bitwise-not (wall:bit wall))))
                 (union! set1 set2)
                 (set-cell:walls c1 (bitwise-and walls wall-mask))
                 (if (= (set-size set1) ncells) (quit #f))))))
       walls))))


;;; Some simple DFS routines useful for determining path length 
;;; through the maze.

;;; Build a DFS tree from ROOT. 
;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
;;; We assume there are no loops in the maze; if this is incorrect, the
;;; algorithm will diverge.

(define (dfs-maze maze root do-children)
  (let search ((node root) (parent #f))
    (set-cell:parent node parent)
    (do-children (lambda (child)
                   (if (not (eq? child parent))
                       (search child node)))
                 maze node)))

;;; Move the root to NEW-ROOT.

(define (reroot-maze new-root)
  (let lp ((node new-root) (new-parent #f))
    (let ((old-parent (cell:parent node)))
      (set-cell:parent node new-parent)
      (if old-parent (lp old-parent node)))))

;;; How far from CELL to the root?

(define (path-length cell)
  (do ((len 0 (+ len 1))
       (node (cell:parent cell) (cell:parent node)))
      ((not node) len)))

;;; Mark the nodes from NODE back to root. Used to mark the winning path.

(define (mark-path node)
  (let lp ((node node))
    (set-cell:mark node #t)
    (cond ((cell:parent node) => lp))))

;------------------------------------------------------------------------------
; Was file "harr.scm".

;;; Hex arrays
;;; Copyright (c) 1995 by Olin Shivers.

;;; External dependencies:
;;; - define-record

;;;        ___       ___       ___
;;;       /   \     /   \     /   \
;;;   ___/  A  \___/  A  \___/  A  \___
;;;  /   \     /   \     /   \     /   \
;;; /  A  \___/  A  \___/  A  \___/  A  \
;;; \     /   \     /   \     /   \     /
;;;  \___/     \___/     \___/     \___/
;;;  /   \     /   \     /   \     /   \
;;; /     \___/     \___/     \___/     \
;;; \     /   \     /   \     /   \     /
;;;  \___/     \___/     \___/     \___/
;;;  /   \     /   \     /   \     /   \
;;; /     \___/     \___/     \___/     \
;;; \     /   \     /   \     /   \     /
;;;  \___/     \___/     \___/     \___/

;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
;;; element. Hexes are three wide and two high; e.g., to get from the center
;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
;;; respectively.
;;;
;;; Hex arrays are represented with a matrix, essentially made by shoving the
;;; odd columns down a half-cell so things line up. The mapping is as follows:
;;;     Center coord      row/column
;;;     ------------      ----------
;;;     (x,  y)        -> (y/2, x/3)
;;;     (3c, 2r + c&1) <- (r,   c)


; (define-record harr
;   nrows
;   ncols
;   elts)

(define (make-harr nrows ncols elts)
  (vector 'harr nrows ncols elts))

(define (harr:nrows o)       (vector-ref o 1))
(define (set-harr:nrows o v) (vector-set! o 1 v))
(define (harr:ncols o)       (vector-ref o 2))
(define (set-harr:ncols o v) (vector-set! o 2 v))
(define (harr:elts o)        (vector-ref o 3))
(define (set-harr:elts o v)  (vector-set! o 3 v))

(define (harr r c)
  (make-harr r c (make-vector (* r c))))



(define (href ha x y)
  (let ((r (quotient y 2))
        (c (quotient x 3)))
    (vector-ref (harr:elts ha)
                (+ (* (harr:ncols ha) r) c))))

(define (hset! ha x y val)
  (let ((r (quotient y 2))
        (c (quotient x 3)))
    (vector-set! (harr:elts ha)
                 (+ (* (harr:ncols ha) r) c)
                 val)))

(define (href/rc ha r c)
    (vector-ref (harr:elts ha)
                (+ (* (harr:ncols ha) r) c)))

;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
;;; is the value returned by (PROC x y).

(define (harr-tabulate nrows ncols proc)
  (let ((v (make-vector (* nrows ncols))))

    (do ((r (- nrows 1) (- r 1)))
        ((< r 0))
      (do ((c 0 (+ c 1))
           (i (* r ncols) (+ i 1)))
          ((= c ncols))
        (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))

    (make-harr nrows ncols v)))


(define (harr-for-each proc harr)
  (vector-for-each proc (harr:elts harr)))

;------------------------------------------------------------------------------
; Was file "hex.scm".

;;; Hexagonal hackery for maze generation.
;;; Copyright (c) 1995 by Olin Shivers.

;;; External dependencies:
;;; - cell and wall records
;;; - Functional Postscript for HEXES->PATH
;;; - logical functions for bit hacking
;;; - hex array code.

;;; To have the maze span (0,0) to (1,1):
;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
;;;        (translate (point 2 1) maze))

;;; Every elt of the hex array manages his SW, S, and SE wall.
;;; Terminology: - An even column is one whose column index is even. That
;;;                means the first, third, ... columns (indices 0, 2, ...).
;;;              - An odd column is one whose column index is odd. That
;;;                means the second, fourth... columns (indices 1, 3, ...).
;;;              The even/odd flip-flop is confusing; be careful to keep it
;;;              straight. The *even* columns are the low ones. The *odd*
;;;              columns are the high ones.
;;;    _   _
;;;  _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;;  0 1 2 3

(define south-west 1)
(define south      2)
(define south-east 4)

(define (gen-maze-array r c)
  (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))

;;; This could be made more efficient.
(define (make-wall-vec harr)
  (let* ((nrows (harr:nrows harr))
         (ncols (harr:ncols harr))
         (xmax (* 3 (- ncols 1)))

         ;; Accumulate walls.
         (walls '())
         (add-wall (lambda (o n b) ; owner neighbor bit
                     (set! walls (cons (make-wall o n b) walls)))))
        
    ;; Do everything but the bottom row.
    (do ((x (* (- ncols 1) 3) (- x 3)))
        ((< x 0))
      (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
              (- y 2)))
          ((<= y 1))    ; Don't do bottom row.
          (let ((hex (href harr x y)))
            (if (not (zero? x))
                (add-wall hex (href harr (- x 3) (- y 1)) south-west))
            (add-wall hex (href harr x (- y 2)) south)
            (if (< x xmax)
                (add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))

    ;; Do the SE and SW walls of the odd columns on the bottom row.
    ;; If the rightmost bottom hex lies in an odd column, however,
    ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
    (if (> ncols 1)
        (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
          ;; Do rightmost odd col.
          (let ((rmoc-hex (href harr rmoc-x 1)))
            (if (< rmoc-x xmax) ; Not  a corner -- do E wall.
                (add-wall rmoc-hex (href harr xmax 0) south-east))
            (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))

          (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
                  (- x 6)))
              ((< x 3)) ; 3 is X coord of leftmost odd column.
            (add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
            (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))

    (list->vector walls)))


;;; Find the cell ctop from the top row, and the cell cbot from the bottom
;;; row such that cbot is furthest from ctop. 
;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].

(define (pick-entrances harr)
  (dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
  (let ((nrows (harr:nrows harr))
        (ncols (harr:ncols harr)))
    (let tp-lp ((max-len -1)
                (entrance #f)
                (exit #f)
                (tcol (- ncols 1)))
      (if (< tcol 0) (vector entrance exit)
          (let ((top-cell (href/rc harr (- nrows 1) tcol)))
            (reroot-maze top-cell)
            (let ((result
                    (let bt-lp ((max-len max-len)
                                (entrance entrance)
                                (exit exit)
                                (bcol (- ncols 1)))
;                     (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
                      (if (< bcol 0) (vector max-len entrance exit)
                          (let ((this-len (path-length (href/rc harr 0 bcol))))
                            (if (> this-len max-len)
                                (bt-lp this-len tcol bcol (- bcol 1))
                                (bt-lp max-len  entrance exit (- bcol 1))))))))
              (let ((max-len (vector-ref result 0))
                    (entrance (vector-ref result 1))
                    (exit (vector-ref result 2)))
                (tp-lp max-len entrance exit (- tcol 1)))))))))
                


;;; Apply PROC to each node reachable from CELL.
(define (for-each-hex-child proc harr cell)
  (let* ((walls (cell:walls cell))
         (id (cell:id cell))
         (x (car id))
         (y (cdr id))
         (nr (harr:nrows harr))
         (nc (harr:ncols harr))
         (maxy (* 2 (- nr 1)))
         (maxx (* 3 (- nc 1))))
    (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
    (if (not (bit-test walls south))      (proc (href harr x       (- y 2))))
    (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))

    ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
    (if (and (> x 0)    ; Not in first column.
             (or (<= y maxy)            ; Not on top row or
                 (zero? (modulo x 6)))) ; not in an odd column.
        (let ((nw (href harr (- x 3) (+ y 1))))
          (if (not (bit-test (cell:walls nw) south-east)) (proc nw))))

    ;; N neighbor, if there is one (we may be on top row).
    (if (< y maxy)              ; Not on top row
        (let ((n (href harr x (+ y 2))))
          (if (not (bit-test (cell:walls n) south)) (proc n))))

    ;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
    (if (and (< x maxx) ; Not in last column.
             (or (<= y maxy)            ; Not on top row or
                 (zero? (modulo x 6)))) ; not in an odd column.
        (let ((ne (href harr (+ x 3) (+ y 1))))
          (if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))



;;; The top-level
(define (make-maze nrows ncols)
  (let* ((cells (gen-maze-array nrows ncols))
         (walls (permute-vec! (make-wall-vec cells) (random-state 20))))
    (dig-maze walls (* nrows ncols))
    (let ((result (pick-entrances cells)))
      (let ((entrance (vector-ref result 0))
            (exit (vector-ref result 1)))
        (let* ((exit-cell (href/rc cells 0 exit))
               (walls (cell:walls exit-cell)))
          (reroot-maze (href/rc cells (- nrows 1) entrance))
          (mark-path exit-cell)
          (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
          (vector cells entrance exit))))))


(define (pmaze nrows ncols)
  (let ((result (make-maze nrows ncols)))
    (let ((cells (vector-ref result 0))
          (entrance (vector-ref result 1))
          (exit (vector-ref result 2)))
      (print-hexmaze cells entrance))))

;------------------------------------------------------------------------------
; Was file "hexprint.scm".

;;; Print out a hex array with characters.
;;; Copyright (c) 1995 by Olin Shivers.

;;; External dependencies:
;;; - hex array code
;;; - hex cell code

;;;    _   _
;;;  _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ 

;;; Top part of top row looks like this:
;;;    _   _  _   _
;;;  _/ \_/ \/ \_/ \
;;; /        

(define output #f) ; the list of all characters written out, in reverse order.

(define (write-ch c)
  (set! output (cons c output)))

(define (print-hexmaze harr entrance)
  (let* ((nrows  (harr:nrows harr))
         (ncols  (harr:ncols harr))
         (ncols2 (* 2 (quotient ncols 2))))

    ;; Print out the flat tops for the top row's odd cols.
    (do ((c 1 (+ c 2)))
        ((>= c ncols))
;     (display "   ")
      (write-ch #\space)
      (write-ch #\space)
      (write-ch #\space)
      (write-ch (if (= c entrance) #\space #\_)))
;   (newline)
    (write-ch #\newline)

    ;; Print out the slanted tops for the top row's odd cols
    ;; and the flat tops for the top row's even cols.
    (write-ch #\space)
    (do ((c 0 (+ c 2)))
        ((>= c ncols2))
;     (format #t "~a/~a\\"
;             (if (= c entrance) #\space #\_)
;             (dot/space harr (- nrows 1) (+ c 1)))
      (write-ch (if (= c entrance) #\space #\_))
      (write-ch #\/)
      (write-ch (dot/space harr (- nrows 1) (+ c 1)))
      (write-ch #\\))
    (if (odd? ncols)
        (write-ch (if (= entrance (- ncols 1)) #\space #\_)))
;   (newline)
    (write-ch #\newline)

    (do ((r (- nrows 1) (- r 1)))
        ((< r 0))

      ;; Do the bottoms for row r's odd cols.
      (write-ch #\/)
      (do ((c 1 (+ c 2)))
          ((>= c ncols2))
        ;; The dot/space for the even col just behind c.
        (write-ch (dot/space harr r (- c 1)))
        (display-hexbottom (cell:walls (href/rc harr r c))))    

      (cond ((odd? ncols)
             (write-ch (dot/space harr r (- ncols 1)))
             (write-ch #\\)))
;     (newline)
      (write-ch #\newline)

      ;; Do the bottoms for row r's even cols.
      (do ((c 0 (+ c 2)))
          ((>= c ncols2))
        (display-hexbottom (cell:walls (href/rc harr r c)))
        ;; The dot/space is for the odd col just after c, on row below.
        (write-ch (dot/space harr (- r 1) (+ c 1))))
      
      (cond ((odd? ncols)
             (display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
            ((not (zero? r)) (write-ch #\\)))
;     (newline)
      (write-ch #\newline))))

(define (bit-test j bit)
  (not (zero? (bitwise-and j bit))))

;;; Return a . if harr[r,c] is marked, otherwise a space.
;;; We use the dot to mark the solution path.
(define (dot/space harr r c)
  (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))

;;; Print a \_/ hex bottom.
(define (display-hexbottom hexwalls)
  (write-ch (if (bit-test hexwalls south-west) #\\ #\space))
  (write-ch (if (bit-test hexwalls south     ) #\_ #\space))
  (write-ch (if (bit-test hexwalls south-east) #\/ #\space)))

;;;    _   _
;;;  _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/

;------------------------------------------------------------------------------

(define (run nrows ncols)
  (set! output '())
  (pmaze nrows ncols)
  (reverse output))

(define (main . args)
  (run-benchmark
    "maze"
    maze-iters
    (lambda (result)
      (equal? result '
(#\  #\  #\  #\_ #\  #\  #\  #\_ #\  #\  #\  #\_ #\newline
 #\  #\_ #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\. #\\ #\  #\newline
 #\/ #\  #\\ #\  #\  #\  #\\ #\_ #\  #\. #\  #\  #\/ #\. #\\ #\newline
 #\\ #\  #\  #\  #\\ #\  #\/ #\. #\  #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\/ #\. #\  #\_ #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\  #\/ #\  #\\ #\  #\/ #\  #\  #\_ #\/ #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\  #\_ #\/ #\. #\\ #\  #\/ #\  #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\  #\/ #\  #\\ #\  #\/ #\  #\  #\_ #\/ #\  #\  #\  #\/ #\newline
 #\/ #\  #\\ #\  #\/ #\. #\\ #\  #\/ #\. #\\ #\_ #\/ #\  #\\ #\newline
 #\\ #\_ #\/ #\  #\\ #\  #\/ #\. #\  #\_ #\  #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\. #\  #\_ #\/ #\  #\\ #\  #\  #\  #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\_ #\/ #\  #\  #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\  #\_ #\/ #\  #\  #\  #\/ #\  #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\  #\/ #\  #\\ #\_ #\  #\. #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\  #\\ #\_ #\  #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\_ #\/ #\  #\  #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\  #\\ #\  #\/ #\. #\\ #\  #\  #\. #\\ #\newline
 #\\ #\  #\/ #\. #\\ #\_ #\  #\. #\  #\  #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\  #\  #\  #\. #\  #\_ #\/ #\. #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\  #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\  #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\. #\  #\  #\/ #\  #\  #\_ #\/ #\  #\\ #\newline
 #\\ #\_ #\  #\  #\\ #\_ #\/ #\. #\\ #\_ #\  #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\  #\_ #\/ #\  #\\ #\  #\/ #\  #\\ #\_ #\  #\  #\\ #\newline
 #\\ #\_ #\/ #\  #\  #\_ #\/ #\. #\\ #\_ #\  #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\  #\/ #\  #\  #\_ #\  #\. #\  #\_ #\  #\  #\\ #\newline
 #\\ #\  #\/ #\  #\\ #\_ #\/ #\. #\  #\_ #\  #\  #\\ #\_ #\/ #\newline
 #\/ #\  #\  #\_ #\  #\  #\\ #\  #\  #\  #\\ #\_ #\/ #\  #\\ #\newline
 #\\ #\_ #\/ #\. #\\ #\_ #\  #\. #\\ #\_ #\/ #\  #\  #\_ #\/ #\newline
 #\/ #\  #\\ #\  #\  #\. #\  #\_ #\/ #\  #\  #\  #\/ #\  #\\ #\newline
 #\\ #\  #\/ #\. #\\ #\_ #\/ #\  #\\ #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\\ #\_ #\  #\. #\  #\_ #\/ #\. #\  #\  #\  #\  #\\ #\newline
 #\\ #\  #\  #\  #\  #\  #\  #\. #\  #\  #\/ #\. #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\/ #\  #\  #\  #\/ #\  #\\ #\_ #\/ #\. #\  #\  #\/ #\newline
 #\/ #\  #\  #\  #\/ #\  #\  #\_ #\  #\  #\\ #\  #\/ #\  #\\ #\newline
 #\\ #\_ #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
 #\/ #\  #\\ #\_ #\/ #\  #\  #\_ #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\  #\  #\  #\  #\_ #\/ #\. #\  #\  #\/ #\. #\  #\_ #\/ #\newline
 #\/ #\  #\\ #\  #\/ #\. #\  #\  #\/ #\  #\\ #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\/ #\. #\  #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\  #\/ #\newline
 #\/ #\  #\  #\_ #\  #\. #\\ #\_ #\  #\. #\  #\_ #\  #\. #\\ #\newline
 #\\ #\_ #\/ #\  #\\ #\  #\/ #\  #\\ #\_ #\/ #\  #\\ #\_ #\/ #\newline)))
    (lambda (nrows ncols) (lambda () (run nrows ncols)))
    20
    7))
(main)
; maze maze

[-- Attachment #3: trav1_bug.scm --]
[-- Type: application/octet-stream, Size: 5267 bytes --]

(define (run-bench name count ok? run)
  (let loop ((i count) (result '(undefined)))
    (if (< 0 i)
      (loop (- i 1) (run))
      result)))

(define (run-benchmark name count ok? run-maker . args)
  (newline)
  (let* ((run (apply run-maker args))
         (result (run-bench name count ok? run)))
    (if (not (ok? result))
      (begin
        (display "*** wrong result ***")
        (newline)
        (display "*** got: ")
        (write result)
        (newline)))))

(define (fatal-error . args)
  (for-each display args)
  (newline)
  (exit 1))

 (define (call-with-output-file/truncate filename proc)
   (call-with-output-file filename proc))

(define trav1-iters        10)
 
(define (make-node)
  (vector 'node '() '() (snb) #f #f #f #f #f #f #f))

(define (node-parents node) (vector-ref node 1))
(define (node-sons node) (vector-ref node 2))
(define (node-sn node) (vector-ref node 3))
(define (node-entry1 node) (vector-ref node 4))
(define (node-entry2 node) (vector-ref node 5))
(define (node-entry3 node) (vector-ref node 6))
(define (node-entry4 node) (vector-ref node 7))
(define (node-entry5 node) (vector-ref node 8))
(define (node-entry6 node) (vector-ref node 9))
(define (node-mark node) (vector-ref node 10))

(define (node-parents-set! node v) (vector-set! node 1 v))
(define (node-sons-set! node v) (vector-set! node 2 v))
(define (node-sn-set! node v) (vector-set! node 3 v))
(define (node-entry1-set! node v) (vector-set! node 4 v))
(define (node-entry2-set! node v) (vector-set! node 5 v))
(define (node-entry3-set! node v) (vector-set! node 6 v))
(define (node-entry4-set! node v) (vector-set! node 7 v))
(define (node-entry5-set! node v) (vector-set! node 8 v))
(define (node-entry6-set! node v) (vector-set! node 9 v))
(define (node-mark-set! node v) (vector-set! node 10 v))

(define *sn* 0)
(define *rand* 21)
(define *count* 0)
(define *marker* #f)
(define *root* '())

(define (snb)
  (set! *sn* (+ 1 *sn*))
  *sn*)
 
(define (seed)
  (set! *rand* 21)
  *rand*)
 
(define (traverse-random)
  (set! *rand* (remainder (* *rand* 17) 251))
  *rand*)
 
(define (traverse-remove n q)
  (cond ((eq? (cdr (car q)) (car q))
         (let ((x (caar q))) (set-car! q '()) x))
        ((= n 0)
         (let ((x (caar q)))
           (do ((p (car q) (cdr p)))
               ((eq? (cdr p) (car q))
                (set-cdr! p (cdr (car q)))
                (set-car! q p)))
           x))
        (else (do ((n n (- n 1))
                (q (car q) (cdr q))
                (p (cdr (car q)) (cdr p)))
               ((= n 0) (let ((x (car q))) (set-cdr! q p) x))))))
 
(define (traverse-select n q)
  (do ((n n (- n 1))
       (q (car q) (cdr q)))
      ((= n 0) (car q))))
 
(define (add a q)
  (cond ((null? q)
         `(,(let ((x `(,a)))
              (set-cdr! x x) x)))
        ((null? (car q))
         (let ((x `(,a)))
           (set-cdr! x x)
           (set-car! q x)
           q))
        ; the CL version had a useless set-car! in the next line (wc)
        (else (set-cdr! (car q) `(,a ,@(cdr (car q))))
              q)))
 
(define (create-structure n)
  (let ((a `(,(make-node))))
    (do ((m (- n 1) (- m 1))
         (p a))
        ((= m 0)
         (set! a `(,(begin (set-cdr! p a) p)))
         (do ((unused a)
              (used (add (traverse-remove 0 a) '()))
              (x '())
              (y '()))
             ((null? (car unused))
              (find-root (traverse-select 0 used) n))
           (set! x (traverse-remove (remainder (traverse-random) n) unused))
           (set! y (traverse-select (remainder (traverse-random) n) used))
           (add x used)
           (node-sons-set! y `(,x ,@(node-sons y)))
           (node-parents-set! x `(,y ,@(node-parents x))) ))
      (set! a (cons (make-node) a)))))
 
(define (find-root node n)
  (do ((n n (- n 1)))
      ((or (= n 0) (null? (node-parents node)))
       node)
    (set! node (car (node-parents node)))))
 
(define (travers node mark)
  (cond ((eq? (node-mark node) mark) #f)
        (else (node-mark-set! node mark)
           (set! *count* (+ 1 *count*))
           (node-entry1-set! node (not (node-entry1 node)))
           (node-entry2-set! node (not (node-entry2 node)))
           (node-entry3-set! node (not (node-entry3 node)))
           (node-entry4-set! node (not (node-entry4 node)))
           (node-entry5-set! node (not (node-entry5 node)))
           (node-entry6-set! node (not (node-entry6 node)))
           (do ((sons (node-sons node) (cdr sons)))
               ((null? sons) #f)
             (travers (car sons) mark)))))
 
(define (traverse root)
  (let ((*count* 0))
    (travers root (begin (set! *marker* (not *marker*)) *marker*))
    *count*))
 
(define (init-traverse)  ; Changed from defmacro to defun \bs
  (set! *root* (create-structure 100))
  #f)
 
(define (run-traverse)  ; Changed from defmacro to defun \bs
  (do ((i 50 (- i 1)))
      ((= i 0))
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)))

;;; to initialize, call:  (init-traverse)
;;; to run traverse, call:  (run-traverse)

(define (main . args)
  (run-benchmark
    "trav1"
    trav1-iters
    (lambda (result) #t)
    (lambda () (lambda () (init-traverse)))))
(main)
; trav1 trav1

[-- Attachment #4: trav2_bug.scm --]
[-- Type: application/octet-stream, Size: 5414 bytes --]

; trav2 trav2
(define-macro (if-fixflo yes no) no)
;------------------------------------------------------------------------------

(define (run-bench name count ok? run)
  (let loop ((i count) (result '(undefined)))
    (if (< 0 i)
      (loop (- i 1) (run))
      result)))

(define (run-benchmark name count ok? run-maker . args)
  (newline)
  (let* ((run (apply run-maker args))
         (result (run-bench name count ok? run)))
    (if (not (ok? result))
      (begin
        (display "*** wrong result ***")
        (newline)
        (display "*** got: ")
        (write result)
        (newline)))))

(define (fatal-error . args)
  (for-each display args)
  (newline)
  (exit 1))

 (define (call-with-output-file/truncate filename proc)
   (call-with-output-file filename proc))

(define trav2-iters         2)

(define (make-node)
  (vector 'node '() '() (snb) #f #f #f #f #f #f #f))

(define (node-parents node) (vector-ref node 1))
(define (node-sons node) (vector-ref node 2))
(define (node-sn node) (vector-ref node 3))
(define (node-entry1 node) (vector-ref node 4))
(define (node-entry2 node) (vector-ref node 5))
(define (node-entry3 node) (vector-ref node 6))
(define (node-entry4 node) (vector-ref node 7))
(define (node-entry5 node) (vector-ref node 8))
(define (node-entry6 node) (vector-ref node 9))
(define (node-mark node) (vector-ref node 10))

(define (node-parents-set! node v) (vector-set! node 1 v))
(define (node-sons-set! node v) (vector-set! node 2 v))
(define (node-sn-set! node v) (vector-set! node 3 v))
(define (node-entry1-set! node v) (vector-set! node 4 v))
(define (node-entry2-set! node v) (vector-set! node 5 v))
(define (node-entry3-set! node v) (vector-set! node 6 v))
(define (node-entry4-set! node v) (vector-set! node 7 v))
(define (node-entry5-set! node v) (vector-set! node 8 v))
(define (node-entry6-set! node v) (vector-set! node 9 v))
(define (node-mark-set! node v) (vector-set! node 10 v))

(define *sn* 0)
(define *rand* 21)
(define *count* 0)
(define *marker* #f)
(define *root* '())

(define (snb)
  (set! *sn* (+ 1 *sn*))
  *sn*)
 
(define (seed)
  (set! *rand* 21)
  *rand*)
 
(define (traverse-random)
  (set! *rand* (remainder (* *rand* 17) 251))
  *rand*)
 
(define (traverse-remove n q)
  (cond ((eq? (cdr (car q)) (car q))
         (let ((x (caar q))) (set-car! q '()) x))
        ((= n 0)
         (let ((x (caar q)))
           (do ((p (car q) (cdr p)))
               ((eq? (cdr p) (car q))
                (set-cdr! p (cdr (car q)))
                (set-car! q p)))
           x))
        (else (do ((n n (- n 1))
                (q (car q) (cdr q))
                (p (cdr (car q)) (cdr p)))
               ((= n 0) (let ((x (car q))) (set-cdr! q p) x))))))
 
(define (traverse-select n q)
  (do ((n n (- n 1))
       (q (car q) (cdr q)))
      ((= n 0) (car q))))
 
(define (add a q)
  (cond ((null? q)
         `(,(let ((x `(,a)))
              (set-cdr! x x) x)))
        ((null? (car q))
         (let ((x `(,a)))
           (set-cdr! x x)
           (set-car! q x)
           q))
        ; the CL version had a useless set-car! in the next line (wc)
        (else (set-cdr! (car q) `(,a ,@(cdr (car q))))
              q)))
 
(define (create-structure n)
  (let ((a `(,(make-node))))
    (do ((m (- n 1) (- m 1))
         (p a))
        ((= m 0)
         (set! a `(,(begin (set-cdr! p a) p)))
         (do ((unused a)
              (used (add (traverse-remove 0 a) '()))
              (x '())
              (y '()))
             ((null? (car unused))
              (find-root (traverse-select 0 used) n))
           (set! x (traverse-remove (remainder (traverse-random) n) unused))
           (set! y (traverse-select (remainder (traverse-random) n) used))
           (add x used)
           (node-sons-set! y `(,x ,@(node-sons y)))
           (node-parents-set! x `(,y ,@(node-parents x))) ))
      (set! a (cons (make-node) a)))))
 
(define (find-root node n)
  (do ((n n (- n 1)))
      ((or (= n 0) (null? (node-parents node)))
       node)
    (set! node (car (node-parents node)))))
 
(define (travers node mark)
  (cond ((eq? (node-mark node) mark) #f)
        (else (node-mark-set! node mark)
           (set! *count* (+ 1 *count*))
           (node-entry1-set! node (not (node-entry1 node)))
           (node-entry2-set! node (not (node-entry2 node)))
           (node-entry3-set! node (not (node-entry3 node)))
           (node-entry4-set! node (not (node-entry4 node)))
           (node-entry5-set! node (not (node-entry5 node)))
           (node-entry6-set! node (not (node-entry6 node)))
           (do ((sons (node-sons node) (cdr sons)))
               ((null? sons) #f)
             (travers (car sons) mark)))))
 
(define (traverse root)
  (let ((*count* 0))
    (travers root (begin (set! *marker* (not *marker*)) *marker*))
    *count*))
 
(define (init-traverse)  ; Changed from defmacro to defun \bs
  (set! *root* (create-structure 100))
  #f)
 
(define (run-traverse)  ; Changed from defmacro to defun \bs
  (do ((i 50 (- i 1)))
      ((= i 0))
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)))

;;; to initialize, call:  (init-traverse)
;;; to run traverse, call:  (run-traverse)

(init-traverse)

(define (main . args)
  (run-benchmark
    "trav2"
    trav2-iters
    (lambda (result) #t)
    (lambda () (lambda () (run-traverse)))))
(main)
; trav2 trav2

Re: Segfault when running fibc benchmark in current trunk

[Juhani Rantanen]

>> I look forward to the next bug report :)
>
> Here are some more files that don't need the benchmark suite to run. I
> also ran all of the tests with Gambit and there wasn't any errors.
>
> Testing maze under Guile-r5rs
> Compiling...
> Running...
> ERROR: In procedure zero?:
> ERROR: Wrong type argument in position 1: #f

Hi,

I still have some cough and flu, I hope you're luckier and have not
catched this evil disease.. Anyway, as I made this bug report I was sick
so my brain didn't work like normal, as it seems that this maze_bug.scm
not working is actually a portability issue in the testsuite, not a
genuine guile bug. At least this seems likely. Benchmark does run with
Gambit without any errors, but that is a different implementation with
different set of primitives. So I'm sorry if I've sent you to a wild goose
chase.

That aside, I am interested in using Guile to extend my application and I
will volunteer to test it with some other code as well before the next
release to improve quality of the release. I used to do release testing
and Unix/DB administration for a living (maybe that is why I wanted to run
the benchmarks and use a development version in the first place :) but I
don't have too much coding experience (in big sw projects) so I won't do
patches at first unless they are trivial in nature. If all goes well I
will report some more bugs soon. One bug might be that Guile 1.8.6 runs
every benchmark (some of them are real-world applications, some simple
synthetic benchmarks) faster than the current version with this new VM.

BR,
Juhani

Re: Segfault when running fibc benchmark in current trunk

[Andy Wingo]

Hi Juhani!

On Wed 22 Apr 2009 21:29, "Juhani Rantanen" <misty@aj-group.net> writes:

>>> I look forward to the next bug report :)
>>
>> Here are some more files that don't need the benchmark suite to run. I
>> also ran all of the tests with Gambit and there wasn't any errors.
>>
>> Testing maze under Guile-r5rs
>> Compiling...
>> Running...
>> ERROR: In procedure zero?:
>> ERROR: Wrong type argument in position 1: #f
>
> Hi,
>
> I still have some cough and flu, I hope you're luckier and have not
> catched this evil disease..

Uf, sounds quite irritating. For the moment I am free of this (knock on
wood)

> it seems that this maze_bug.scm not working is actually a portability
> issue in the testsuite, not a genuine guile bug. At least this seems
> likely. Benchmark does run with Gambit without any errors, but that is
> a different implementation with different set of primitives. So I'm
> sorry if I've sent you to a wild goose chase.

I haven't started poking at this yet, so no problem, although not for
the right reason :)

> That aside, I am interested in using Guile to extend my application

Great!

> and I
> will volunteer to test it with some other code as well before the next
> release to improve quality of the release.

Even better! :-)

> One bug might be that Guile 1.8.6 runs every benchmark (some of them
> are real-world applications, some simple synthetic benchmarks) faster
> than the current version with this new VM.

Hah! Yes that sounds like a bug to me :) Are you compiling the
benchmarks? I'd like to look into this. Let me know if you can get an
isolated test case.

Cheers,

Andy
-- 
http://wingolog.org/

Re: Segfault when running fibc benchmark in current trunk

[Juhani Rantanen]

[-- Attachment #1: Type: text/plain, Size: 1130 bytes --]

>> One bug might be that Guile 1.8.6 runs every benchmark (some of them
>> are real-world applications, some simple synthetic benchmarks) faster
>> than the current version with this new VM.
>
> Hah! Yes that sounds like a bug to me :) Are you compiling the
> benchmarks? I'd like to look into this. Let me know if you can get an
> isolated test case.

Hi,

I have tried both compiling the benchmarks ahead-of-time and simply
running them with guile -s, compiling is naturally little faster but still
a little slow. From C stack trace I noticed that debugging VM was always
used but I don't know how to change the VM. Trunk version was compiled
with '-O2 -march=athlon' and 1.8.6 is a binary installed from Fedora Core
10 repository.

I attached the worst offender (ctak) which takes 1.6GB of core and about
one minute to run on the trunk, but insignificant amount of memory and
about two seconds on 1.8.6. I also attached a very simple fibonacci
benchmark that is somewhat slower on trunk. Other, bigger benchmarks are
slower as well but this was easiest way to make an isolated test case :)

BR,
Juhani

[-- Attachment #2: ctak.scm --]
[-- Type: application/octet-stream, Size: 606 bytes --]

;;; CTAK -- A version of the TAK procedure that uses continuations.

(define (ctak x y z)
  (call-with-current-continuation
   (lambda (k) (ctak-aux k x y z))))

(define (ctak-aux k x y z)
  (if (not (< y x))
      (k z)
      (call-with-current-continuation
       (lambda (k)
         (ctak-aux
          k
          (call-with-current-continuation
           (lambda (k) (ctak-aux k (- x 1) y z)))
          (call-with-current-continuation
           (lambda (k) (ctak-aux k (- y 1) z x)))
          (call-with-current-continuation
           (lambda (k) (ctak-aux k (- z 1) x y))))))))

(ctak 18 12 6)

[-- Attachment #3: fib.scm --]
[-- Type: application/octet-stream, Size: 157 bytes --]

;;; FIB -- A classic benchmark, computes fib(35) inefficiently.

(define (fib n)
  (if (< n 2)
    n
    (+ (fib (- n 1))
       (fib (- n 2)))))


(fib 35)