basis/threads/threads-tests.factor

   1 USING: io memory namespaces tools.test threads threads.private kernel
   2 concurrency.combinators concurrency.promises locals math
   3 words calendar sequences fry ;
   4 IN: threads.tests
   5
   6 ! Bug #1319
   7 ! The start-context-and-delete primitive calls reset_context which
   8 ! causes reads to uninitialized locations in the data segment if it
   9 ! gc:s
  10
  11 TUPLE: tup1 a ;
  12
  13 ! This word attempts to fill the nursery so that there is less than 48
  14 ! bytes of free space in it. The constant used to fill is volatile but
  15 ! should work on 64 bit.
  16 : fill-nursery ( -- obj )
  17     minor-gc 48074 [ tup1 new ] replicate ;
  18
  19 : do-reset-context ( -- val )
  20     ! "main running" print flush
  21     [ "a" print ] "foo1" spawn drop
  22     [ "b" print ] "foo2" spawn drop
  23     [ "c" print ] "foo3"
  24     [ fill-nursery ] 2dip
  25     spawn drop
  26     0 seconds sleep ;
  27
  28 { 48074 } [
  29     do-reset-context length
  30 ] unit-test
  31
  32 3 "x" set
  33 [ 2 "x" set ] "Test" spawn drop
  34 { 2 } [ yield "x" get ] unit-test
  35 { } [ [ flush ] "flush test" spawn drop flush ] unit-test
  36 { } [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test
  37 yield
  38
  39 { } [ 0.3 sleep ] unit-test
  40 [ "hey" sleep ] must-fail
  41
  42 { 3 } [ 3 self resume-with "Test suspend" suspend ] unit-test
  43
  44 { f } [ f get-global ] unit-test
  45
  46 { { 0 3 6 9 12 15 18 21 24 27 } } [
  47     10 <iota> [
  48         0 "i" tset
  49         [
  50             "i" [ yield 3 + ] tchange
  51         ] times yield
  52         "i" tget
  53     ] parallel-map
  54 ] unit-test
  55
  56 :: spawn-namespace-test ( -- ? )
  57     <promise> :> p gensym :> g
  58     g "x" [
  59         [ "x" get p fulfill ] "B" spawn drop
  60     ] with-variable
  61     p ?promise g eq? ;
  62
  63 { t } [ spawn-namespace-test ] unit-test
  64
  65 [ "a" [ 1 1 + ] spawn 100 sleep ] must-fail
  66
  67 { } [ 0.1 seconds sleep ] unit-test
  68
  69 ! Test thread-local variables
  70 <promise> "p" set
  71
  72 5 "x" tset
  73
  74 { 5 } [ "x" tget ] unit-test
  75
  76 { } [ "x" [ 1 + ] tchange ] unit-test
  77
  78 { 6 } [ "x" tget ] unit-test
  79
  80 ! Are they truly thread-local?
  81 [ "x" tget "p" get fulfill ] in-thread
  82
  83 { f } [ "p" get ?promise ] unit-test
  84
  85 ! Test system traps inside threads
  86 { } [ [ dup ] in-thread yield ] unit-test
  87
  88 ! The start-context-and-delete primitive wasn't rewinding the
  89 ! callstack properly.
  90
  91 ! This got fixed for x86-64 but the problem remained on x86-32.
  92
  93 ! The unit test asserts that the callstack is empty from the
  94 ! quotation passed to start-context-and-delete.
  95
  96 { 3 } [
  97     <promise> [
  98         '[
  99             _ [
 100                 [ get-callstack swap fulfill stop ] start-context-and-delete
 101             ] start-context-and-delete
 102         ] in-thread
 103     ] [ ?promise callstack>array length ] bi
 104 ] unit-test