core/memory/memory-tests.factor

   1 USING: accessors byte-arrays effects kernel kernel.private math memory
   2 prettyprint io sequences tools.test words namespaces layouts classes
   3 classes.builtin arrays quotations system ;
   4 FROM: tools.memory => data-room code-room ;
   5 IN: memory.tests
   6
   7 [ save-image-and-exit ] must-fail
   8
   9 ! Tests for 'instances'
  10 [ [ ] instances ] must-infer
  11 2 [ [ [ 3 throw ] instances ] must-fail ] times
  12
  13 ! Tests for 'become'
  14 { } [ { } { } become ] unit-test
  15
  16 ! Become something when it's on the data stack.
  17 { "replacer" } [
  18     "original" dup 1array { "replacer" } become
  19 ] unit-test
  20
  21 ! Nested in aging
  22 { "replacer" } [
  23     "original" [ 5 [ 1array ] times ] [ 1array ] bi
  24     minor-gc
  25     { "replacer" } become 5 [ first ] times
  26 ] unit-test
  27
  28 ! Also when it is nested in nursery
  29 { "replacer" } [
  30     minor-gc
  31     "original" [ 5 [ 1array ] times ] [ 1array ] bi { "replacer" } become
  32     5 [ first ] times
  33 ] unit-test
  34
  35 ! Bug found on Windows build box, having too many words in the
  36 ! image breaks 'become'
  37 { } [ 100000 [ f <uninterned-word> ] replicate { } { } become drop ] unit-test
  38
  39 ! Bug: code heap collection had to be done when data heap was
  40 ! full, not just when code heap was full. If the code heap
  41 ! contained dead code blocks referring to large data heap
  42 ! objects, those large objects would continue to live on even
  43 ! if the code blocks were not reachable, as long as the code
  44 ! heap did not fill up.
  45 : leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
  46
  47 : leak-loop ( -- ) 100 [ leak-step ] times ;
  48
  49 { } [ leak-loop ] unit-test
  50
  51 ! Bug: allocation of large objects directly into tenured space
  52 ! can proceed past the high water mark.
  53 !
  54 ! Suppose the nursery and aging spaces are mostly comprised of
  55 ! reachable objects. When doing a full GC, objects from young
  56 ! generations ere promoted *before* unreachable objects in
  57 ! tenured space are freed by the sweep phase. So if large object
  58 ! allocation filled up the heap past the high water mark, this
  59 ! promotion might trigger heap growth, even if most of those
  60 ! large objects are unreachable.
  61 SYMBOL: foo
  62
  63 { } [
  64     gc
  65
  66     data-room tenured>> size>>
  67
  68     10 [
  69         4 [ 120 1024 * f <array> ] replicate foo set-global
  70         100 [ 256 1024 * f <array> drop ] times
  71     ] times
  72
  73     data-room tenured>> size>>
  74     assert=
  75 ] unit-test
  76
  77 ! Perform one gc cycle. Then increase the stack height by 100 and
  78 ! force a gc cycle again.
  79 SYMBOL: foo-var
  80
  81 : perform ( -- )
  82     { 1 2 3 } { 4 5 6 } <effect> drop ;
  83
  84 : deep-stack-minor-gc ( n -- )
  85     dup [
  86         dup 0 > [ 1 - deep-stack-minor-gc ] [
  87             drop 100000 [ perform ] times
  88         ] if
  89     ] dip foo-var set ;
  90
  91 { } [
  92     minor-gc 100 deep-stack-minor-gc
  93 ] unit-test
  94
  95 ! Bug #1289
  96 TUPLE: tup2 a b c d ;
  97
  98 : inner ( k -- n )
  99     20 f <array> 20 f <array> assert=
 100     ! Allocates a byte array so large that the next allocation will
 101     ! trigger a gc.
 102     drop 2097103 <byte-array> ;
 103
 104 : outer ( -- lag )
 105     9 iota [ inner ] map
 106     ! D 0 is scrubbed, but if the branch calling 'inner' was
 107     ! called, then both D 0 and D 1 should have been scrubbed.
 108     0 9 1 tup2 boa ;
 109
 110 { } [
 111     outer drop
 112 ] unit-test