1 // alloctest.cpp                                Copyright (C) 2020 Codemist
2 
3 // This is going to be so I can have a simple test harness for
4 // newalloc.cpp and its friends.
5 
6 
7 // $Id: alloctest.cpp 5745 2021-03-20 17:35:28Z arthurcnorman $
8 
9 
10 /**************************************************************************
11  * Copyright (C) 2020, Codemist.                         A C Norman       *
12  *                                                                        *
13  * Redistribution and use in source and binary forms, with or without     *
14  * modification, are permitted provided that the following conditions are *
15  * met:                                                                   *
16  *                                                                        *
17  *     * Redistributions of source code must retain the relevant          *
18  *       copyright notice, this list of conditions and the following      *
19  *       disclaimer.                                                      *
20  *     * Redistributions in binary form must reproduce the above          *
21  *       copyright notice, this list of conditions and the following      *
22  *       disclaimer in the documentation and/or other materials provided  *
23  *       with the distribution.                                           *
24  *                                                                        *
25  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
26  * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
27  * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
28  * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
29  * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
30  * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
31  * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
32  * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
33  * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
34  * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
35  * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
36  * DAMAGE.                                                                *
37  *************************************************************************/
38 
39 #include "config.h"
40 #include "headers.h"
41 #include "arithlib.hpp"
42 
43 // I will need to provide definitions of a number of things that the main
44 // parts of CSL use, even if I will not actually make use of them here.
45 
fwin_report_left(const char * s)46 void fwin_report_left(const char *s)
47 {}
48 
fwin_report_right(const char * s)49 void fwin_report_right(const char *s)
50 {}
51 
52 int window_heading;
53 
fwin_ensure_screen()54 void fwin_ensure_screen()
55 {
56 }
57 
ensure_screen()58 void ensure_screen()
59 {
60 }
61 
62 volatile std::atomic<std::uintptr_t> event_flag;
63 
fwin_getchar()64 int fwin_getchar()
65 {   return EOF;
66 }
67 
make_undefined_symbol(const char * name)68 LispObject make_undefined_symbol(const char *name)
69 {   return nil;
70 }
71 
get_pname(LispObject a)72 LispObject get_pname(LispObject a)
73 {   return a;
74 }
75 
76 LispObject nil, lisp_true, unset_var;
77 LispObject *nilsegment, *stacksegment, *stackBase,
78            *stackLimit;
79 #define TL_stack 48
80 DEFINE_THREAD_LOCAL(LispObject *, stack);
81 std::uintptr_t *C_stackbase, C_stacklimit;
82 
fatal_error(int code,...)83 [[noreturn]] void fatal_error(int code, ...)
84 {   my_abort();
85 }
trace_printf(const char * fmt,...)86 void trace_printf(const char *fmt, ...)
87 {
88 }
89 
global_longjmp()90 void global_longjmp()
91 {   my_abort();
92 }
93 
respond_to_stack_event()94 void respond_to_stack_event()
95 {
96 }
97 
98 int init_flags;
99 double maxStoreSize;
100 unsigned int exit_count;
101 std::intptr_t miscflags;
102 
103 const char *programDir;
104 const char *programName;
105 const char *standard_directory;
106 
107 LispObject free_vectors[LOG2_VECTOR_CHUNK_BYTES+1] = {0};
108 
Crand()109 std::uint32_t Crand()
110 {   return 0;
111 }
112 
file_exists(char *,char const *,unsigned long,char *)113 bool file_exists(char*, char const*, unsigned long, char*)
114 {   return false;
115 }
116 
117 const volatile char *errorset_msg;
118 
aerror(const char * msg)119 LispObject aerror(const char *msg)
120 {   my_abort();
121     return 0;
122 }
123 
aerror1(const char * msg,LispObject a)124 LispObject aerror1(const char *msg, LispObject a)
125 {   my_abort();
126     return 0;
127 }
128 
sixty_four_bits(LispObject a)129 std::int64_t sixty_four_bits(LispObject a)
130 {   return 0;
131 }
132 
133 //=======================================================================
134 // Everything above this is just so that I can compile my code.
135 
136 std::mutex print_mutex;
137 
zcons(LispObject a,LispObject b)138 LispObject zcons(LispObject a, LispObject b)
139 {   char *r = new char[2*sizeof(LispObject)];
140     LispObject r1 = TAG_CONS + reinterpret_cast<LispObject>(r);
141     car(r1) = a;
142     cdr(r1) = b;
143     return r1;
144 }
145 
146 #define TL_treehash 63
147 DEFINE_THREAD_LOCAL(std::uint64_t, treehash);
148 
make_n_tree1(int n)149 LispObject make_n_tree1(int n)
150 {   if (n == 0)
151     {   std::uint64_t r = arithlib_implementation::mersenne_twister();
152         r &= UINT64_C(0x0000ffffffffffff);
153         treehash = 1234567*treehash + r;
154         treehash -= (treehash >> 32);
155         return fixnum_of_int(r);
156     }
157     int n1 = (n-1)/2;
158     LispObject left = make_n_tree1(n1);
159     if ((arithlib_implementation::mersenne_twister() % 1000) == 0)
160     {   may_block([&]
161         {   std::this_thread::sleep_for(std::chrono::seconds(1));
162         });
163         LispObject right = make_n_tree1(n-n1-1);
164         return cons(left, right);
165     }
166 
167     LispObject make_n_tree(int n)
168     {   treehash = 0;
169         LispObject r = make_n_tree1(n);
170         return r;
171     }
172 
173     int treesize1(LispObject a)
174     {   if (is_fixnum(a))
175         {   std::uint64_t r = int_of_fixnum(a);
176             treehash = 1234567*treehash + r;
177             treehash -= (treehash >> 32);
178             return 0;
179         }
180         if (!is_cons(a)) my_abort();
181         int left = treesize1(car(a));
182         int right = treesize1(cdr(a));
183         return left+right+1;
184     }
185 
186     void treesize(LispObject a, int expected_size,
187                   std::uint64_t expected_hash)
188     {   treehash = 0;
189         int n = treesize1(a);
190         my_assert(n == expected_size);
191         my_assert(treehash == expected_hash);
192     }
193 
194 // Threads are created using this function, and its argument cen be passed
195 // to identify the activity with a thread number.
196 
197     int thread_function(int id)
198     {   thread_id = id;
199 // The next 2 lines may need to be in a critical region? And/or
200 // threadcount might need to be atomic. And the issue of creating
201 // a new thread while another is involved in garbage collection might be
202 // a hideous mess.
203         activeThreads.fetch_add(1);
204         threadcount++;
205         stack_bases[id].store(reinterpret_cast<void *>(&id));
206         int size = 3;
207         LispObject a = fixnum_of_int(0), b = fixnum_of_int(0);
208         {   std::lock_guard<std::mutex> lock(print_mutex);
209             std::printf("Starting thread %d\n", id);
210             std::fflush(stdout);
211         }
212         int sizeA = 0, sizeB = 0;
213         std::uint64_t checkA = 0, checkB = 0;
214         while (size < 400)
215         {   a = b;
216             sizeA = sizeB;
217             checkA = checkB;
218             sizeB = arithlib_implementation::mersenne_twister() % size;
219             {   std::lock_guard<std::mutex> lock(print_mutex);
220                 std::printf("Thread %d, next size will be %d [%d]\n", id, sizeB,
221                             size);
222                 std::fflush(stdout);
223             }
224             b = make_n_tree(sizeB);
225             {   std::lock_guard<std::mutex> lock(print_mutex);
226                 std::printf("Thread %d, tree made\n", id);
227                 std::fflush(stdout);
228             }
229             checkB = treehash;
230             treesize(a, sizeA, checkA);
231             treesize(b, sizeB, checkB);
232             size = size + (size+9)/10;
233         }
234         return 0;
235     }
236 
237     int main(int argc, char *argv[])
238     {   std::printf("alloctest starting\n");
239         std::fflush(stdout);
240         for (int i=0; i<max_threads; i++)
241         {   stack_bases[i] = nullptr;
242             stack_fringes[i] = nullptr;
243         }
244         heapSegmentCount = 0;
245         freePages = nullptr;
246         freePagesCount = activePagesCount = 0;
247         initHeapSegments(64.0*1024.0);
248         nurseryPage = freePages;
249         freePages = freePages->pageHeader.chain;
250         set_variables_from_page(nurseryPage);
251 // If I leave the opage empty to start with I will have to do rather a lot of
252 // work before it is full enough to trigger GC, so here I will just do a bulk
253 // allocation that uses up all but a little bit of the space.
254         get_n_bytes(pageSize - spareBytes - 1000);
255 // Each thread MUST be given a (distinct) thraed_id in the range from 0
256 /// to max_threads-1.
257         std::thread t1(thread_function, 1);
258         std::thread t2(thread_function, 2);
259         thread_function(0);
260 // all threads are done. I will run the mutatuor task in this the main
261 // thread as well as the subsidiary ones just in case that makes a difference.
262         t1.join();
263         t2.join();
264         std::printf("Memory left = %" PRId64 "\n",
265                     static_cast<std::int64_t>(Alimit.load() - Afringe.load()));
266         return 0;
267     }
268 
269 // end of alloctest.cpp
270