core: Prepare for pointer cells.

* include/mes/cc.h: Prepare for pointer-based cells.
* include/mes/macros.h[POINTER_CELLS]: Alternative set of macros.
* include/mes/mes.h (struct scm)[POINTER_CELLS]: Alternative definition.
* src/gc.c (copy_cell, copy_news): New function.
* include/mes/mes.h: Declare them.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2020-07-14 15:57:49 +02:00
parent 52c57da02f
commit f9a372de13
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
13 changed files with 346 additions and 101 deletions

View file

@ -21,7 +21,11 @@
#ifndef __MES_CC_H #ifndef __MES_CC_H
#define __MES_CC_H #define __MES_CC_H
#if POINTER_CELLS
typedef struct scm* SCM;
#else
typedef long SCM; typedef long SCM;
#endif
#if __MESC__ #if __MESC__
typedef long FUNCTION; typedef long FUNCTION;

View file

@ -53,7 +53,15 @@ struct timeval
*/ */
#define struct_size 12 #define struct_size 12
#if POINTER_CELLS
#define CELL(x) (x)
#else
#define CELL(x) ((x*struct_size)+g_cells) #define CELL(x) ((x*struct_size)+g_cells)
#define TYPE(x) ((x*struct_size)+g_cells)->type #define TYPE(x) ((x*struct_size)+g_cells)->type
#define CAR(x) ((x*struct_size)+g_cells)->car #define CAR(x) ((x*struct_size)+g_cells)->car
#define CDR(x) ((x*struct_size)+g_cells)->cdr #define CDR(x) ((x*struct_size)+g_cells)->cdr
@ -95,4 +103,6 @@ struct timeval
#define CADDR(x) CAR (CDR (CDR (x))) #define CADDR(x) CAR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#endif
#endif /* __MES_M2_H */ #endif /* __MES_M2_H */

View file

@ -21,6 +21,43 @@
#ifndef __MES_MACROS_H #ifndef __MES_MACROS_H
#define __MES_MACROS_H #define __MES_MACROS_H
#if POINTER_CELLS
#define TYPE(x) g_cells[x - g_cells].type
#define CAR(x) g_cells[x - g_cells].car
#define CDR(x) g_cells[x - g_cells].cdr
#define NTYPE(x) g_news[x - g_news].type
#define NCAR(x) g_news[x - g_news].car
#define NCDR(x) g_news[x - g_news].cdr
#define STYPE(x) TYPE (g_stack_array[x])
#define SCAR(x) CAR (g_stack_array[x])
#define SCDR(x) CDR (g_stack_arraynews[x])
#define BYTES(x) g_cells[x - g_cells].bytes
#define LENGTH(x) g_cells[x - g_cells].length
#define MACRO(x) g_cells[x - g_cells].macro
#define PORT(x) g_cells[x - g_cells].port
#define REF(x) g_cells[x - g_cells].ref
#define VARIABLE(x) g_cells[x - g_cells].variable
#define CLOSURE(x) g_cells[x - g_cells].closure
#define CONTINUATION(x) g_cells[x - g_cells].continuation
#define NAME(x) g_cells[x - g_cells].name
#define STRING(x) g_cells[x - g_cells].string
#define STRUCT(x) g_cells[x - g_cells].structure
#define VALUE(x) g_cells[x - g_cells].value
#define VECTOR(x) g_cells[x - g_cells].vector
#define NLENGTH(x) g_news[x - g_news].length
#define NVALUE(x) g_news[x - g_news].value
#define NSTRING(x) g_news[x - g_news].string
#define NVECTOR(x) g_news[x - g_news].vector
#else
#define TYPE(x) g_cells[x].type #define TYPE(x) g_cells[x].type
#define CAR(x) g_cells[x].car #define CAR(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr #define CDR(x) g_cells[x].cdr
@ -29,6 +66,10 @@
#define NCAR(x) g_news[x].car #define NCAR(x) g_news[x].car
#define NCDR(x) g_news[x].cdr #define NCDR(x) g_news[x].cdr
#define STYPE(x) TYPE (g_stack_array[x])
#define SCAR(x) CAR (g_stack_array[x])
#define SCDR(x) CDR (g_stack_array[x])
#define BYTES(x) g_cells[x].car #define BYTES(x) g_cells[x].car
#define LENGTH(x) g_cells[x].car #define LENGTH(x) g_cells[x].car
#define REF(x) g_cells[x].car #define REF(x) g_cells[x].car
@ -50,6 +91,8 @@
#define NSTRING(x) g_news[x].cdr #define NSTRING(x) g_news[x].cdr
#define NVECTOR(x) g_news[x].cdr #define NVECTOR(x) g_news[x].cdr
#endif
#define CAAR(x) CAR (CAR (x)) #define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x)) #define CADR(x) CAR (CDR (x))
#define CDAR(x) CDR (CAR (x)) #define CDAR(x) CDR (CAR (x))

View file

@ -21,14 +21,35 @@
#ifndef __MES_MES_H #ifndef __MES_MES_H
#define __MES_MES_H #define __MES_MES_H
#define POINTER_CELLS 0
#include <sys/types.h> #include <sys/types.h>
#include "mes/cc.h" #include "mes/cc.h"
struct scm struct scm
{ {
long type; long type;
union
{
SCM car; SCM car;
char *bytes;
long length;
SCM ref;
SCM variable;
SCM macro;
long port;
};
union
{
SCM cdr; SCM cdr;
SCM closure;
SCM continuation;
char *name;
SCM string;
SCM structure;
long value;
SCM vector;
};
}; };
/* mes */ /* mes */
@ -61,8 +82,16 @@ long JAM_SIZE;
long GC_SAFETY; long GC_SAFETY;
long MAX_STRING; long MAX_STRING;
char *g_arena; char *g_arena;
SCM cell_arena;
#if POINTER_CELLS
SCM g_free;
long g_stack;
#else
long g_free; long g_free;
SCM g_stack; SCM g_stack;
#endif
SCM *g_stack_array; SCM *g_stack_array;
struct scm *g_cells; struct scm *g_cells;
struct scm *g_news; struct scm *g_news;
@ -80,6 +109,7 @@ SCM apply_builtin (SCM fn, SCM x);
SCM builtin_name (SCM builtin); SCM builtin_name (SCM builtin);
SCM cstring_to_list (char const *s); SCM cstring_to_list (char const *s);
SCM cstring_to_symbol (char const *s); SCM cstring_to_symbol (char const *s);
SCM cell_ref (SCM cell, long index);
SCM fdisplay_ (SCM, int, int); SCM fdisplay_ (SCM, int, int);
SCM init_symbols (); SCM init_symbols ();
SCM init_time (SCM a); SCM init_time (SCM a);
@ -114,11 +144,14 @@ long length__ (SCM x);
size_t bytes_cells (size_t length); size_t bytes_cells (size_t length);
void assert_max_string (size_t i, char const *msg, char *string); void assert_max_string (size_t i, char const *msg, char *string);
void assert_msg (int check, char *msg); void assert_msg (int check, char *msg);
void copy_cell (SCM to, SCM from);
void gc_ (); void gc_ ();
void gc_init (); void gc_init ();
void gc_peek_frame (); void gc_peek_frame ();
void gc_pop_frame (); void gc_pop_frame ();
void gc_push_frame (); void gc_push_frame ();
void gc_stats_ (char const* where);
void init_symbols_ ();
#include "mes/builtins.h" #include "mes/builtins.h"
#include "mes/constants.h" #include "mes/constants.h"

View file

@ -143,4 +143,11 @@ SCM cell_symbol_test;
// CONSTANT SYMBOL_MAX 119 // CONSTANT SYMBOL_MAX 119
#define SYMBOL_MAX 119 #define SYMBOL_MAX 119
// CONSTANT CELL_UNSPECIFIED 7
#define CELL_UNSPECIFIED 7
// CONSTANT CELL_SYMBOL_RECORD_TYPE 88
#define CELL_SYMBOL_RECORD_TYPE 88
#endif /* __MES_SYMBOLS_H */ #endif /* __MES_SYMBOLS_H */

View file

@ -352,7 +352,7 @@ eval_apply ()
int global_p; int global_p;
int macro_p; int macro_p;
int t; int t;
long c; SCM c;
eval_apply: eval_apply:
if (R3 == cell_vm_evlis2) if (R3 == cell_vm_evlis2)

215
src/gc.c
View file

@ -25,10 +25,25 @@
#include <string.h> #include <string.h>
#include <stdlib.h> #include <stdlib.h>
#if __M2_PLANET__
#define M2_CELL_SIZE 12
// CONSTANT M2_CELL_SIZE 12
#else
#define M2_CELL_SIZE 1
// CONSTANT M2_CELL_SIZE 12
#endif
char * char *
cell_bytes (SCM x) cell_bytes (SCM x)
{ {
#if POINTER_CELLS
char *p = x;
return p + (2 * sizeof (long));
#elif __M2_PLANET__
CELL (x) + 8;
#else
return &CDR (x); return &CDR (x);
#endif
} }
char * char *
@ -48,7 +63,11 @@ gc_init ()
MAX_ARENA_SIZE = 100000000; MAX_ARENA_SIZE = 100000000;
STACK_SIZE = 20000; STACK_SIZE = 20000;
#if POINTER_CELLS
JAM_SIZE = 1000;
#else
JAM_SIZE = 20000; JAM_SIZE = 20000;
#endif
GC_SAFETY = 2000; GC_SAFETY = 2000;
MAX_STRING = 524288; MAX_STRING = 524288;
@ -69,32 +88,60 @@ gc_init ()
MAX_STRING = atoi (p); MAX_STRING = atoi (p);
long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm); long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
#if POINTER_CELLS
void *a = malloc (arena_bytes + STACK_SIZE * sizeof (SCM) * 2);
#else
void *a = malloc (arena_bytes + STACK_SIZE * sizeof (SCM)); void *a = malloc (arena_bytes + STACK_SIZE * sizeof (SCM));
#endif
g_cells = a; g_cells = a;
g_stack_array = a + arena_bytes; g_stack_array = a + arena_bytes;
TYPE (0) = TVECTOR; #if POINTER_CELLS
LENGTH (0) = 1000; /* The vector that holds the arenea. */
VECTOR (0) = 0; cell_arena = g_cells;
#else
/* The vector that holds the arenea. */
cell_arena = 0;
#endif
TYPE (cell_arena) = TVECTOR;
LENGTH (cell_arena) = 1000;
VECTOR (cell_arena) = 0;
g_cells = g_cells + 1; g_cells = g_cells + 1;
TYPE (0) = TCHAR; TYPE (cell_arena) = TCHAR;
VALUE (0) = 'c'; VALUE (cell_arena) = 'c';
#if !POINTER_CELLS
g_free = 1;
#else
g_free = g_cells + M2_CELL_SIZE;
#endif
/* FIXME: remove MES_MAX_STRING, grow dynamically */ /* FIXME: remove MES_MAX_STRING, grow dynamically */
g_buf = malloc (MAX_STRING); g_buf = malloc (MAX_STRING);
} }
SCM long
gc_init_news () /*:((internal)) */ gc_free ()
{ {
g_news = g_cells + g_free; #if POINTER_CELLS
NTYPE (0) = TVECTOR; return g_free - g_cells;
NLENGTH (0) = 1000; #else
NVECTOR (0) = 0; return g_free;
g_news = g_news + 1; #endif
NTYPE (0) = TCHAR; }
NVALUE (0) = 'n';
return 0; void
gc_stats_ (char const* where)
{
#if POINTER_CELLS
long i = g_free - g_cells;
#else
long i = g_free;
#endif
eputs (where);
eputs (": [");
eputs (ntoab (i, 10, 0));
eputs ("]\n");
} }
SCM SCM
@ -102,7 +149,12 @@ alloc (long n)
{ {
SCM x = g_free; SCM x = g_free;
g_free = g_free + n; g_free = g_free + n;
if (g_free > ARENA_SIZE) #if POINTER_CELLS
long i = g_free - g_cells;
#else
long i = g_free;
#endif
if (i > ARENA_SIZE)
assert_msg (0, "alloc: out of memory"); assert_msg (0, "alloc: out of memory");
return x; return x;
} }
@ -112,7 +164,12 @@ make_cell (long type, SCM car, SCM cdr)
{ {
SCM x = g_free; SCM x = g_free;
g_free = g_free + 1; g_free = g_free + 1;
if (g_free > ARENA_SIZE) #if POINTER_CELLS
long i = g_free - g_cells;
#else
long i = g_free;
#endif
if (i > ARENA_SIZE)
assert_msg (0, "alloc: out of memory"); assert_msg (0, "alloc: out of memory");
TYPE (x) = type; TYPE (x) = type;
CAR (x) = car; CAR (x) = car;
@ -120,6 +177,34 @@ make_cell (long type, SCM car, SCM cdr)
return x; return x;
} }
void
copy_cell (SCM to, SCM from)
{
TYPE (to) = TYPE (from);
CAR (to) = CAR (from);
CDR (to) = CDR (from);
}
void
copy_news (SCM to, SCM from)
{
NTYPE (to) = TYPE (from);
NCAR (to) = CAR (from);
NCDR (to) = CDR (from);
}
void
copy_stack (long index, SCM from)
{
g_stack_array[index] = from;
}
SCM
cell_ref (SCM cell, long index)
{
return cell + index;
}
SCM SCM
cons (SCM x, SCM y) cons (SCM x, SCM y)
{ {
@ -139,12 +224,7 @@ make_bytes (char const *s, size_t length)
SCM x = alloc (size); SCM x = alloc (size);
TYPE (x) = TBYTES; TYPE (x) = TBYTES;
LENGTH (x) = length; LENGTH (x) = length;
#if __M2_PLANET__ char *p = cell_bytes (x);
char *p = &g_cells[x];
p = p + 2 * sizeof (SCM);
#else
char *p = &CDR (x);
#endif
if (length == 0) if (length == 0)
p[0] = 0; p[0] = 0;
else else
@ -206,6 +286,22 @@ make_string_port (SCM x) /*:((internal)) */
return make_cell (TPORT, -length__ (g_ports) - 2, x); return make_cell (TPORT, -length__ (g_ports) - 2, x);
} }
void
gc_init_news ()
{
#if POINTER_CELLS
g_news = g_free;
#else
g_news = g_cells + g_free;
NTYPE (cell_arena) = TVECTOR;
NLENGTH (cell_arena) = 1000;
NVECTOR (cell_arena) = 0;
g_news = g_news + 1;
NTYPE (cell_arena) = TCHAR;
NVALUE (cell_arena) = 'n';
#endif
}
void void
gc_up_arena () gc_up_arena ()
{ {
@ -225,7 +321,12 @@ gc_up_arena ()
eputs ("realloc failed, g_free="); eputs ("realloc failed, g_free=");
eputs (itoa (g_free)); eputs (itoa (g_free));
eputs (":"); eputs (":");
eputs (itoa (ARENA_SIZE - g_free)); #if POINTER_CELLS
long i = g_free - g_cells;
#else
long i = g_free;
#endif
eputs (itoa (ARENA_SIZE - i));
eputs ("\n"); eputs ("\n");
assert_msg (0, "0"); assert_msg (0, "0");
exit (1); exit (1);
@ -238,15 +339,20 @@ gc_up_arena ()
void void
gc_flip () gc_flip ()
{ {
#if POINTER_CELLS
//with pointers, nevva gonna wok
//memcpy (g_cells - 1, g_news - 1, (g_free - g_cells + 2) * sizeof (struct scm));
g_cells = g_news;
#endif
if (g_debug > 2) if (g_debug > 2)
{ gc_stats_ (";;; => jam");
eputs (";;; => jam["); #if POINTER_CELLS
eputs (itoa (g_free)); // nothing
eputs ("]\n"); #else
}
if (g_free > JAM_SIZE) if (g_free > JAM_SIZE)
JAM_SIZE = g_free + g_free / 2; JAM_SIZE = g_free + g_free / 2;
memcpy (g_cells - 1, g_news - 1, (g_free + 2) * sizeof (struct scm)); memcpy (g_cells - 1, g_news - 1, (g_free + 2) * sizeof (struct scm));
#endif
} }
SCM SCM
@ -256,14 +362,14 @@ gc_copy (SCM old) /*:((internal)) */
return CAR (old); return CAR (old);
SCM new = g_free; SCM new = g_free;
g_free = g_free + 1; g_free = g_free + 1;
g_news[new] = g_cells[old]; copy_news (new, old);
if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR) if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR)
{ {
NVECTOR (new) = g_free; NVECTOR (new) = g_free;
long i; long i;
for (i = 0; i < LENGTH (old); i = i + 1) for (i = 0; i < LENGTH (old); i = i + 1)
{ {
g_news[g_free] = g_cells[VECTOR (old) + i]; copy_news (g_free, cell_ref (VECTOR (old), i));
g_free = g_free + 1; g_free = g_free + 1;
} }
} }
@ -271,7 +377,7 @@ gc_copy (SCM old) /*:((internal)) */
{ {
char const *src = cell_bytes (old); char const *src = cell_bytes (old);
char *dest = news_bytes (new); char *dest = news_bytes (new);
size_t length = NLENGTH (new); size_t length = NLENGTH (old);
memcpy (dest, src, length); memcpy (dest, src, length);
g_free = g_free + bytes_cells (length) - 1; g_free = g_free + bytes_cells (length) - 1;
@ -311,7 +417,7 @@ gc_relocate_cdr (SCM new, SCM cdr) /*:((internal)) */
} }
void void
gc_loop (SCM scan) /*:((internal)) */ gc_loop (SCM scan)
{ {
SCM car; SCM car;
SCM cdr; SCM cdr;
@ -351,9 +457,9 @@ gc_loop (SCM scan) /*:((internal)) */
gc_relocate_cdr (scan, cdr); gc_relocate_cdr (scan, cdr);
} }
if (t == TBYTES) if (t == TBYTES)
scan = scan + bytes_cells (NLENGTH (scan)); scan = scan + (bytes_cells (NLENGTH (scan)) * M2_CELL_SIZE);
else else
scan = scan + 1; scan = scan + M2_CELL_SIZE;
} }
gc_flip (); gc_flip ();
} }
@ -361,7 +467,11 @@ gc_loop (SCM scan) /*:((internal)) */
SCM SCM
gc_check () gc_check ()
{ {
#if POINTER_CELLS
if ((g_free - g_cells) + GC_SAFETY > ARENA_SIZE)
#else
if (g_free + GC_SAFETY > ARENA_SIZE) if (g_free + GC_SAFETY > ARENA_SIZE)
#endif
gc (); gc ();
return cell_unspecified; return cell_unspecified;
} }
@ -374,13 +484,20 @@ gc_ ()
eputs ("."); eputs (".");
if (g_debug > 2) if (g_debug > 2)
{ {
eputs (";;; gc["); gc_stats_ (";;; gc");
eputs (itoa (g_free)); eputs (";;; free: [");
eputs (":"); #if POINTER_CELLS
eputs (itoa (ARENA_SIZE - (g_free - g_cells)));
#else
eputs (itoa (ARENA_SIZE - g_free)); eputs (itoa (ARENA_SIZE - g_free));
#endif
eputs ("]..."); eputs ("]...");
} }
#if POINTER_CELLS
g_free = g_news;
#else
g_free = 1; g_free = 1;
#endif
if (ARENA_SIZE < MAX_ARENA_SIZE && g_news > 0) if (ARENA_SIZE < MAX_ARENA_SIZE && g_news > 0)
{ {
@ -401,16 +518,28 @@ gc_ ()
gc_up_arena (); gc_up_arena ();
} }
long i; SCM s;
for (i = g_free; i < g_symbol_max; i = i + 1) for (s = cell_nil; s < g_symbol_max; s = s + 1)
gc_copy (i); gc_copy (s);
g_symbols = gc_copy (g_symbols); g_symbols = gc_copy (g_symbols);
g_macros = gc_copy (g_macros); g_macros = gc_copy (g_macros);
g_ports = gc_copy (g_ports); g_ports = gc_copy (g_ports);
M0 = gc_copy (M0); M0 = gc_copy (M0);
long i;
for (i = g_stack; i < STACK_SIZE; i = i + 1) for (i = g_stack; i < STACK_SIZE; i = i + 1)
g_stack_array[i] = gc_copy (g_stack_array[i]); copy_stack (i, gc_copy (g_stack_array[i]));
gc_loop (1); #if POINTER_CELLS
long save_gfree = g_free;
long save_gsymbols =g_symbols;
g_symbols = 0;
///g_free = g_news + 1;
cell_nil = g_news; // hmm?
init_symbols_ ();
g_symbol_max = g_symbol;
g_free = save_gfree;
g_symbols = save_gsymbols;
#endif
gc_loop (cell_nil);
} }
SCM SCM

View file

@ -29,7 +29,7 @@ hash_cstring (char const *s, long size)
int hash = s[0] * 37; int hash = s[0] * 37;
if (s[0] != 0 && s[1] != 0) if (s[0] != 0 && s[1] != 0)
hash = hash + s[1] * 43; hash = hash + s[1] * 43;
assert_msg (size, "size"); assert_msg (size != 0, "size");
hash = hash % size; hash = hash % size;
return hash; return hash;
} }

View file

@ -131,7 +131,7 @@ memq (SCM x, SCM a)
int t = TYPE (x); int t = TYPE (x);
if (t == TCHAR || t == TNUMBER) if (t == TCHAR || t == TNUMBER)
{ {
SCM v = VALUE (x); long v = VALUE (x);
while (a != cell_nil && v != VALUE (CAR (a))) while (a != cell_nil && v != VALUE (CAR (a)))
a = CDR (a); a = CDR (a);
} }

View file

@ -224,7 +224,7 @@ assq (SCM x, SCM a)
a = CDR (a); a = CDR (a);
else if (t == TCHAR || t == TNUMBER) else if (t == TCHAR || t == TNUMBER)
{ {
SCM v = VALUE (x); long v = VALUE (x);
while (a != cell_nil && v != VALUE (CAAR (a))) while (a != cell_nil && v != VALUE (CAAR (a)))
a = CDR (a); a = CDR (a);
} }
@ -399,7 +399,6 @@ init (char **envp)
g_debug = atoi (p); g_debug = atoi (p);
open_boot (); open_boot ();
gc_init (); gc_init ();
g_ports = 1;
} }
int int
@ -420,11 +419,7 @@ main (int argc, char **argv, char **envp)
push_cc (R2, cell_unspecified, R0, cell_unspecified); push_cc (R2, cell_unspecified, R0, cell_unspecified);
if (g_debug > 2) if (g_debug > 2)
{ gc_stats_ ("\n gc boot");
eputs ("\ngc stats: [");
eputs (itoa (g_free));
eputs ("]\n");
}
if (g_debug > 3) if (g_debug > 3)
{ {
eputs ("program: "); eputs ("program: ");
@ -443,25 +438,22 @@ main (int argc, char **argv, char **envp)
if (g_debug > 5) if (g_debug > 5)
module_printer (M0); module_printer (M0);
eputs ("\ngc stats: ["); if (g_debug < 3)
eputs (itoa (g_free)); gc_stats_ ("\ngc run");
MAX_ARENA_SIZE = 0; MAX_ARENA_SIZE = 0;
gc (g_stack); gc (g_stack);
eputs (" => "); if (g_debug < 3)
eputs (itoa (g_free)); gc_stats_ (" => ");
eputs ("]\n");
eputs ("\n");
if (g_debug > 5) if (g_debug > 5)
{ {
eputs ("ports:"); eputs ("\nports:");
write_error_ (g_ports); write_error_ (g_ports);
eputs ("\n"); eputs ("\n");
} }
eputs ("\n"); eputs ("\n");
} }
return 0; return 0;
} }

View file

@ -27,14 +27,8 @@ make_struct (SCM type, SCM fields, SCM printer)
long size = 2 + length__ (fields); long size = 2 + length__ (fields);
SCM v = alloc (size); SCM v = alloc (size);
SCM x = make_cell (TSTRUCT, size, v); SCM x = make_cell (TSTRUCT, size, v);
SCM vt = vector_entry (type); copy_cell (v, vector_entry (type));
TYPE (v) = TYPE (vt); copy_cell (cell_ref (v, 1), vector_entry (printer));
CAR (v) = CAR (vt);
CDR (v) = CDR (vt);
SCM vp = vector_entry (printer);
TYPE (v + 1) = TYPE (vp);
CAR (v + 1) = CAR (vp);
CDR (v + 1) = CDR (vp);
long i; long i;
for (i = 2; i < size; i = i + 1) for (i = 2; i < size; i = i + 1)
{ {
@ -44,10 +38,7 @@ make_struct (SCM type, SCM fields, SCM printer)
e = CAR (fields); e = CAR (fields);
fields = CDR (fields); fields = CDR (fields);
} }
SCM ve = vector_entry (e); copy_cell (cell_ref (v, i), vector_entry (e));
TYPE (v + i) = TYPE (ve);
CAR (v + i) = CAR (ve);
CDR (v + i) = CDR (ve);
} }
return x; return x;
} }
@ -64,7 +55,7 @@ struct_ref_ (SCM x, long i)
{ {
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT"); assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < LENGTH (x), "i < LENGTH (x)");
SCM e = STRUCT (x) + i; SCM e = cell_ref (STRUCT (x), i);
if (TYPE (e) == TREF) if (TYPE (e) == TREF)
e = REF (e); e = REF (e);
if (TYPE (e) == TCHAR) if (TYPE (e) == TCHAR)
@ -79,7 +70,7 @@ struct_set_x_ (SCM x, long i, SCM e)
{ {
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT"); assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < LENGTH (x), "i < LENGTH (x)");
g_cells[STRUCT (x) + i] = g_cells[vector_entry (e)]; copy_cell (cell_ref (STRUCT (x), i), vector_entry (e));
return cell_unspecified; return cell_unspecified;
} }

View file

@ -23,32 +23,42 @@
#include <string.h> #include <string.h>
#if __M2_PLANET__
#define M2_CELL_SIZE 12
// CONSTANT M2_CELL_SIZE 12
#else
#define M2_CELL_SIZE 1
// CONSTANT M2_CELL_SIZE 12
#endif
#if POINTER_CELLS
SCM g_symbol;
#else
long g_symbol; long g_symbol;
#endif
SCM SCM
init_symbol (SCM x, long type, char const *name) init_symbol (SCM x, long type, char const *name)
{ {
TYPE (x) = type; TYPE (x) = type;
if (!g_symbols)
g_free = g_free + M2_CELL_SIZE;
else
{
int length = strlen (name); int length = strlen (name);
SCM string = make_string (name, length); SCM string = make_string (name, length);
CAR (x) = length; CAR (x) = length;
CDR (x) = STRING (string); CDR (x) = STRING (string);
hash_set_x (g_symbols, string, x); hash_set_x (g_symbols, string, x);
g_symbol = g_symbol + 1; }
g_symbol = g_symbol + M2_CELL_SIZE;
return x; return x;
} }
SCM void
init_symbols () /*:((internal)) */ init_symbols_ () /*:((internal)) */
{ {
g_free = SYMBOL_MAX + 1; g_symbol = cell_nil;
g_symbol_max = g_free;
g_symbols = make_hash_table_ (500);
int size = VALUE (struct_ref_ (g_symbols, 3));
g_symbol = 1;
cell_nil = 1;
cell_nil = init_symbol (g_symbol, TSPECIAL, "()"); cell_nil = init_symbol (g_symbol, TSPECIAL, "()");
cell_f = init_symbol (g_symbol, TSPECIAL, "#f"); cell_f = init_symbol (g_symbol, TSPECIAL, "#f");
cell_t = init_symbol (g_symbol, TSPECIAL, "#t"); cell_t = init_symbol (g_symbol, TSPECIAL, "#t");
@ -167,8 +177,34 @@ init_symbols () /*:((internal)) */
cell_type_vector = init_symbol (g_symbol, TSYMBOL, "<cell:vector>"); cell_type_vector = init_symbol (g_symbol, TSYMBOL, "<cell:vector>");
cell_type_broken_heart = init_symbol (g_symbol, TSYMBOL, "<cell:broken-heart>"); cell_type_broken_heart = init_symbol (g_symbol, TSYMBOL, "<cell:broken-heart>");
cell_symbol_test = init_symbol (g_symbol, TSYMBOL, "%%test"); cell_symbol_test = init_symbol (g_symbol, TSYMBOL, "%%test");
}
assert_msg (g_symbol == SYMBOL_MAX, "i == SYMBOL_MAX"); SCM
init_symbols () /*:((internal)) */
{
#if POINTER_CELLS
g_free = g_cells + M2_CELL_SIZE;
#else
g_free = 1;
#endif
g_symbols = 0;
cell_nil = g_free;
init_symbols_ ();
#if POINTER_CELLS
assert_msg ("UNSPEC", cell_unspecified - g_cells == CELL_UNSPECIFIED);
assert_msg ("RECORD-TYPE", cell_symbol_record_type - g_cells == CELL_SYMBOL_RECORD_TYPE);
g_symbol_max = g_symbol;
#else
assert_msg ("UNSPEC", cell_unspecified == CELL_UNSPECIFIED);
assert_msg ("RECORD-TYPE", cell_symbol_record_type == CELL_SYMBOL_RECORD_TYPE);
g_symbol_max = g_symbol;
#endif
g_symbols = make_hash_table_ (500);
init_symbols_ ();
g_ports = cell_nil;
SCM a = cell_nil; SCM a = cell_nil;
a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a); a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);

View file

@ -28,7 +28,8 @@ make_vector__ (long k)
SCM x = make_cell (TVECTOR, k, v); SCM x = make_cell (TVECTOR, k, v);
long i; long i;
for (i = 0; i < k; i = i + 1) for (i = 0; i < k; i = i + 1)
g_cells[v + i] = g_cells[vector_entry (cell_unspecified)]; copy_cell (cell_ref (v, i), vector_entry (cell_unspecified));
return x; return x;
} }
@ -50,7 +51,7 @@ vector_ref_ (SCM x, long i)
{ {
assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR"); assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < LENGTH (x), "i < LENGTH (x)");
SCM e = VECTOR (x) + i; SCM e = cell_ref (VECTOR (x), i);
if (TYPE (e) == TREF) if (TYPE (e) == TREF)
e = REF (e); e = REF (e);
if (TYPE (e) == TCHAR) if (TYPE (e) == TCHAR)
@ -79,7 +80,7 @@ vector_set_x_ (SCM x, long i, SCM e)
{ {
assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR"); assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < LENGTH (x), "i < LENGTH (x)");
g_cells[VECTOR (x) + i] = g_cells[vector_entry (e)]; copy_cell (cell_ref (VECTOR (x), i), vector_entry (e));
return cell_unspecified; return cell_unspecified;
} }
@ -92,12 +93,11 @@ vector_set_x (SCM x, SCM i, SCM e)
SCM SCM
list_to_vector (SCM x) list_to_vector (SCM x)
{ {
SCM v = make_vector__ (length__ (x)); SCM v = make_vector__ (length__ (x));
SCM p = VECTOR (v); SCM p = VECTOR (v);
while (x != cell_nil) while (x != cell_nil)
{ {
g_cells[p] = g_cells[vector_entry (car (x))]; copy_cell (p, vector_entry (car (x)));
p = p + 1; p = p + 1;
x = cdr (x); x = cdr (x);
} }
@ -111,7 +111,7 @@ vector_to_list (SCM v)
long i; long i;
for (i = LENGTH (v); i; i = i - 1) for (i = LENGTH (v); i; i = i - 1)
{ {
SCM e = VECTOR (v) + i - 1; SCM e = cell_ref (VECTOR (v), i - 1);
if (TYPE (e) == TREF) if (TYPE (e) == TREF)
e = REF (e); e = REF (e);
x = cons (e, x); x = cons (e, x);