mes: Single environment lookup for variables, SICP chapter 3.
[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           || NTYPE (scan) == TVARIABLE)
107         {
108           SCM car = gc_copy (g_news[scan].car);
109           gc_relocate_car (scan, car);
110         }
111       if ((NTYPE (scan) == TCLOSURE
112            || NTYPE (scan) == TCONTINUATION
113            || NTYPE (scan) == TMACRO
114            || NTYPE (scan) == TPAIR
115            || NTYPE (scan) == TVALUES
116            || NTYPE (scan) == TVARIABLE)
117           && g_news[scan].cdr) // allow for 0 terminated list of symbols
118         {
119           SCM cdr = gc_copy (g_news[scan].cdr);
120           gc_relocate_cdr (scan, cdr);
121         }
122       scan++;
123     }
124   return gc_flip ();
125 }
126
127 SCM
128 gc_check ()
129 {
130   if (g_free + GC_SAFETY > ARENA_SIZE)
131     gc_pop_frame (gc (gc_push_frame ()));
132   return cell_unspecified;
133 }
134
135 SCM
136 gc ()
137 {
138   if (g_debug == 1)
139     eputs (".");
140   if (g_debug > 1)
141     {
142       eputs (";;; gc[");
143       eputs (itoa (g_free));
144       eputs (":");
145       eputs (itoa (ARENA_SIZE - g_free));
146       eputs ("]...");
147     }
148   g_free = 1;
149   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE)
150     gc_up_arena ();
151   for (int i=g_free; i<g_symbol_max; i++)
152     gc_copy (i);
153   make_tmps (g_news);
154   g_symbols = gc_copy (g_symbols);
155   g_macros = gc_copy (g_macros);
156   SCM new = gc_copy (g_stack);
157   if (g_debug > 1)
158     {
159       eputs ("new=");
160       eputs (itoa (new));
161       eputs ("\n");
162     }
163   g_stack = new;
164   return gc_loop (1);
165 }