build: Resurrect --with-cheating.
[mes.git] / src / gc.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of GNU Mes.
6  *
7  * GNU Mes is free software; you can redistribute it and/or modify it
8  * under the terms of the GNU General Public License as published by
9  * the Free Software Foundation; either version 3 of the License, or (at
10  * your option) any later version.
11  *
12  * GNU Mes is distributed in the hope that it will be useful, but
13  * WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 #include "mes/lib.h"
22 #include "mes/mes.h"
23
24 #include <assert.h>
25 #include <errno.h>
26 #include <string.h>
27 #include <stdlib.h>
28
29 long ARENA_SIZE;
30 long MAX_ARENA_SIZE;
31 long STACK_SIZE;
32 long JAM_SIZE;
33 long GC_SAFETY;
34 long MAX_STRING;
35 char *g_arena;
36 long g_free;
37 SCM g_stack;
38 SCM *g_stack_array;
39 struct scm *g_cells;
40 struct scm *g_news;
41
42 SCM
43 gc_init ()                ///((internal))
44 {
45 #if SYSTEM_LIBC
46   ARENA_SIZE = 100000000;    // 2.3GiB
47 #else
48   ARENA_SIZE = 300000;       // 32b: 3MiB, 64b: 6 MiB
49 #endif
50   MAX_ARENA_SIZE = 100000000;
51   STACK_SIZE = 20000;
52
53   JAM_SIZE = 20000;
54   GC_SAFETY = 2000;
55   MAX_STRING = 524288;
56
57   char *p;
58   if (p = getenv ("MES_MAX_ARENA"))
59     MAX_ARENA_SIZE = atoi (p);
60   if (p = getenv ("MES_ARENA"))
61     ARENA_SIZE = atoi (p);
62   JAM_SIZE = ARENA_SIZE / 10;
63   if (p = getenv ("MES_JAM"))
64     JAM_SIZE = atoi (p);
65   GC_SAFETY = ARENA_SIZE / 100;
66   if (p = getenv ("MES_SAFETY"))
67     GC_SAFETY = atoi (p);
68   if (p = getenv ("MES_STACK"))
69     STACK_SIZE = atoi (p);
70   if (p = getenv ("MES_MAX_STRING"))
71     MAX_STRING = atoi (p);
72
73   long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
74   void *a = malloc (arena_bytes + STACK_SIZE * sizeof (SCM));
75   g_cells = (struct scm *) a;
76   g_stack_array = (SCM *) (a + arena_bytes);
77
78   TYPE (0) = TVECTOR;
79   LENGTH (0) = 1000;
80   VECTOR (0) = 0;
81   g_cells++;
82   TYPE (0) = TCHAR;
83   VALUE (0) = 'c';
84
85   // FIXME: remove MES_MAX_STRING, grow dynamically
86   g_buf = (char *) malloc (MAX_STRING);
87
88   return 0;
89 }
90
91 SCM
92 gc_init_news ()                 ///((internal))
93 {
94   g_news = g_cells + g_free;
95   NTYPE (0) = TVECTOR;
96   NLENGTH (0) = 1000;
97   NVECTOR (0) = 0;
98   g_news++;
99   NTYPE (0) = TCHAR;
100   NVALUE (0) = 'n';
101   return 0;
102 }
103
104 SCM
105 gc_up_arena ()                  ///((internal))
106 {
107   long old_arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
108   if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
109     {
110       ARENA_SIZE <<= 1;
111       JAM_SIZE <<= 1;
112       GC_SAFETY <<= 1;
113     }
114   else
115     ARENA_SIZE = MAX_ARENA_SIZE - JAM_SIZE;
116   long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
117   void *p = realloc (g_cells - 1, arena_bytes + STACK_SIZE * sizeof (SCM));
118   if (!p)
119     {
120       eputs ("realloc failed, g_free=");
121       eputs (itoa (g_free));
122       eputs (":");
123       eputs (itoa (ARENA_SIZE - g_free));
124       eputs ("\n");
125       assert (0);
126       exit (1);
127     }
128   g_cells = (struct scm *) p;
129   memcpy (p + arena_bytes, p + old_arena_bytes, STACK_SIZE * sizeof (SCM));
130   g_cells++;
131
132   return 0;
133 }
134
135 void
136 gc_flip ()                      ///((internal))
137 {
138   if (g_debug > 2)
139     {
140       eputs (";;;   => jam[");
141       eputs (itoa (g_free));
142       eputs ("]\n");
143     }
144   if (g_free > JAM_SIZE)
145     JAM_SIZE = g_free + g_free / 2;
146   memcpy (g_cells - 1, g_news - 1, (g_free + 2) * sizeof (struct scm));
147 }
148
149 SCM
150 gc_copy (SCM old)               ///((internal))
151 {
152   if (TYPE (old) == TBROKEN_HEART)
153     return g_cells[old].car;
154   SCM new = g_free++;
155   g_news[new] = g_cells[old];
156   if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR)
157     {
158       NVECTOR (new) = g_free;
159       for (long i = 0; i < LENGTH (old); i++)
160         g_news[g_free++] = g_cells[VECTOR (old) + i];
161     }
162   else if (NTYPE (new) == TBYTES)
163     {
164       char const *src = CBYTES (old);
165       char *dest = NCBYTES (new);
166       size_t length = NLENGTH (new);
167       memcpy (dest, src, length + 1);
168       g_free += bytes_cells (length) - 1;
169
170       if (g_debug > 4)
171         {
172           eputs ("gc copy bytes: ");
173           eputs (src);
174           eputs ("\n");
175           eputs ("    length: ");
176           eputs (itoa (LENGTH (old)));
177           eputs ("\n");
178           eputs ("    nlength: ");
179           eputs (itoa (NLENGTH (new)));
180           eputs ("\n");
181           eputs ("        ==> ");
182           eputs (dest);
183           eputs ("\n");
184         }
185     }
186   TYPE (old) = TBROKEN_HEART;
187   CAR (old) = new;
188   return new;
189 }
190
191 SCM
192 gc_relocate_car (SCM new, SCM car)      ///((internal))
193 {
194   g_news[new].car = car;
195   return cell_unspecified;
196 }
197
198 SCM
199 gc_relocate_cdr (SCM new, SCM cdr)      ///((internal))
200 {
201   g_news[new].cdr = cdr;
202   return cell_unspecified;
203 }
204
205 void
206 gc_loop (SCM scan)              ///((internal))
207 {
208   SCM car;
209   SCM cdr;
210   while (scan < g_free)
211     {
212       if (NTYPE (scan) == TBROKEN_HEART)
213         error (cell_symbol_system_error, cstring_to_symbol ("gc"));
214       if (NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TREF || scan == 1  // null
215           || NTYPE (scan) == TVARIABLE)
216         {
217           car = gc_copy (g_news[scan].car);
218           gc_relocate_car (scan, car);
219         }
220       if ((NTYPE (scan) == TCLOSURE || NTYPE (scan) == TCONTINUATION || NTYPE (scan) == TKEYWORD || NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TPORT || NTYPE (scan) == TSPECIAL || NTYPE (scan) == TSTRING || NTYPE (scan) == TSYMBOL || scan == 1     // null
221            || NTYPE (scan) == TVALUES) && g_news[scan].cdr)     // allow for 0 terminated list of symbols
222         {
223           cdr = gc_copy (g_news[scan].cdr);
224           gc_relocate_cdr (scan, cdr);
225         }
226       if (NTYPE (scan) == TBYTES)
227         scan += bytes_cells (NLENGTH (scan)) - 1;
228       scan++;
229     }
230   gc_flip ();
231 }
232
233 SCM
234 gc_check ()
235 {
236   if (g_free + GC_SAFETY > ARENA_SIZE)
237     gc ();
238   return cell_unspecified;
239 }
240
241 SCM
242 gc_ ()                          ///((internal))
243 {
244   gc_init_news ();
245   if (g_debug == 2)
246     eputs (".");
247   if (g_debug > 2)
248     {
249       eputs (";;; gc[");
250       eputs (itoa (g_free));
251       eputs (":");
252       eputs (itoa (ARENA_SIZE - g_free));
253       eputs ("]...");
254     }
255   g_free = 1;
256
257 #if __MESC__
258   if (ARENA_SIZE < MAX_ARENA_SIZE && (long) g_news > 0)
259 #else
260   if (ARENA_SIZE < MAX_ARENA_SIZE && g_news > 0)
261 #endif
262     {
263       if (g_debug == 2)
264         eputs ("+");
265       if (g_debug > 2)
266         {
267           eputs (" up[");
268           eputs (itoa ((unsigned long) g_cells));
269           eputs (",");
270           eputs (itoa ((unsigned long) g_news));
271           eputs (":");
272           eputs (itoa (ARENA_SIZE));
273           eputs (",");
274           eputs (itoa (MAX_ARENA_SIZE));
275           eputs ("]...");
276         }
277       gc_up_arena ();
278     }
279
280   for (long i = g_free; i < g_symbol_max; i++)
281     gc_copy (i);
282   g_symbols = gc_copy (g_symbols);
283   g_macros = gc_copy (g_macros);
284   g_ports = gc_copy (g_ports);
285   m0 = gc_copy (m0);
286   for (long i = g_stack; i < STACK_SIZE; i++)
287     g_stack_array[i] = gc_copy (g_stack_array[i]);
288   gc_loop (1);
289 }
290
291 SCM
292 gc ()
293 {
294   if (g_debug > 5)
295     {
296       eputs ("symbols: ");
297       write_error_ (g_symbols);
298       eputs ("\n");
299       eputs ("R0: ");
300       write_error_ (r0);
301       eputs ("\n");
302     }
303   gc_push_frame ();
304   gc_ ();
305   gc_pop_frame ();
306   if (g_debug > 5)
307     {
308       eputs ("symbols: ");
309       write_error_ (g_symbols);
310       eputs ("\n");
311       eputs ("R0: ");
312       write_error_ (r0);
313       eputs ("\n");
314     }
315 }
316
317 SCM
318 gc_push_frame ()                ///((internal))
319 {
320   if (g_stack < 5)
321     assert (!"STACK FULL");
322   g_stack_array[--g_stack] = cell_f;
323   g_stack_array[--g_stack] = r0;
324   g_stack_array[--g_stack] = r1;
325   g_stack_array[--g_stack] = r2;
326   g_stack_array[--g_stack] = r3;
327   return g_stack;
328 }
329
330 SCM
331 gc_peek_frame ()                ///((internal))
332 {
333   r3 = g_stack_array[g_stack];
334   r2 = g_stack_array[g_stack + 1];
335   r1 = g_stack_array[g_stack + 2];
336   r0 = g_stack_array[g_stack + 3];
337   return g_stack_array[g_stack + FRAME_PROCEDURE];
338 }
339
340 SCM
341 gc_pop_frame ()                 ///((internal))
342 {
343   SCM x = gc_peek_frame ();
344   g_stack += 5;
345   return x;
346 }