core: Cleanup make_cell, remove tmp cells.

* src/mes.c (make_cell__): New function.
  (make_cell_): Use it.
  (length__): New function.
  (tmp, tmp_num, tmp_num2, tmp_num_, tmp_num2_, make_tmps): Remove.
  Update callers to use make_cell__ directly.
 * src/vector.c (make_vector__): New function.
  (make_vector_): Use it.
This commit is contained in:
Jan Nieuwenhuizen 2018-04-14 08:15:49 +02:00
parent 7cad0671f3
commit ac0baf84d4
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
5 changed files with 112 additions and 119 deletions

View File

@ -1,7 +1,6 @@
#! /bin/sh
# -*-scheme-*-
MES=${MES-$(dirname $0)/mes}
export MES_ARENA=${MES_ARENA-40000}
prefix=module/
cat $0 /dev/stdin | $MES $MES_FLAGS -- "$@"
#paredit:|

View File

@ -24,21 +24,21 @@ SCM
gc_up_arena () ///((internal))
{
ARENA_SIZE *= 2;
GC_SAFETY *= 2;
#if _POSIX_SOURCE
void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
#else
char *p = g_cells;
p = realloc (p-sizeof (struct scm), 2*ARENA_SIZE*sizeof(struct scm));
#endif
#if _POSIX_SOURCE
if (!p)
error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
{
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;
g_cells++;
#endif
gc_init_news ();
return 0;
}
@ -132,12 +132,12 @@ SCM
gc_check ()
{
if (g_free + GC_SAFETY > ARENA_SIZE)
gc_pop_frame (gc (gc_push_frame ()));
gc ();
return cell_unspecified;
}
SCM
gc ()
gc_ () ///((internal))
{
if (g_debug == 2)
eputs (".");
@ -150,11 +150,30 @@ gc ()
eputs ("]...");
}
g_free = 1;
if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE)
gc_up_arena ();
if (g_cells < g_news
//&& g_free > ARENA_SIZE >> 2
&& ARENA_SIZE < MAX_ARENA_SIZE)
{
if (g_debug == 2)
eputs ("+");
if (g_debug > 2)
{
eputs (" up[");
eputs (itoa (g_cells));
eputs (",");
eputs (itoa (g_news));
eputs (":");
eputs (itoa (ARENA_SIZE));
eputs (",");
eputs (itoa (MAX_ARENA_SIZE));
eputs ("]...");
}
gc_up_arena ();
}
for (int i=g_free; i<g_symbol_max; i++)
gc_copy (i);
make_tmps (g_news);
g_symbols = gc_copy (g_symbols);
g_macros = gc_copy (g_macros);
SCM new = gc_copy (g_stack);
@ -165,5 +184,31 @@ gc ()
eputs ("\n");
}
g_stack = new;
return gc_loop (1);
gc_loop (1);
}
SCM
gc ()
{
if (g_debug > 4)
{
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 > 4)
{
eputs ("symbols: ");
write_error_ (g_symbols);
eputs ("\n");
eputs ("R0: ");
write_error_ (r0);
eputs ("\n");
}
}

135
src/mes.c
View File

@ -29,12 +29,14 @@
// take a bit more to run all tests
int ARENA_SIZE = 400000; // 32b: 1MiB, 64b: 2 MiB
#if !_POSIX_SOURCE
//int MAX_ARENA_SIZE = 60000000; // 32b: ~ 300MiB
int MAX_ARENA_SIZE = 166600000; // 32b: ~ 2GiB
//int MAX_ARENA_SIZE = 500000000; // 32b: ~ 8GiB
#else
int MAX_ARENA_SIZE = 200000000; // 32b: 2.3GiB, 64b: 4.6GiB
#endif
int GC_SAFETY = 50000;
int GC_SAFETY = 4000;
char *g_arena = 0;
typedef int SCM;
@ -229,10 +231,6 @@ struct scm scm_test = {TSYMBOL, "test",0};
#include "mes.symbols.h"
#endif
SCM tmp;
SCM tmp_num;
SCM tmp_num2;
struct function g_functions[200];
int g_function = 0;
@ -306,13 +304,13 @@ int g_function = 0;
#define NVECTOR(x) g_news[x].vector
#endif
#define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
#define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
#define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
#define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
#define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
#define MAKE_KEYWORD(x) make_cell_ (tmp_num_ (TKEYWORD), x, 0)
#define MAKE_MACRO(name, x) make_cell_ (tmp_num_ (TMACRO), STRING (name), x)
#define MAKE_CHAR(n) make_cell__ (TCHAR, 0, n)
#define MAKE_CONTINUATION(n) make_cell__ (TCONTINUATION, n, g_stack)
#define MAKE_NUMBER(n) make_cell__ (TNUMBER, 0, n)
#define MAKE_REF(n) make_cell__ (TREF, n, 0)
#define MAKE_STRING(x) make_cell__ (TSTRING, x, 0)
#define MAKE_KEYWORD(x) make_cell__ (TKEYWORD, x, 0)
#define MAKE_MACRO(name, x) make_cell__ (TMACRO, STRING (name), x)
#define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x))
@ -332,52 +330,29 @@ alloc (int n)
}
SCM
tmp_num_ (int x)
make_cell__ (int type, SCM car, SCM cdr)
{
VALUE (tmp_num) = x;
return tmp_num;
}
SCM
tmp_num2_ (int x)
{
VALUE (tmp_num2) = x;
return tmp_num2;
SCM x = alloc (1);
TYPE (x) = type;
CAR (x) = car;
CDR (x) = cdr;
return x;
}
SCM
make_cell_ (SCM type, SCM car, SCM cdr)
{
SCM x = alloc (1);
assert (TYPE (type) == TNUMBER);
TYPE (x) = VALUE (type);
if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER)
{
if (car)
CAR (x) = CAR (car);
if (cdr)
CDR (x) = CDR (cdr);
}
else if (VALUE (type) == TFUNCTION)
{
if (car)
CAR (x) = car;
if (cdr)
CDR (x) = CDR (cdr);
}
else
{
CAR (x) = car;
CDR (x) = cdr;
}
return x;
int t = VALUE (type);
if (t == TCHAR || t == TNUMBER)
return make_cell__ (t, car ? CAR (car) : 0, cdr ? CDR (cdr) : 0);
return make_cell__ (t, car, cdr);
}
SCM
make_symbol_ (SCM s) ///((internal))
{
VALUE (tmp_num) = TSYMBOL;
SCM x = make_cell_ (tmp_num, s, 0);
SCM x = make_cell__ (TSYMBOL, s, 0);
g_symbols = cons (x, g_symbols);
return x;
}
@ -451,8 +426,7 @@ arity_ (SCM x)
SCM
cons (SCM x, SCM y)
{
VALUE (tmp_num) = TPAIR;
return make_cell_ (tmp_num, x, y);
return make_cell__ (TPAIR, x, y);
}
SCM
@ -514,18 +488,24 @@ acons (SCM key, SCM value, SCM alist)
return cons (cons (key, value), alist);
}
SCM
length (SCM x)
int
length__ (SCM x)
{
int n = 0;
while (x != cell_nil)
{
n++;
if (TYPE (x) != TPAIR)
return MAKE_NUMBER (-1);
return -1;
x = CDR (x);
}
return MAKE_NUMBER (n);
return n;
}
SCM
length (SCM x)
{
return MAKE_NUMBER (length__ (x));
}
SCM apply (SCM, SCM, SCM);
@ -757,13 +737,13 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
SCM
make_closure_ (SCM args, SCM body, SCM a) ///((internal))
{
return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
return make_cell__ (TCLOSURE, cell_f, cons (cons (cell_circular, a), cons (args, body)));
}
SCM
make_variable_ (SCM var, SCM global_p) ///((internal))
{
return make_cell_ (tmp_num_ (TVARIABLE), var, global_p);
return make_cell__ (TVARIABLE, var, global_p);
}
SCM
@ -926,7 +906,6 @@ eval_apply ()
int macro_p;
eval_apply:
gc_check ();
switch (r3)
{
case cell_vm_evlis: goto evlis;
@ -968,7 +947,6 @@ eval_apply ()
}
evlis:
gc_check ();
if (r1 == cell_nil)
goto vm_return;
if (TYPE (r1) != TPAIR)
@ -983,7 +961,6 @@ eval_apply ()
goto vm_return;
apply:
gc_check ();
switch (TYPE (CAR (r1)))
{
case TFUNCTION:
@ -1074,7 +1051,6 @@ eval_apply ()
goto apply;
eval:
gc_check ();
switch (TYPE (r1))
{
case TPAIR:
@ -1108,7 +1084,8 @@ eval_apply ()
r1 = CADR (x);
goto eval_apply;
}
case cell_symbol_begin: goto begin;
case cell_symbol_begin:
goto begin;
case cell_symbol_lambda:
{
r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
@ -1217,6 +1194,7 @@ eval_apply ()
goto vm_return;
}
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
gc_check ();
goto eval;
eval_check_func:
push_cc (CDR (r2), r2, r0, cell_vm_eval2);
@ -1388,8 +1366,7 @@ eval_apply ()
{
push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
goto eval; // FIXME: expand too?!
begin_expand_primitive_load:;
input; // = current_input_port ();
begin_expand_primitive_load:
if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
;
else if (TYPE (r1) == TSTRING)
@ -1421,7 +1398,6 @@ eval_apply ()
}
r1 = r2;
expand_variable (CAR (r1), cell_nil);
//eputs ("expanded r1="); write_error_ (CAR (r1)); eputs ("\n");
push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
goto eval;
begin_expand_eval:
@ -1497,18 +1473,6 @@ mes_g_stack (SCM a) ///((internal))
// Environment setup
SCM
make_tmps (struct scm* cells)
{
tmp = g_free++;
cells[tmp].type = TCHAR;
tmp_num = g_free++;
cells[tmp_num].type = TNUMBER;
tmp_num2 = g_free++;
cells[tmp_num2].type = TNUMBER;
return 0;
}
#include "posix.c"
#include "math.c"
#include "lib.c"
@ -1520,15 +1484,10 @@ SCM
gc_init_cells () ///((internal))
{
g_cells = (struct scm *)malloc (2*ARENA_SIZE*sizeof (struct scm));
TYPE (0) = TVECTOR;
LENGTH (0) = 1000;
VECTOR (0) = 0;
#if 0 //__MESC__
g_cells += sizeof (struct scm);
#else
g_cells++;
#endif
TYPE (0) = TCHAR;
VALUE (0) = 'c';
return 0;
@ -1537,23 +1496,11 @@ gc_init_cells () ///((internal))
SCM
gc_init_news () ///((internal))
{
#if 0 //__MESC__
char *p = g_cells;
p -= sizeof (struct scm);
p += ARENA_SIZE * sizeof (struct scm);
g_news = p;
#else
g_news = g_cells-1 + ARENA_SIZE;
#endif
NTYPE (0) = TVECTOR;
NLENGTH (0) = 1000;
NVECTOR (0) = 0;
#if 0 //__MESC__
g_news += sizeof (struct scm);
#else
g_news++;
#endif
NTYPE (0) = TCHAR;
NVALUE (0) = 'n';
return 0;
@ -1571,9 +1518,7 @@ mes_symbols () ///((internal))
#include "mes.symbols.i"
#endif
g_symbol_max = g_free;
make_tmps (g_cells);
g_symbol_max = g_free++;
g_symbols = 0;
for (int i=1; i<g_symbol_max; i++)
g_symbols = cons (i, g_symbols);
@ -1845,7 +1790,6 @@ main (int argc, char *argv[])
MAX_ARENA_SIZE = atoi (p);
if (p = getenv ("MES_ARENA"))
ARENA_SIZE = atoi (p);
GC_SAFETY = ARENA_SIZE / 400;
if (p = getenv ("MES_SAFETY"))
GC_SAFETY = atoi (p);
if (argc > 1 && !strcmp (argv[1], "--help"))
@ -1900,6 +1844,7 @@ main (int argc, char *argv[])
{
eputs ("\ngc stats: [");
eputs (itoa (g_free));
MAX_ARENA_SIZE = 0;
gc (g_stack);
eputs (" => ");
eputs (itoa (g_free));

View File

@ -19,16 +19,20 @@
*/
SCM
make_vector_ (SCM n)
make_vector__ (int k)
{
int k = VALUE (n);
VALUE (tmp_num) = TVECTOR;
SCM v = alloc (k);
SCM x = make_cell_ (tmp_num, k, v);
SCM x = make_cell__ (TVECTOR, k, v);
for (int i=0; i<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
return x;
}
SCM
make_vector_ (SCM n)
{
return make_vector__ (VALUE (n));
}
SCM
vector_length (SCM x)
{
@ -71,8 +75,8 @@ vector_set_x (SCM x, SCM i, SCM e)
SCM
list_to_vector (SCM x)
{
VALUE (tmp_num) = VALUE (length (x));
SCM v = make_vector_ (tmp_num);
SCM v = make_vector__ (length__ (x));
SCM p = VECTOR (v);
while (x != cell_nil)
{

View File

@ -1,7 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES=${MES-$(dirname $0)/../src/mes}
#export MES_ARENA=${MES_ARENA-40000}
#export MES_ARENA=${MES_ARENA-200000}
$MES $MES_FLAGS "$@" < $0
exit $?
!#