(set! (*s7* 'heap-size) 128000) ; old-style -- makes little difference (30 in callgrind)
(load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init)))

(define (check-cyclic p1)
  (let ((c1 (cyclic-sequences p1))
	(c2 (cyclic-sequences (copy p1)))
	(c3 (cyclic-sequences (object->let p1))))
    (unless (and (equal? c1 c2)
		 (equal? c2 c3))
      (format *stderr* "cyclic: ~S: ~S ~S ~S~%" p1 c1 c2 c3))))

;(define wait-size 20000) ; this makes the gc work much harder (especially the mark process, mark_vector linearly etc)
(if (defined? 'big-tgc)
    (define-expansion (wait-size) 20000) ; plug in the constant to avoid endless lookups (this is cheating)
    (define-expansion (wait-size) 200)) ; plug in the constant to avoid endless lookups (this is cheating)

(define (tgc-cyclic tries)
  (let ((wait (make-vector (wait-size) #f)))
    (do ((i 0 (+ i 1)))
	((= i tries))
      (let ((p1 (cons 1 2))
	    (p2 (make-list 7 1))
	    (p3 (list 1 2)))
	(set-cdr! (cdr p3) p3)
	(check-cyclic p1)
	(check-cyclic p2)
	(check-cyclic p3)
	(let ((v1 (vector 1 2))
	      (v2 (make-vector 7 1))
	      (v3 (vector 1 2 3))
	      (v4 (make-vector '(3 2))))
	  (vector-set! v3 2 v3)
	  (check-cyclic v1)
	  (check-cyclic v2)
	  (check-cyclic v3)
	  (check-cyclic v4)
	  (check-cyclic (subvector v2 1 5))
	  (check-cyclic (subvector v3 1))
	  (let ((s1 (string #\a #\s #\d #\f)))
	    (check-cyclic s1)
	    (check-cyclic (substring s1 1))
	    (let ((iv1 (int-vector 1 2))
		  (iv2 (make-int-vector 7 1)))
	      (check-cyclic iv1)
	      (check-cyclic iv2)
	      (check-cyclic (subvector iv2 1 5))
	      (let ((h1 (hash-table 'a 1))
		    (h2 (weak-hash-table 'b p1)))
		(check-cyclic h1)
		(check-cyclic h2)
		(let ((i1 (inlet 'a 1 'b 2)))
		  (check-cyclic i1)
		  (let ((in1 (open-output-string)))
		    (format in1 "asdf\n")
		    (check-cyclic in1)
		    (let ((in2 (open-input-string "asdf\n")))
		      (read-line in2)
		      (check-cyclic in2)
		      (let ((c1 (c-pointer 0 integer? "info" (cons h1 h2) (vector p3 p2 p1))))
			(check-cyclic c1)
			(let ((cc (call/cc (lambda (ret) ret))))
			  (check-cyclic cc)
			  (let ((ex1 (call-with-exit 
				      (lambda (go) 
					(check-cyclic go)
					go))))
			    (let ((f1 (lambda (a b c) (+ a b c))))
			      (check-cyclic f1)
			      (let ((u1 #<asdf>))
				(check-cyclic u1)
				(let ((g1 (gensym)))
				  (check-cyclic g1)
				  (check-cyclic ())
				  (check-cyclic #<unspecified)
				  (check-cyclic when)
				  (check-cyclic #<eof>)
				  (check-cyclic #f)
				  (check-cyclic #\a)
				  (check-cyclic pi)
				  (check-cyclic 1/2)
				  (check-cyclic 1+i)
				  (check-cyclic 'a)
				  (check-cyclic (lambda (a) (+ a 1)))
				  (let ((it1 (make-iterator '(1 2 3))))
				    (check-cyclic it1)
				    (let ((b1 (block 1 2 3)))
				      (check-cyclic b1)
				      (for-each 
				       (lambda (a)
					 (vector-set! wait (random (wait-size)) a)
					 (dynamic-wind
					     #f
					     (lambda ()
					       (catch #t
						 (lambda ()
						   (call-with-exit
						    (lambda (r)
						      (r a))))
						 (lambda (type info)
						   (format *stderr* "~A: ~A~%" type (apply format #f info)))))
					     #f))
				       (list p1 p2 p3 v1 v2 v3 v4 s1 iv2 iv2 h1 h2 i1 in1 in2 c1 cc ex1 u1 g1 it1 b1)))))))))))))))))))))

(tgc-cyclic 25000)


(define (tgc tries)
  (do ((wait (make-vector (wait-size) #f))
       (i 0 (+ i 1)))
      ((= i tries))
    (let ((p1 (cons 1 2))
	  (p2 (list 1 1 1 1 1 1 1))
	  (p3 (list 1 2))
	  (v1 (vector 1 2))
	  (v2 (make-vector 7 1))
	  (v3 (vector 1 2 3))
	  (v4 (make-vector '(3 2)))
	  (s1 (string #\a #\s #\d #\f))
	  (iv2 (make-int-vector 7 1))
	  (h1 (hash-table 'a 1))
	  (i1 (inlet 'a 1 'b 2))
	  (in1 (open-output-string))
	  (in2 (open-input-string "asdf\n"))
	  (cc (call/cc (lambda (ret) ret)))
	  (ex1 (call-with-exit 
		(lambda (go) 
		  go)))
	  (f1 (lambda (a b c) (+ a b c)))
	  (u1 #<asdf>)
	  (g1 (gensym))
	  (it1 (make-iterator '(1 2 3)))
	  (b1 (block 1 2 3)))
      (set-cdr! (cdr p3) p3)
      (vector-set! v3 2 v3)
      (format in1 "asdf\n")
      (read-line in2)
      (let* ((h2 (weak-hash-table 'b p1))
	     (c1 (c-pointer 0 integer? "info" (cons h1 h2) (vector p3 p2 p1))))
	(for-each 
	 (lambda (a)
	   (vector-set! wait (random (wait-size)) a)
	   (dynamic-wind
	       #f
	       (lambda ()
		 (catch #t
		   (lambda ()
		     (call-with-exit
		      (lambda (r)
			(r a))))
		   (lambda (type info)
		     (format *stderr* "~A: ~A~%" type (apply format #f info)))))
	       #f))
	 (list p1 p2 p3 v1 v2 v3 v4 s1 iv2 iv2 h1 h2 i1 in1 in2 c1 cc ex1 u1 g1 it1 b1))))))

(if (defined? 'big-case)
    (tgc 1000000)
    (tgc 200000))
;(tgc 1000000000)

(exit)