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