tests/mem.scm

   1 ; File: "mem.scm", Time-stamp: <2009-05-14 14:21:50 feeley>
   2
   3 ; Copyright (c) 1996-2009 by Marc Feeley, All Rights Reserved.
   4
   5 ; Test program for Gambit-C's memory management system.
   6
   7 ;------------------------------------------------------------------------------
   8
   9 ; Utilities:
  10
  11 ; pseudo-random number generator
  12
  13 (define seed #f)
  14
  15 (define (reset-random)
  16   (set! seed 1923202963))
  17
  18 (define (random n)
  19   (let* ((hi (quotient seed 44488))
  20          (lo (remainder seed 44488))
  21          (test (- (* lo 48271) (* hi 3399))))
  22     (set! seed (if (> test 0) test (+ test 2147483647)))
  23     (modulo seed n)))
  24
  25 ; repetition of an evaluation
  26
  27 (define (repeat n thunk)
  28   (let loop ((i n))
  29     (if (> i 0)
  30       (begin
  31         (thunk)
  32         (loop (- i 1))))))
  33
  34 (define gc-reports? #t)
  35
  36 (define (setup-gc-reports)
  37   (gc-report-set! gc-reports?))
  38
  39 (define (trigger-gc)
  40   (##gc))
  41
  42 ;------------------------------------------------------------------------------
  43
  44 ; Test #1
  45 ;
  46 ; Allocate and deallocate medium size objects and large objects.  The
  47 ; GC reports show that movable and non-movable objects are allocated
  48 ; and reclaimed.
  49
  50 (define (test1)
  51
  52   (setup-gc-reports)
  53
  54   (reset-random)
  55
  56   (trigger-gc)
  57
  58   (let* ((n 4)
  59          (v (make-vector n #f)))
  60
  61     (repeat
  62       200
  63       (lambda ()
  64         (let ((i (random n))
  65               (size (if (= 0 (random 2)) 1000 35000)))
  66           (vector-set! v i (make-vector size))))))
  67
  68   (trigger-gc))
  69
  70 ;------------------------------------------------------------------------------
  71
  72 ; Test #2
  73 ;
  74 ; Allocate and deallocate medium size objects and large objects.  The
  75 ; GC reports show that movable and non-movable objects are allocated
  76 ; and reclaimed.
  77
  78 (define (test2)
  79
  80   (setup-gc-reports)
  81
  82   (reset-random)
  83
  84   (trigger-gc)
  85
  86   (set! test2-data '())
  87
  88   ; allocate roughly 1 MB of data
  89
  90   (repeat
  91     10
  92     (lambda ()
  93       (set! test2-data
  94         (cons (make-vector (if (= 0 (random 2)) 1000 35000))
  95               test2-data))))
  96
  97   (idle)
  98
  99   ; release roughly .5 MB of data
 100
 101   (repeat
 102     5
 103     (lambda ()
 104       (set! test2-data (cdr test2-data))))
 105
 106   (idle)
 107
 108   ; allocate roughly 1 MB more
 109
 110   (repeat
 111     10
 112     (lambda ()
 113       (set! test2-data
 114         (cons (make-vector (if (= 0 (random 2)) 1000 35000))
 115               test2-data))))
 116
 117   (idle)
 118
 119   ; release it all
 120
 121   (set! test2-data #f)
 122
 123   (trigger-gc))
 124
 125 (define test2-data #f)
 126
 127 (define (idle)
 128   (let loop ((i 20))
 129     (if (> i 0)
 130       (begin
 131         (make-vector (if (= 0 (random 2)) 1000 35000))
 132         (loop (- i 1))))))
 133
 134 ;------------------------------------------------------------------------------
 135
 136 ; Test #3
 137 ;
 138 ; Show how to recover from heap overflows.
 139 ;
 140 ; Note: make sure you specify a heap size limit when you start the
 141 ; compiler or interpreter, otherwise it may take a long time before
 142 ; the virtual memory is exhausted.
 143
 144 (define (test3)
 145
 146   (setup-gc-reports)
 147
 148   (trigger-gc)
 149   (test3-helper 10)      ; this call should terminate normally
 150   (test3-helper 1000000) ; this one will cause a heap overflow
 151   (test3-helper 10)      ; this call should terminate normally
 152 )
 153
 154 (define (test3-helper n)
 155   (reset-random)
 156   (let ((action
 157           (call-with-current-continuation
 158             (lambda (abort)
 159               (with-exception-handler
 160                 (lambda (exc)
 161                   (abort
 162                     (lambda ()
 163                       (trigger-gc) ; clean up heap and recover overflow reserve
 164                       (display "caught exception ")
 165                       (write exc)
 166                       (newline))))
 167                 (lambda ()
 168                   (let ((data (create-big-set-of-data n)))
 169                     (lambda ()
 170                       (trigger-gc)
 171                       (write (map vector? data))
 172                       (newline)))))))))
 173     (action)))
 174
 175 (define (create-big-set-of-data n)
 176   (let loop ((lst '()) (i n))
 177     (if (> i 0)
 178      (loop
 179         (cons (case (random 6)
 180                 ((0)  (make-string (random 80000)))
 181                 ((1)  (make-vector (random 40000)))
 182                 ((2)  (cons lst lst))
 183                 ((3)  (gensym))
 184                 ((4)  (lambda (x) lst))
 185                 (else (* 1.23 (random 100))))
 186               lst)
 187         (- i 1))
 188      lst)))
 189
 190 ;------------------------------------------------------------------------------
 191
 192 ; Test #4
 193 ;
 194 ; Show how to recover from stack overflows.
 195 ;
 196 ; Note: make sure you specify a heap size limit when you start the
 197 ; compiler or interpreter, otherwise it may take a long time before
 198 ; the virtual memory is exhausted.
 199
 200 (define (test4)
 201
 202   (setup-gc-reports)
 203
 204   (trigger-gc)
 205   (test4-helper 10)      ; this call should terminate normally
 206   (test4-helper 1000000) ; this one will cause a heap overflow
 207   (test4-helper 10)      ; this call should terminate normally
 208 )
 209
 210 (define (test4-helper n)
 211   (reset-random)
 212   (let ((action
 213           (call-with-current-continuation
 214             (lambda (abort)
 215               (with-exception-handler
 216                 (lambda (exc)
 217                   (abort
 218                     (lambda ()
 219                       (trigger-gc) ; clean up heap and recover overflow reserve
 220                       (display "caught exception ")
 221                       (write exc)
 222                       (newline))))
 223                 (lambda ()
 224                   (let ((data (deeply-nested-computation n)))
 225                     (lambda ()
 226                       (trigger-gc)
 227                       (write (map even? data))
 228                       (newline)))))))))
 229     (action)))
 230
 231 (define (deeply-nested-computation n)
 232   (if (> n 0)
 233     (cons n (deeply-nested-computation (- n 1)))
 234     '()))
 235
 236 ;------------------------------------------------------------------------------
 237
 238 ; Test #5
 239 ;
 240 ; Allocation of Scheme objects from C.
 241
 242 (c-declare "
 243
 244 #include <math.h>
 245
 246 static ___SCMOBJ obj1, obj2, obj3, obj4, obj5; /* some Scheme objects */
 247
 248 void foo (double x, int n, int (*f)(char*))
 249 {
 250   ___EXT(___DOUBLE_to_SCMOBJ) (___CLIBEXT(sqrt) (x), &obj1, 0);
 251   obj2 = ___EXT(___make_vector) (n, obj1, ___STILL);
 252   ___EXT(___CHARSTRING_to_SCMOBJ) (\"hello world!\", &obj3, 0);
 253   ___EXT(___CHARSTRING_to_SCMOBJ) (\"another string\", &obj4, 0);
 254   obj5 = ___EXT(___make_pair) (obj2, obj3, ___STILL);
 255   ___EXT(___still_obj_refcount_dec) (obj1); /* no direct need for obj1, etc */
 256   ___EXT(___still_obj_refcount_dec) (obj2);
 257   ___EXT(___still_obj_refcount_dec) (obj3);
 258   f (\"was called from C\");
 259 }
 260
 261 ___SCMOBJ bar ()
 262 {
 263   return obj4;
 264 }
 265
 266 ___SCMOBJ baz ()
 267 {
 268   ___EXT(___still_obj_refcount_dec) (obj5);
 269   return obj5;
 270 }
 271 ")
 272
 273 (c-define-type real double)
 274 (c-define-type integer int)
 275
 276 (define foo (c-lambda (real integer (function (char-string) int)) void "foo"))
 277 (define bar (c-lambda () scheme-object "bar"))
 278 (define baz (c-lambda () scheme-object "baz"))
 279
 280 (c-define (hop str) (char-string) int "hop" ""
 281   (write (list 'hop str))
 282   (newline)
 283   (string-length str))
 284
 285 (define (test5)
 286
 287   (setup-gc-reports)
 288
 289   (trigger-gc)
 290
 291   (hop "was called from Scheme")
 292
 293   (let ()
 294     (declare (standard-bindings) (not safe) (flonum)) ; inline "sqrt"
 295     (foo (sqrt (##first-argument .0625)) 5 hop)) ; create objects from C
 296
 297   (trigger-gc) ; they will show up as "not movable" objects in the GC report
 298
 299   (let ((x (bar))) ; get obj4 from C
 300
 301     (trigger-gc) ; no problem if a GC happens here
 302
 303     (write x)
 304     (newline))
 305
 306   (trigger-gc)
 307
 308   (let ((y (baz)))
 309
 310     (trigger-gc)
 311
 312     (write y)
 313     (newline))
 314
 315   (trigger-gc)) ; at this point, only obj4 is not reclaimed (because refcount != 0)
 316
 317 ;------------------------------------------------------------------------------
 318
 319 ; Test #6
 320 ;
 321 ; Finalization test.
 322
 323 (define (test6)
 324
 325   (setup-gc-reports)
 326
 327   (reset-random)
 328
 329   (trigger-gc)
 330   (trigger-gc)
 331
 332   (let* ((n 100)
 333          (v (make-vector n #f))
 334          (c 0)
 335          (expect 0)
 336          (result 0))
 337
 338     (define (new x)
 339       (let ((obj
 340              (case (random 8)
 341                ((0)
 342                 (make-string (random 10)))
 343                ((1)
 344                 (make-vector (random 10) x))
 345                ((2)
 346                 (cons x x))
 347                ((3)
 348                 (gensym))
 349                ((4)
 350                 (lambda (y) x))
 351                ((5)
 352                 (make-will (cons x x) (lambda (o) #f)))
 353                ((6)
 354                 (let ((id c))
 355                   (set! expect (+ expect id))
 356                   (set! c (+ c 1))
 357                   (make-will (make-vector (random 40000))
 358                              (lambda (o) (set! result (+ result id))))))
 359                (else
 360                 (+ 1.23 (random 100))))))
 361         (if (= (random 2) 0)
 362           (make-will obj (lambda (o) #f))
 363           (let ((id c))
 364             (set! expect (+ expect id))
 365             (set! c (+ c 1))
 366             (make-will obj
 367                        (lambda (o) (set! result (+ result id))))))
 368         obj))
 369
 370     (repeat
 371       2000
 372       (lambda ()
 373         (let ((i (random n)))
 374           (vector-set! v i (new (vector-ref v (random n)))))))
 375
 376     (set! v #f)
 377
 378     (write '(final-gc))
 379     (newline)
 380
 381     (trigger-gc)
 382
 383     (write expect)
 384     (newline)
 385
 386     (write result)
 387     (newline)
 388
 389     (trigger-gc)))
 390
 391 ;------------------------------------------------------------------------------
 392
 393 ; Test #7
 394 ;
 395 ; Finalization test.
 396
 397 (define (test7)
 398
 399   (define (printer name)
 400     (lambda (o)
 401       (display "===> calling the action procedure for object ")
 402       (display name)
 403       (display " = ")
 404       (write o)
 405       (newline)))
 406
 407   (define (gc)
 408     (display "--------------------------------------- GC")
 409     (newline)
 410     (trigger-gc))
 411
 412   (let* ((obj1 (list 'obj1))
 413          (obj2 (list 'obj2))
 414          (obj3 (list 'obj3))
 415          (obj4 (list 'obj4 (make-will (list 'obj4) (lambda (o) #f))))
 416          (obj5 (list 'obj5 (make-will (list 'obj5) (lambda (o) #f))))
 417          (obj6 (list 'obj6 (make-will (list 'obj6) (lambda (o) #f))))
 418          (obj7 (list 'obj7 (make-will (list 'obj7) (lambda (o) #f))))
 419          (obj8 (list 'obj8 (make-will (list 'obj8) (lambda (o) #f))))
 420          (obj9 (vector 1 2 3 4 5)))
 421
 422     (let* ((will1 (make-will obj1 (lambda (o) #f)))
 423            (will2 (make-will obj2 (printer 'obj2)))
 424            (will3 (make-will obj3 (lambda (o) #f)))
 425            (will4 (make-will obj4 (printer 'obj4)))
 426            (will5 (make-will obj5 (lambda (o) #f)))
 427            (will6 (make-will obj6 (printer 'obj6)))
 428            (will7 (make-will obj7 (lambda (o) #f)))
 429            (will8 (make-will obj8 (printer 'obj8))))
 430
 431       (define (print-testators)
 432
 433         (define (print name will)
 434           (display "(will-testator ")
 435           (display name)
 436           (display ") = ")
 437           (write (will-testator will))
 438           (newline))
 439
 440         (print 'will1 will1)
 441         (print 'will2 will2)
 442         (print 'will3 will3)
 443         (print 'will4 will4)
 444         (print 'will5 will5)
 445         (print 'will6 will6)
 446         (print 'will7 will7)
 447         (print 'will8 will8))
 448
 449       (let ((obj obj9)
 450             (p (printer 'obj9)))
 451         (make-will obj
 452                    (lambda (o) (p o) (set! obj9 o)))) ; resurect object
 453
 454       (setup-gc-reports)
 455
 456       (gc)
 457       (gc)
 458
 459       (print-testators)
 460
 461       (gc)
 462
 463       (print-testators)
 464
 465       (set! obj1 123)
 466
 467       (gc)
 468
 469       (print-testators)
 470
 471       (set! obj2 123)
 472       (set! obj3 123)
 473       (set! obj4 123)
 474       (set! obj5 123)
 475       (set! obj6 123)
 476       (set! obj7 123)
 477
 478       (gc)
 479
 480       (print-testators)
 481
 482       (set! obj8 123)
 483       (set! obj9 123)
 484
 485       (pretty-print obj9)
 486
 487       (gc)
 488
 489       (print-testators)
 490
 491       (pretty-print obj9)
 492
 493       (gc)
 494       (gc)
 495
 496       (let* ((a (cons 11 22))
 497              (b (cons 33 44))
 498              (wa (make-will a
 499                             (let ((x b))
 500                               (lambda (o)
 501                                 (pretty-print (list 'executing-will 'a x)))))))
 502         (make-will b
 503                    (lambda (o)
 504                      (pretty-print (list 'executing-will 'b))))
 505         (set! b #f)
 506         (gc)
 507         (set! a #f)
 508         (gc)
 509         (gc)
 510         (gc)))))
 511
 512 ;------------------------------------------------------------------------------
 513
 514 (define (test-all)
 515   (set! gc-reports? #f)
 516   (test1)
 517   (test2)
 518   (test3)
 519   (test4)
 520   (test5)
 521   (test6)
 522   (test7)
 523   (pretty-print 'all-tests-done))
 524
 525 (test-all)
 526 (exit)