Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

527 lines (397 sloc) 12.191 kB
; File: "mem.scm", Time-stamp: <2009-05-14 14:21:50 feeley>
; Copyright (c) 1996-2009 by Marc Feeley, All Rights Reserved.
; Test program for Gambit-C's memory management system.
;------------------------------------------------------------------------------
; Utilities:
; pseudo-random number generator
(define seed #f)
(define (reset-random)
(set! seed 1923202963))
(define (random n)
(let* ((hi (quotient seed 44488))
(lo (remainder seed 44488))
(test (- (* lo 48271) (* hi 3399))))
(set! seed (if (> test 0) test (+ test 2147483647)))
(modulo seed n)))
; repetition of an evaluation
(define (repeat n thunk)
(let loop ((i n))
(if (> i 0)
(begin
(thunk)
(loop (- i 1))))))
(define gc-reports? #t)
(define (setup-gc-reports)
(gc-report-set! gc-reports?))
(define (trigger-gc)
(##gc))
;------------------------------------------------------------------------------
; Test #1
;
; Allocate and deallocate medium size objects and large objects. The
; GC reports show that movable and non-movable objects are allocated
; and reclaimed.
(define (test1)
(setup-gc-reports)
(reset-random)
(trigger-gc)
(let* ((n 4)
(v (make-vector n #f)))
(repeat
200
(lambda ()
(let ((i (random n))
(size (if (= 0 (random 2)) 1000 35000)))
(vector-set! v i (make-vector size))))))
(trigger-gc))
;------------------------------------------------------------------------------
; Test #2
;
; Allocate and deallocate medium size objects and large objects. The
; GC reports show that movable and non-movable objects are allocated
; and reclaimed.
(define (test2)
(setup-gc-reports)
(reset-random)
(trigger-gc)
(set! test2-data '())
; allocate roughly 1 MB of data
(repeat
10
(lambda ()
(set! test2-data
(cons (make-vector (if (= 0 (random 2)) 1000 35000))
test2-data))))
(idle)
; release roughly .5 MB of data
(repeat
5
(lambda ()
(set! test2-data (cdr test2-data))))
(idle)
; allocate roughly 1 MB more
(repeat
10
(lambda ()
(set! test2-data
(cons (make-vector (if (= 0 (random 2)) 1000 35000))
test2-data))))
(idle)
; release it all
(set! test2-data #f)
(trigger-gc))
(define test2-data #f)
(define (idle)
(let loop ((i 20))
(if (> i 0)
(begin
(make-vector (if (= 0 (random 2)) 1000 35000))
(loop (- i 1))))))
;------------------------------------------------------------------------------
; Test #3
;
; Show how to recover from heap overflows.
;
; Note: make sure you specify a heap size limit when you start the
; compiler or interpreter, otherwise it may take a long time before
; the virtual memory is exhausted.
(define (test3)
(setup-gc-reports)
(trigger-gc)
(test3-helper 10) ; this call should terminate normally
(test3-helper 1000000) ; this one will cause a heap overflow
(test3-helper 10) ; this call should terminate normally
)
(define (test3-helper n)
(reset-random)
(let ((action
(call-with-current-continuation
(lambda (abort)
(with-exception-handler
(lambda (exc)
(abort
(lambda ()
(trigger-gc) ; clean up heap and recover overflow reserve
(display "caught exception ")
(write exc)
(newline))))
(lambda ()
(let ((data (create-big-set-of-data n)))
(lambda ()
(trigger-gc)
(write (map vector? data))
(newline)))))))))
(action)))
(define (create-big-set-of-data n)
(let loop ((lst '()) (i n))
(if (> i 0)
(loop
(cons (case (random 6)
((0) (make-string (random 80000)))
((1) (make-vector (random 40000)))
((2) (cons lst lst))
((3) (gensym))
((4) (lambda (x) lst))
(else (* 1.23 (random 100))))
lst)
(- i 1))
lst)))
;------------------------------------------------------------------------------
; Test #4
;
; Show how to recover from stack overflows.
;
; Note: make sure you specify a heap size limit when you start the
; compiler or interpreter, otherwise it may take a long time before
; the virtual memory is exhausted.
(define (test4)
(setup-gc-reports)
(trigger-gc)
(test4-helper 10) ; this call should terminate normally
(test4-helper 1000000) ; this one will cause a heap overflow
(test4-helper 10) ; this call should terminate normally
)
(define (test4-helper n)
(reset-random)
(let ((action
(call-with-current-continuation
(lambda (abort)
(with-exception-handler
(lambda (exc)
(abort
(lambda ()
(trigger-gc) ; clean up heap and recover overflow reserve
(display "caught exception ")
(write exc)
(newline))))
(lambda ()
(let ((data (deeply-nested-computation n)))
(lambda ()
(trigger-gc)
(write (map even? data))
(newline)))))))))
(action)))
(define (deeply-nested-computation n)
(if (> n 0)
(cons n (deeply-nested-computation (- n 1)))
'()))
;------------------------------------------------------------------------------
; Test #5
;
; Allocation of Scheme objects from C.
(c-declare "
#include <math.h>
static ___SCMOBJ obj1, obj2, obj3, obj4, obj5; /* some Scheme objects */
void foo (double x, int n, int (*f)(char*))
{
___EXT(___DOUBLE_to_SCMOBJ) (___CLIBEXT(sqrt) (x), &obj1, 0);
obj2 = ___EXT(___make_vector) (n, obj1, ___STILL);
___EXT(___CHARSTRING_to_SCMOBJ) (\"hello world!\", &obj3, 0);
___EXT(___CHARSTRING_to_SCMOBJ) (\"another string\", &obj4, 0);
obj5 = ___EXT(___make_pair) (obj2, obj3, ___STILL);
___EXT(___still_obj_refcount_dec) (obj1); /* no direct need for obj1, etc */
___EXT(___still_obj_refcount_dec) (obj2);
___EXT(___still_obj_refcount_dec) (obj3);
f (\"was called from C\");
}
___SCMOBJ bar ()
{
return obj4;
}
___SCMOBJ baz ()
{
___EXT(___still_obj_refcount_dec) (obj5);
return obj5;
}
")
(c-define-type real double)
(c-define-type integer int)
(define foo (c-lambda (real integer (function (char-string) int)) void "foo"))
(define bar (c-lambda () scheme-object "bar"))
(define baz (c-lambda () scheme-object "baz"))
(c-define (hop str) (char-string) int "hop" ""
(write (list 'hop str))
(newline)
(string-length str))
(define (test5)
(setup-gc-reports)
(trigger-gc)
(hop "was called from Scheme")
(let ()
(declare (standard-bindings) (not safe) (flonum)) ; inline "sqrt"
(foo (sqrt (##first-argument .0625)) 5 hop)) ; create objects from C
(trigger-gc) ; they will show up as "not movable" objects in the GC report
(let ((x (bar))) ; get obj4 from C
(trigger-gc) ; no problem if a GC happens here
(write x)
(newline))
(trigger-gc)
(let ((y (baz)))
(trigger-gc)
(write y)
(newline))
(trigger-gc)) ; at this point, only obj4 is not reclaimed (because refcount != 0)
;------------------------------------------------------------------------------
; Test #6
;
; Finalization test.
(define (test6)
(setup-gc-reports)
(reset-random)
(trigger-gc)
(trigger-gc)
(let* ((n 100)
(v (make-vector n #f))
(c 0)
(expect 0)
(result 0))
(define (new x)
(let ((obj
(case (random 8)
((0)
(make-string (random 10)))
((1)
(make-vector (random 10) x))
((2)
(cons x x))
((3)
(gensym))
((4)
(lambda (y) x))
((5)
(make-will (cons x x) (lambda (o) #f)))
((6)
(let ((id c))
(set! expect (+ expect id))
(set! c (+ c 1))
(make-will (make-vector (random 40000))
(lambda (o) (set! result (+ result id))))))
(else
(+ 1.23 (random 100))))))
(if (= (random 2) 0)
(make-will obj (lambda (o) #f))
(let ((id c))
(set! expect (+ expect id))
(set! c (+ c 1))
(make-will obj
(lambda (o) (set! result (+ result id))))))
obj))
(repeat
2000
(lambda ()
(let ((i (random n)))
(vector-set! v i (new (vector-ref v (random n)))))))
(set! v #f)
(write '(final-gc))
(newline)
(trigger-gc)
(write expect)
(newline)
(write result)
(newline)
(trigger-gc)))
;------------------------------------------------------------------------------
; Test #7
;
; Finalization test.
(define (test7)
(define (printer name)
(lambda (o)
(display "===> calling the action procedure for object ")
(display name)
(display " = ")
(write o)
(newline)))
(define (gc)
(display "--------------------------------------- GC")
(newline)
(trigger-gc))
(let* ((obj1 (list 'obj1))
(obj2 (list 'obj2))
(obj3 (list 'obj3))
(obj4 (list 'obj4 (make-will (list 'obj4) (lambda (o) #f))))
(obj5 (list 'obj5 (make-will (list 'obj5) (lambda (o) #f))))
(obj6 (list 'obj6 (make-will (list 'obj6) (lambda (o) #f))))
(obj7 (list 'obj7 (make-will (list 'obj7) (lambda (o) #f))))
(obj8 (list 'obj8 (make-will (list 'obj8) (lambda (o) #f))))
(obj9 (vector 1 2 3 4 5)))
(let* ((will1 (make-will obj1 (lambda (o) #f)))
(will2 (make-will obj2 (printer 'obj2)))
(will3 (make-will obj3 (lambda (o) #f)))
(will4 (make-will obj4 (printer 'obj4)))
(will5 (make-will obj5 (lambda (o) #f)))
(will6 (make-will obj6 (printer 'obj6)))
(will7 (make-will obj7 (lambda (o) #f)))
(will8 (make-will obj8 (printer 'obj8))))
(define (print-testators)
(define (print name will)
(display "(will-testator ")
(display name)
(display ") = ")
(write (will-testator will))
(newline))
(print 'will1 will1)
(print 'will2 will2)
(print 'will3 will3)
(print 'will4 will4)
(print 'will5 will5)
(print 'will6 will6)
(print 'will7 will7)
(print 'will8 will8))
(let ((obj obj9)
(p (printer 'obj9)))
(make-will obj
(lambda (o) (p o) (set! obj9 o)))) ; resurect object
(setup-gc-reports)
(gc)
(gc)
(print-testators)
(gc)
(print-testators)
(set! obj1 123)
(gc)
(print-testators)
(set! obj2 123)
(set! obj3 123)
(set! obj4 123)
(set! obj5 123)
(set! obj6 123)
(set! obj7 123)
(gc)
(print-testators)
(set! obj8 123)
(set! obj9 123)
(pretty-print obj9)
(gc)
(print-testators)
(pretty-print obj9)
(gc)
(gc)
(let* ((a (cons 11 22))
(b (cons 33 44))
(wa (make-will a
(let ((x b))
(lambda (o)
(pretty-print (list 'executing-will 'a x)))))))
(make-will b
(lambda (o)
(pretty-print (list 'executing-will 'b))))
(set! b #f)
(gc)
(set! a #f)
(gc)
(gc)
(gc)))))
;------------------------------------------------------------------------------
(define (test-all)
(set! gc-reports? #f)
(test1)
(test2)
(test3)
(test4)
(test5)
(test6)
(test7)
(pretty-print 'all-tests-done))
(test-all)
(exit)
Jump to Line
Something went wrong with that request. Please try again.