mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
702cdb35db
* test-suite/standalone/test-out-of-memory: Prevent the test harness from being inlined. If the test harness is inlined, it might cause the optimizer to omit the allocations being tested!
87 lines
2.9 KiB
Scheme
Executable file
87 lines
2.9 KiB
Scheme
Executable file
#!/bin/sh
|
|
guild compile "$0"
|
|
exec guile -q -s "$0" "$@"
|
|
!#
|
|
|
|
(unless (defined? 'setrlimit)
|
|
;; Without an rlimit, this test can take down your system, as it
|
|
;; consumes all of your memory. That doesn't seem like something we
|
|
;; should run as part of an automated test suite.
|
|
(exit 0))
|
|
|
|
(when (string-ci= "darwin" (vector-ref (uname) 0))
|
|
;; setrlimits are ignored in OS X (tested on 10.9 and 10.10). Proceeding
|
|
;; with the test would fill all available memory and probably end in a crash.
|
|
;; See also test-stack-overflow.
|
|
(exit 77)) ; unresolved
|
|
|
|
(when (string-ci= "GNU" (vector-ref (uname) 0))
|
|
;; setrlimits are not yet implemented on GNU/Hurd systems. Proceeding
|
|
;; with the test would end in a crash. See
|
|
;; <https://lists.gnu.org/archive/html/bug-hurd/2017-05/msg00013.html>
|
|
(exit 77)) ; unresolved
|
|
|
|
(when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT")
|
|
;; attempting to use setrlimits for memory RLIMIT_AS will always
|
|
;; produce an invalid argument error on Cygwin (tested on
|
|
;; CYGWIN_NT-10.0 DLL v2.7.0). Proceeding with the test would fill
|
|
;; all available memory and probably end in a crash. See also
|
|
;; test-stack-overflow.
|
|
(exit 77)) ; unresolved
|
|
|
|
(catch #t
|
|
;; Silence GC warnings.
|
|
(lambda ()
|
|
(current-warning-port (open-output-file "/dev/null")))
|
|
(lambda (k . args)
|
|
(print-exception (current-error-port) #f k args)
|
|
(write "Skipping test.\n" (current-error-port))
|
|
(exit 77))) ; unresolved
|
|
|
|
;; 50 MB.
|
|
(define *limit* (* 50 1024 1024))
|
|
|
|
(call-with-values (lambda () (getrlimit 'as))
|
|
(lambda (soft hard)
|
|
(unless (and soft (< soft *limit*))
|
|
(setrlimit 'as (if hard (min *limit* hard) *limit*) hard))))
|
|
|
|
(define (test thunk)
|
|
(catch 'out-of-memory
|
|
(lambda ()
|
|
(thunk)
|
|
(error "should not be reached"))
|
|
(lambda _
|
|
#t)))
|
|
|
|
;; Prevent `test' from being inlined, which might cause an unused
|
|
;; allocation to be omitted.
|
|
(set! test test)
|
|
|
|
(use-modules (rnrs bytevectors))
|
|
|
|
(test (lambda ()
|
|
;; Unhappily, on 32-bit systems, vectors are limited to 16M
|
|
;; elements. Boo. Anyway, a vector with 16M elements takes 64
|
|
;; MB, which doesn't fit into 50 MB.
|
|
(make-vector (1- (ash 1 24)))))
|
|
(test (lambda ()
|
|
;; Likewise for a bytevector. This is different from the above,
|
|
;; as the elements of a bytevector are not traced by GC.
|
|
(make-bytevector #e1e9)))
|
|
(test (lambda ()
|
|
;; This one is the kicker -- we allocate pairs until the heap
|
|
;; can't expand. This is the hardest test to deal with because
|
|
;; the error-handling machinery has no memory in which to work.
|
|
(iota #e1e8)))
|
|
(test (lambda ()
|
|
;; The same, but also causing allocating during the unwind
|
|
;; (ouch!)
|
|
(dynamic-wind
|
|
(lambda () #t)
|
|
(lambda () (iota #e1e8))
|
|
(lambda () (iota #e1e8)))))
|
|
|
|
;; Local Variables:
|
|
;; mode: scheme
|
|
;; End:
|