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