347 lines
8.1 KiB
C
347 lines
8.1 KiB
C
/* -*-comment-start: "//";comment-end:""-*-
|
|
* GNU Mes --- Maxwell Equations of Software
|
|
* Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
*
|
|
* This file is part of GNU Mes.
|
|
*
|
|
* GNU Mes is free software; you can redistribute it and/or modify it
|
|
* under the terms of the GNU General Public License as published by
|
|
* the Free Software Foundation; either version 3 of the License, or (at
|
|
* your option) any later version.
|
|
*
|
|
* GNU Mes is distributed in the hope that it will be useful, but
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
* GNU General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU General Public License
|
|
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
*/
|
|
|
|
#include "mes/lib.h"
|
|
#include "mes/mes.h"
|
|
|
|
#include <assert.h>
|
|
#include <errno.h>
|
|
#include <string.h>
|
|
#include <stdlib.h>
|
|
|
|
long ARENA_SIZE;
|
|
long MAX_ARENA_SIZE;
|
|
long STACK_SIZE;
|
|
long JAM_SIZE;
|
|
long GC_SAFETY;
|
|
long MAX_STRING;
|
|
char *g_arena;
|
|
long g_free;
|
|
SCM g_stack;
|
|
SCM *g_stack_array;
|
|
struct scm *g_cells;
|
|
struct scm *g_news;
|
|
|
|
SCM
|
|
gc_init () ///((internal))
|
|
{
|
|
#if SYSTEM_LIBC
|
|
ARENA_SIZE = 100000000; // 2.3GiB
|
|
#else
|
|
ARENA_SIZE = 300000; // 32b: 3MiB, 64b: 6 MiB
|
|
#endif
|
|
MAX_ARENA_SIZE = 100000000;
|
|
STACK_SIZE = 20000;
|
|
|
|
JAM_SIZE = 20000;
|
|
GC_SAFETY = 2000;
|
|
MAX_STRING = 524288;
|
|
|
|
char *p;
|
|
if (p = getenv ("MES_MAX_ARENA"))
|
|
MAX_ARENA_SIZE = atoi (p);
|
|
if (p = getenv ("MES_ARENA"))
|
|
ARENA_SIZE = atoi (p);
|
|
JAM_SIZE = ARENA_SIZE / 10;
|
|
if (p = getenv ("MES_JAM"))
|
|
JAM_SIZE = atoi (p);
|
|
GC_SAFETY = ARENA_SIZE / 100;
|
|
if (p = getenv ("MES_SAFETY"))
|
|
GC_SAFETY = atoi (p);
|
|
if (p = getenv ("MES_STACK"))
|
|
STACK_SIZE = atoi (p);
|
|
if (p = getenv ("MES_MAX_STRING"))
|
|
MAX_STRING = atoi (p);
|
|
|
|
long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
|
|
void *a = malloc (arena_bytes + STACK_SIZE * sizeof (SCM));
|
|
g_cells = (struct scm *) a;
|
|
g_stack_array = (SCM *) (a + arena_bytes);
|
|
|
|
TYPE (0) = TVECTOR;
|
|
LENGTH (0) = 1000;
|
|
VECTOR (0) = 0;
|
|
g_cells++;
|
|
TYPE (0) = TCHAR;
|
|
VALUE (0) = 'c';
|
|
|
|
// FIXME: remove MES_MAX_STRING, grow dynamically
|
|
g_buf = (char *) malloc (MAX_STRING);
|
|
|
|
return 0;
|
|
}
|
|
|
|
SCM
|
|
gc_init_news () ///((internal))
|
|
{
|
|
g_news = g_cells + g_free;
|
|
NTYPE (0) = TVECTOR;
|
|
NLENGTH (0) = 1000;
|
|
NVECTOR (0) = 0;
|
|
g_news++;
|
|
NTYPE (0) = TCHAR;
|
|
NVALUE (0) = 'n';
|
|
return 0;
|
|
}
|
|
|
|
SCM
|
|
gc_up_arena () ///((internal))
|
|
{
|
|
long old_arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
|
|
if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
|
|
{
|
|
ARENA_SIZE <<= 1;
|
|
JAM_SIZE <<= 1;
|
|
GC_SAFETY <<= 1;
|
|
}
|
|
else
|
|
ARENA_SIZE = MAX_ARENA_SIZE - JAM_SIZE;
|
|
long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
|
|
void *p = realloc (g_cells - 1, arena_bytes + STACK_SIZE * sizeof (SCM));
|
|
if (!p)
|
|
{
|
|
eputs ("realloc failed, g_free=");
|
|
eputs (itoa (g_free));
|
|
eputs (":");
|
|
eputs (itoa (ARENA_SIZE - g_free));
|
|
eputs ("\n");
|
|
assert (0);
|
|
exit (1);
|
|
}
|
|
g_cells = (struct scm *) p;
|
|
memcpy (p + arena_bytes, p + old_arena_bytes, STACK_SIZE * sizeof (SCM));
|
|
g_cells++;
|
|
|
|
return 0;
|
|
}
|
|
|
|
void
|
|
gc_flip () ///((internal))
|
|
{
|
|
if (g_debug > 2)
|
|
{
|
|
eputs (";;; => jam[");
|
|
eputs (itoa (g_free));
|
|
eputs ("]\n");
|
|
}
|
|
if (g_free > JAM_SIZE)
|
|
JAM_SIZE = g_free + g_free / 2;
|
|
memcpy (g_cells - 1, g_news - 1, (g_free + 2) * sizeof (struct scm));
|
|
}
|
|
|
|
SCM
|
|
gc_copy (SCM old) ///((internal))
|
|
{
|
|
if (TYPE (old) == TBROKEN_HEART)
|
|
return g_cells[old].car;
|
|
SCM new = g_free++;
|
|
g_news[new] = g_cells[old];
|
|
if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR)
|
|
{
|
|
NVECTOR (new) = g_free;
|
|
for (long i = 0; i < LENGTH (old); i++)
|
|
g_news[g_free++] = g_cells[VECTOR (old) + i];
|
|
}
|
|
else if (NTYPE (new) == TBYTES)
|
|
{
|
|
char const *src = CBYTES (old);
|
|
char *dest = NCBYTES (new);
|
|
size_t length = NLENGTH (new);
|
|
memcpy (dest, src, length + 1);
|
|
g_free += bytes_cells (length) - 1;
|
|
|
|
if (g_debug > 4)
|
|
{
|
|
eputs ("gc copy bytes: ");
|
|
eputs (src);
|
|
eputs ("\n");
|
|
eputs (" length: ");
|
|
eputs (itoa (LENGTH (old)));
|
|
eputs ("\n");
|
|
eputs (" nlength: ");
|
|
eputs (itoa (NLENGTH (new)));
|
|
eputs ("\n");
|
|
eputs (" ==> ");
|
|
eputs (dest);
|
|
eputs ("\n");
|
|
}
|
|
}
|
|
TYPE (old) = TBROKEN_HEART;
|
|
CAR (old) = new;
|
|
return new;
|
|
}
|
|
|
|
SCM
|
|
gc_relocate_car (SCM new, SCM car) ///((internal))
|
|
{
|
|
g_news[new].car = car;
|
|
return cell_unspecified;
|
|
}
|
|
|
|
SCM
|
|
gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
|
|
{
|
|
g_news[new].cdr = cdr;
|
|
return cell_unspecified;
|
|
}
|
|
|
|
void
|
|
gc_loop (SCM scan) ///((internal))
|
|
{
|
|
SCM car;
|
|
SCM cdr;
|
|
while (scan < g_free)
|
|
{
|
|
if (NTYPE (scan) == TBROKEN_HEART)
|
|
error (cell_symbol_system_error, cstring_to_symbol ("gc"));
|
|
if (NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TREF || scan == 1 // null
|
|
|| NTYPE (scan) == TVARIABLE)
|
|
{
|
|
car = gc_copy (g_news[scan].car);
|
|
gc_relocate_car (scan, car);
|
|
}
|
|
if ((NTYPE (scan) == TCLOSURE || NTYPE (scan) == TCONTINUATION || NTYPE (scan) == TKEYWORD || NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TPORT || NTYPE (scan) == TSPECIAL || NTYPE (scan) == TSTRING || NTYPE (scan) == TSYMBOL || scan == 1 // null
|
|
|| NTYPE (scan) == TVALUES) && g_news[scan].cdr) // allow for 0 terminated list of symbols
|
|
{
|
|
cdr = gc_copy (g_news[scan].cdr);
|
|
gc_relocate_cdr (scan, cdr);
|
|
}
|
|
if (NTYPE (scan) == TBYTES)
|
|
scan += bytes_cells (NLENGTH (scan)) - 1;
|
|
scan++;
|
|
}
|
|
gc_flip ();
|
|
}
|
|
|
|
SCM
|
|
gc_check ()
|
|
{
|
|
if (g_free + GC_SAFETY > ARENA_SIZE)
|
|
gc ();
|
|
return cell_unspecified;
|
|
}
|
|
|
|
SCM
|
|
gc_ () ///((internal))
|
|
{
|
|
gc_init_news ();
|
|
if (g_debug == 2)
|
|
eputs (".");
|
|
if (g_debug > 2)
|
|
{
|
|
eputs (";;; gc[");
|
|
eputs (itoa (g_free));
|
|
eputs (":");
|
|
eputs (itoa (ARENA_SIZE - g_free));
|
|
eputs ("]...");
|
|
}
|
|
g_free = 1;
|
|
|
|
#if __MESC__
|
|
if (ARENA_SIZE < MAX_ARENA_SIZE && (long) g_news > 0)
|
|
#else
|
|
if (ARENA_SIZE < MAX_ARENA_SIZE && g_news > 0)
|
|
#endif
|
|
{
|
|
if (g_debug == 2)
|
|
eputs ("+");
|
|
if (g_debug > 2)
|
|
{
|
|
eputs (" up[");
|
|
eputs (itoa ((unsigned long) g_cells));
|
|
eputs (",");
|
|
eputs (itoa ((unsigned long) g_news));
|
|
eputs (":");
|
|
eputs (itoa (ARENA_SIZE));
|
|
eputs (",");
|
|
eputs (itoa (MAX_ARENA_SIZE));
|
|
eputs ("]...");
|
|
}
|
|
gc_up_arena ();
|
|
}
|
|
|
|
for (long i = g_free; i < g_symbol_max; i++)
|
|
gc_copy (i);
|
|
g_symbols = gc_copy (g_symbols);
|
|
g_macros = gc_copy (g_macros);
|
|
g_ports = gc_copy (g_ports);
|
|
m0 = gc_copy (m0);
|
|
for (long i = g_stack; i < STACK_SIZE; i++)
|
|
g_stack_array[i] = gc_copy (g_stack_array[i]);
|
|
gc_loop (1);
|
|
}
|
|
|
|
SCM
|
|
gc ()
|
|
{
|
|
if (g_debug > 5)
|
|
{
|
|
eputs ("symbols: ");
|
|
write_error_ (g_symbols);
|
|
eputs ("\n");
|
|
eputs ("R0: ");
|
|
write_error_ (r0);
|
|
eputs ("\n");
|
|
}
|
|
gc_push_frame ();
|
|
gc_ ();
|
|
gc_pop_frame ();
|
|
if (g_debug > 5)
|
|
{
|
|
eputs ("symbols: ");
|
|
write_error_ (g_symbols);
|
|
eputs ("\n");
|
|
eputs ("R0: ");
|
|
write_error_ (r0);
|
|
eputs ("\n");
|
|
}
|
|
}
|
|
|
|
SCM
|
|
gc_push_frame () ///((internal))
|
|
{
|
|
if (g_stack < 5)
|
|
assert (!"STACK FULL");
|
|
g_stack_array[--g_stack] = cell_f;
|
|
g_stack_array[--g_stack] = r0;
|
|
g_stack_array[--g_stack] = r1;
|
|
g_stack_array[--g_stack] = r2;
|
|
g_stack_array[--g_stack] = r3;
|
|
return g_stack;
|
|
}
|
|
|
|
SCM
|
|
gc_peek_frame () ///((internal))
|
|
{
|
|
r3 = g_stack_array[g_stack];
|
|
r2 = g_stack_array[g_stack + 1];
|
|
r1 = g_stack_array[g_stack + 2];
|
|
r0 = g_stack_array[g_stack + 3];
|
|
return g_stack_array[g_stack + FRAME_PROCEDURE];
|
|
}
|
|
|
|
SCM
|
|
gc_pop_frame () ///((internal))
|
|
{
|
|
SCM x = gc_peek_frame ();
|
|
g_stack += 5;
|
|
return x;
|
|
}
|