mescc: Support regular C99 compile, headers + mlibc.
[mes.git] / src / gc.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017 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 #include <errno.h>
22
23 SCM
24 gc_up_arena () ///((internal))
25 {
26   ARENA_SIZE *= 2;
27   GC_SAFETY *= 2;
28 #if _POSIX_SOURCE
29   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
30 #else
31   char *p = g_cells;
32   p = realloc (p-sizeof (struct scm), 2*ARENA_SIZE*sizeof(struct scm));
33 #endif
34
35 #if _POSIX_SOURCE
36   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
37   g_cells = (struct scm*)p;
38   g_cells++;
39 #endif
40   gc_init_news ();
41   return 0;
42 }
43
44 SCM
45 gc_flip () ///((internal))
46 {
47   struct scm *cells = g_cells;
48   g_cells = g_news;
49   g_news = cells;
50   if (g_debug > 1)
51     {
52       eputs (";;;   => jam[");
53       eputs (itoa (g_free));
54       eputs ("]\n");
55     }
56   return g_stack;
57 }
58
59 SCM
60 gc_copy (SCM old) ///((internal))
61 {
62   if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
63   SCM new = g_free++;
64   g_news[new] = g_cells[old];
65   if (NTYPE (new) == TVECTOR)
66     {
67       NVECTOR (new) = g_free;
68       for (int i=0; i<LENGTH (old); i++)
69         g_news[g_free++] = g_cells[VECTOR (old)+i];
70     }
71   TYPE (old) = TBROKEN_HEART;
72   CAR (old) = new;
73   return new;
74 }
75
76 SCM
77 gc_relocate_car (SCM new, SCM car) ///((internal))
78 {
79   g_news[new].car = car;
80   return cell_unspecified;
81 }
82
83 SCM
84 gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
85 {
86   g_news[new].cdr = cdr;
87   return cell_unspecified;
88 }
89
90 SCM
91 gc_loop (SCM scan) ///((internal))
92 {
93   while (scan < g_free)
94     {
95       if (NTYPE (scan) == TCLOSURE
96           || NTYPE (scan) == TCONTINUATION
97           || NTYPE (scan) == TFUNCTION
98           || NTYPE (scan) == TKEYWORD
99           || NTYPE (scan) == TMACRO
100           || NTYPE (scan) == TPAIR
101           || NTYPE (scan) == TREF
102           || scan == 1 // null
103           || NTYPE (scan) == TSPECIAL
104           || NTYPE (scan) == TSTRING
105           || NTYPE (scan) == TSYMBOL)
106         {
107           SCM car = gc_copy (g_news[scan].car);
108           gc_relocate_car (scan, car);
109         }
110       if ((NTYPE (scan) == TCLOSURE
111            || NTYPE (scan) == TCONTINUATION
112            || NTYPE (scan) == TMACRO
113            || NTYPE (scan) == TPAIR
114            || NTYPE (scan) == TVALUES)
115           && g_news[scan].cdr) // allow for 0 terminated list of symbols
116         {
117           SCM cdr = gc_copy (g_news[scan].cdr);
118           gc_relocate_cdr (scan, cdr);
119         }
120       scan++;
121     }
122   return gc_flip ();
123 }
124
125 SCM
126 gc_check ()
127 {
128   if (g_free + GC_SAFETY > ARENA_SIZE)
129     gc_pop_frame (gc (gc_push_frame ()));
130   return cell_unspecified;
131 }
132
133 SCM
134 gc ()
135 {
136   if (g_debug == 1) eputs (".");
137   if (g_debug > 1)
138     {
139       eputs (";;; gc[");
140       eputs (itoa (g_free));
141       eputs (":");
142       eputs (itoa (ARENA_SIZE - g_free));
143       eputs ("]...");
144     }
145   g_free = 1;
146   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
147   for (int i=g_free; i<g_symbol_max; i++)
148     gc_copy (i);
149   make_tmps (g_news);
150   g_symbols = gc_copy (g_symbols);
151   SCM new = gc_copy (g_stack);
152   if (g_debug > 1)
153     {
154       eputs ("new=");
155       eputs (itoa (new));
156       eputs ("\n");
157     }
158   g_stack = new;
159   return gc_loop (1);
160 }