26e4b252ce0bd0b9747887f950341404979998c9
[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   GC_SAFETY *= 2;
27   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
28 #else
29   ARENA_SIZE = ARENA_SIZE * 2;
30   GC_SAFETY = GC_SAFETY * 2;
31   //p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
32   int size = ARENA_SIZE * 2;
33   size = size * 12;
34   char *p = size;
35   p = realloc (g_cells-1, size);
36   g_cells = p;
37 #endif
38
39 #if _POSIX_SOURCE
40   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
41   g_cells = (struct scm*)p;
42   g_cells++;
43 #else
44   //assert (p);
45   //g_cells = (struct scm*)p;
46 #endif
47   gc_init_news ();
48   return 0;
49 }
50
51 SCM
52 gc_flip () ///((internal))
53 {
54   struct scm *cells = g_cells;
55   g_cells = g_news;
56   g_news = cells;
57 #if _POSIX_SOURCE
58   if (g_debug) fprintf (stderr, ";;;   => jam[%d]\n", g_free);
59 #else
60   if (g_debug)
61     {
62       eputs (";;;   => jam[");
63       eputs (itoa (g_free));
64       eputs ("]\n");
65     }
66 #endif
67   return g_stack;
68 }
69
70 SCM
71 gc_copy (SCM old) ///((internal))
72 {
73   if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
74   SCM new = g_free++;
75   g_news[new] = g_cells[old];
76   if (NTYPE (new) == TVECTOR)
77     {
78       NVECTOR (new) = g_free;
79       for (int 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 SCM
102 gc_loop (SCM scan) ///((internal))
103 {
104   while (scan < g_free)
105     {
106       if (NTYPE (scan) == TCLOSURE
107           || NTYPE (scan) == TCONTINUATION
108           || NTYPE (scan) == TFUNCTION
109           || NTYPE (scan) == TKEYWORD
110           || NTYPE (scan) == TMACRO
111           || NTYPE (scan) == TPAIR
112           || NTYPE (scan) == TREF
113           || scan == 1 // null
114           || NTYPE (scan) == TSPECIAL
115           || NTYPE (scan) == TSTRING
116           || NTYPE (scan) == TSYMBOL)
117         {
118           SCM car = gc_copy (g_news[scan].car);
119           gc_relocate_car (scan, car);
120         }
121       if ((NTYPE (scan) == TCLOSURE
122            || NTYPE (scan) == TCONTINUATION
123            || NTYPE (scan) == TMACRO
124            || NTYPE (scan) == TPAIR
125            || NTYPE (scan) == TVALUES)
126           && g_news[scan].cdr) // allow for 0 terminated list of symbols
127         {
128           SCM cdr = gc_copy (g_news[scan].cdr);
129           gc_relocate_cdr (scan, cdr);
130         }
131       scan++;
132     }
133   return gc_flip ();
134 }
135
136 SCM
137 gc_check ()
138 {
139   if (g_free + GC_SAFETY > ARENA_SIZE)
140     gc_pop_frame (gc (gc_push_frame ()));
141   return cell_unspecified;
142 }
143
144 SCM
145 gc ()
146 {
147 #if _POSIX_SOURCE
148   if (g_debug) fprintf (stderr, ";;; gc[%d:%d]...", g_free, ARENA_SIZE - g_free);
149 #else
150   if (g_debug)
151     {
152       eputs (";;; gc[");
153       eputs (itoa (g_free));
154       eputs (":");
155       eputs (itoa (ARENA_SIZE - g_free));
156       eputs ("]...");
157     }
158 #endif
159   g_free = 1;
160   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
161   for (int i=g_free; i<g_symbol_max; i++)
162     gc_copy (i);
163   make_tmps (g_news);
164   g_symbols = gc_copy (g_symbols);
165   SCM new = gc_copy (g_stack);
166 #if _POSIX_SOURCE
167   if (g_debug) fprintf (stderr, "new=%d\n", new);
168 #else
169   if (g_debug)
170     {
171       eputs ("new=");
172       eputs (itoa (new));
173       eputs ("\n");
174     }
175 #endif
176   g_stack = new;
177   return gc_loop (1);
178 }