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