mini-mes: Workarounds for gc.c.
[mes.git] / gc.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of Mes.
6  *
7  * 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  * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 SCM
22 gc_up_arena () ///((internal))
23 {
24 #if _POSIX_SOURCE
25   ARENA_SIZE *= 2;
26   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
27 #else
28   ARENA_SIZE = ARENA_SIZE * 2;
29   //p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
30   int size = ARENA_SIZE * 2;
31   size = size * 12;
32   char *p = size;
33   p = realloc (g_cells-1, size);
34   g_cells = p;
35 #endif
36
37 #if _POSIX_SOURCE
38   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
39   g_cells = (struct scm*)p;
40   g_cells++;
41 #else
42   //assert (p);
43   //g_cells = (struct scm*)p;
44 #endif
45   gc_init_news ();
46   return 0;
47 }
48
49 SCM
50 gc_flip () ///((internal))
51 {
52   struct scm *cells = g_cells;
53   g_cells = g_news;
54   g_news = cells;
55 #if _POSIX_SOURCE
56   if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
57 #else
58   if (g_debug)
59     {
60       eputs (" => jam[");
61       eputs (itoa (g_free));
62       eputs ("]\n");
63     }
64 #endif
65   return g_stack;
66 }
67
68 SCM
69 gc_copy (SCM old) ///((internal))
70 {
71   if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
72   SCM new = g_free++;
73 #if 0
74   g_news[new] = g_cells[old];
75 #else
76   SCM y = new;
77   SCM z = old;
78   SCM zz = TYPE (z);
79   NTYPE (y) = zz;
80   zz = CAR (z);
81   NCAR (y) = zz;
82   zz = CDR (z);
83   NCDR (y) = zz;
84 #endif
85   if (NTYPE (new) == TVECTOR)
86     {
87       NVECTOR (new) = g_free;
88       for (int i=0; i<LENGTH (old); i++)
89 #if 0
90         //__GNUC__
91         g_news[g_free++] = g_cells[VECTOR (old)+i];
92 #else
93       {
94         //eputs ("gc_copy\n");
95         y = g_free;
96         g_free++;
97         z = VECTOR (old);
98         z = z + i;
99         //z = g_cells[z];
100         zz = TYPE (z);
101         NTYPE (y) = zz;
102         zz = CAR (z);
103         NCAR (y) = zz;
104         zz = CDR (z);
105         NCDR (y) = zz;
106       }
107 #endif
108     }
109   TYPE (old) = TBROKEN_HEART;
110   CAR (old) = new;
111   return new;
112 }
113
114 SCM
115 gc_relocate_car (SCM new, SCM car) ///((internal))
116 {
117   g_news[new].car = car;
118   return cell_unspecified;
119 }
120
121 SCM
122 gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
123 {
124   g_news[new].cdr = cdr;
125   return cell_unspecified;
126 }
127
128 SCM
129 gc_loop (SCM scan) ///((internal))
130 {
131   while (scan < g_free)
132     {
133       if (NTYPE (scan) == TCLOSURE
134           || NTYPE (scan) == TCONTINUATION
135           || NTYPE (scan) == TFUNCTION
136           || NTYPE (scan) == TKEYWORD
137           || NTYPE (scan) == TMACRO
138           || NTYPE (scan) == TPAIR
139           || NTYPE (scan) == TREF
140           || scan == 1 // null
141           || NTYPE (scan) == TSPECIAL
142           || NTYPE (scan) == TSTRING
143           || NTYPE (scan) == TSYMBOL)
144         {
145           SCM car = gc_copy (g_news[scan].car);
146           gc_relocate_car (scan, car);
147         }
148       if ((NTYPE (scan) == TCLOSURE
149            || NTYPE (scan) == TCONTINUATION
150            || NTYPE (scan) == TMACRO
151            || NTYPE (scan) == TPAIR
152            || NTYPE (scan) == TVALUES)
153           && g_news[scan].cdr) // allow for 0 terminated list of symbols
154         {
155           SCM cdr = gc_copy (g_news[scan].cdr);
156           gc_relocate_cdr (scan, cdr);
157         }
158       scan++;
159     }
160   return gc_flip ();
161 }
162
163 SCM
164 gc ()
165 {
166 #if _POSIX_SOURCE
167   if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
168 #else
169   if (g_debug)
170     {
171       eputs ("***gc[");
172       eputs (itoa (g_free));
173       eputs ("]...");
174     }
175 #endif
176   g_free = 1;
177   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
178   for (int i=g_free; i<g_symbol_max; i++)
179     gc_copy (i);
180   make_tmps (g_news);
181   g_symbols = gc_copy (g_symbols);
182   SCM new = gc_copy (g_stack);
183 #if _POSIX_SOURCE
184   if (g_debug) fprintf (stderr, "new=%d\n", new);
185 #else
186   if (g_debug)
187     {
188       eputs ("new=");
189       eputs (itoa (new));
190       eputs ("\n");
191     }
192 #endif
193   g_stack = new;
194   return gc_loop (1);
195 }