(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-constant (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))

(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))
				       (vector 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)
  (let ((wait (make-vector (wait-size) #f)))
    (do ((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))
	   (vector 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)

;(load "write.scm") (gc) (gc) (let-temporarily (((*s7* 'float-format-precision) 4)) (pretty-print (*s7* 'memory-usage) *stderr*)) (newline)
; weak-hash-table[-iter] undefined

(exit)
