core/memory/memory-tests.factor

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