mes: Make debug levels 4 and 5 usable.
[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 <errno.h>
22
23 size_t bytes_cells (size_t length);
24
25 SCM
26 gc_up_arena ()                  ///((internal))
27 {
28   long old_arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
29   if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
30     {
31       ARENA_SIZE <<= 1;
32       JAM_SIZE <<= 1;
33       GC_SAFETY <<= 1;
34     }
35   else
36     ARENA_SIZE = MAX_ARENA_SIZE - JAM_SIZE;
37   long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
38   void *p = realloc (g_cells - 1, arena_bytes + STACK_SIZE * sizeof (SCM));
39   if (!p)
40     {
41       eputs ("realloc failed, g_free=");
42       eputs (itoa (g_free));
43       eputs (":");
44       eputs (itoa (ARENA_SIZE - g_free));
45       eputs ("\n");
46       assert (0);
47       exit (1);
48     }
49   g_cells = (struct scm *) p;
50   memcpy (p + arena_bytes, p + old_arena_bytes, STACK_SIZE * sizeof (SCM));
51   g_cells++;
52
53   return 0;
54 }
55
56 void
57 gc_flip ()                      ///((internal))
58 {
59   if (g_debug > 2)
60     {
61       eputs (";;;   => jam[");
62       eputs (itoa (g_free));
63       eputs ("]\n");
64     }
65   if (g_free > JAM_SIZE)
66     JAM_SIZE = g_free + g_free / 2;
67   memcpy (g_cells - 1, g_news - 1, (g_free + 2) * sizeof (struct scm));
68 }
69
70 SCM
71 gc_copy (SCM old)               ///((internal))
72 {
73   if (TYPE (old) == TBROKEN_HEART)
74     return g_cells[old].car;
75   SCM new = g_free++;
76   g_news[new] = g_cells[old];
77   if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR)
78     {
79       NVECTOR (new) = g_free;
80       for (long i = 0; i < LENGTH (old); i++)
81         g_news[g_free++] = g_cells[VECTOR (old) + i];
82     }
83   else if (NTYPE (new) == TBYTES)
84     {
85       char const *src = CBYTES (old);
86       char *dest = NCBYTES (new);
87       size_t length = NLENGTH (new);
88       memcpy (dest, src, length + 1);
89       g_free += bytes_cells (length) - 1;
90
91       if (g_debug > 4)
92         {
93           eputs ("gc copy bytes: ");
94           eputs (src);
95           eputs ("\n");
96           eputs ("    length: ");
97           eputs (itoa (LENGTH (old)));
98           eputs ("\n");
99           eputs ("    nlength: ");
100           eputs (itoa (NLENGTH (new)));
101           eputs ("\n");
102           eputs ("        ==> ");
103           eputs (dest);
104           eputs ("\n");
105         }
106     }
107   TYPE (old) = TBROKEN_HEART;
108   CAR (old) = new;
109   return new;
110 }
111
112 SCM
113 gc_relocate_car (SCM new, SCM car)      ///((internal))
114 {
115   g_news[new].car = car;
116   return cell_unspecified;
117 }
118
119 SCM
120 gc_relocate_cdr (SCM new, SCM cdr)      ///((internal))
121 {
122   g_news[new].cdr = cdr;
123   return cell_unspecified;
124 }
125
126 void
127 gc_loop (SCM scan)              ///((internal))
128 {
129   SCM car;
130   SCM cdr;
131   while (scan < g_free)
132     {
133       if (NTYPE (scan) == TBROKEN_HEART)
134         error (cell_symbol_system_error, cstring_to_symbol ("gc"));
135       if (NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TREF || scan == 1  // null
136           || NTYPE (scan) == TVARIABLE)
137         {
138           car = gc_copy (g_news[scan].car);
139           gc_relocate_car (scan, car);
140         }
141       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
142            || NTYPE (scan) == TVALUES) && g_news[scan].cdr)     // allow for 0 terminated list of symbols
143         {
144           cdr = gc_copy (g_news[scan].cdr);
145           gc_relocate_cdr (scan, cdr);
146         }
147       if (NTYPE (scan) == TBYTES)
148         scan += bytes_cells (NLENGTH (scan)) - 1;
149       scan++;
150     }
151   gc_flip ();
152 }
153
154 SCM
155 gc_check ()
156 {
157   if (g_free + GC_SAFETY > ARENA_SIZE)
158     gc ();
159   return cell_unspecified;
160 }
161
162 SCM
163 gc_init_news ()                 ///((internal))
164 {
165   g_news = g_cells + g_free;
166   NTYPE (0) = TVECTOR;
167   NLENGTH (0) = 1000;
168   NVECTOR (0) = 0;
169   g_news++;
170   NTYPE (0) = TCHAR;
171   NVALUE (0) = 'n';
172   return 0;
173 }
174
175 SCM
176 gc_ ()                          ///((internal))
177 {
178   gc_init_news ();
179   if (g_debug == 2)
180     eputs (".");
181   if (g_debug > 2)
182     {
183       eputs (";;; gc[");
184       eputs (itoa (g_free));
185       eputs (":");
186       eputs (itoa (ARENA_SIZE - g_free));
187       eputs ("]...");
188     }
189   g_free = 1;
190
191 #if __MESC__
192   if (ARENA_SIZE < MAX_ARENA_SIZE && (long) g_news > 0)
193 #else
194   if (ARENA_SIZE < MAX_ARENA_SIZE && g_news > 0)
195 #endif
196     {
197       if (g_debug == 2)
198         eputs ("+");
199       if (g_debug > 2)
200         {
201           eputs (" up[");
202           eputs (itoa ((unsigned long) g_cells));
203           eputs (",");
204           eputs (itoa ((unsigned long) g_news));
205           eputs (":");
206           eputs (itoa (ARENA_SIZE));
207           eputs (",");
208           eputs (itoa (MAX_ARENA_SIZE));
209           eputs ("]...");
210         }
211       gc_up_arena ();
212     }
213
214   for (long i = g_free; i < g_symbol_max; i++)
215     gc_copy (i);
216   g_symbols = gc_copy (g_symbols);
217   g_macros = gc_copy (g_macros);
218   g_ports = gc_copy (g_ports);
219   m0 = gc_copy (m0);
220   for (long i = g_stack; i < STACK_SIZE; i++)
221     g_stack_array[i] = gc_copy (g_stack_array[i]);
222   gc_loop (1);
223 }
224
225 SCM
226 gc ()
227 {
228   if (g_debug > 5)
229     {
230       eputs ("symbols: ");
231       write_error_ (g_symbols);
232       eputs ("\n");
233       eputs ("R0: ");
234       write_error_ (r0);
235       eputs ("\n");
236     }
237   gc_push_frame ();
238   gc_ ();
239   gc_pop_frame ();
240   if (g_debug > 5)
241     {
242       eputs ("symbols: ");
243       write_error_ (g_symbols);
244       eputs ("\n");
245       eputs ("R0: ");
246       write_error_ (r0);
247       eputs ("\n");
248     }
249 }