mes/src/gc.c

/* -*-comment-start: "//";comment-end:""-*-
 * GNU Mes --- Maxwell Equations of Software
 * Copyright © 2016,2017,2018,2019 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 <errno.h>
#include <fcntl.h>
#include <string.h>
#include <stdlib.h>

int g_dump_filedes;

#define M2_CELL_SIZE 1
// CONSTANT M2_CELL_SIZE 12

char *
cell_bytes (SCM x)
{
  char *p = x;
  return p + (2 * sizeof (long));
}

char *
news_bytes (SCM x)
{
  char *p = x;
  return p + (2 * sizeof (long));
}

void
gc_init ()
{
#if SYSTEM_LIBC
  ARENA_SIZE = 100000000;       /* 2.3GiB */
#elif ! __M2_PLANET__
  ARENA_SIZE = 300000;          /* 32b: 3MiB, 64b: 6 MiB */
#else
  ARENA_SIZE = 20000000;
#endif
  STACK_SIZE = 20000;

  JAM_SIZE = 10;
  MAX_ARENA_SIZE = 10000000;
  GC_SAFETY = 2000;
  MAX_STRING = 524288;

  char *p;
  p = getenv ("MES_MAX_ARENA");
  if (p != 0)
    MAX_ARENA_SIZE = atoi (p);
  p = getenv ("MES_ARENA");
  if (p != 0)
    ARENA_SIZE = atoi (p);
  JAM_SIZE = ARENA_SIZE / 10;
  p = getenv ("MES_JAM");
  if (p != 0)
    JAM_SIZE = atoi (p);
  GC_SAFETY = ARENA_SIZE / 100;
  p = getenv ("MES_SAFETY");
  if (p != 0)
    GC_SAFETY = atoi (p);
  p = getenv ("MES_STACK");
  if (p != 0)
    STACK_SIZE = atoi (p);
  p = getenv ("MES_MAX_STRING");
  if (p != 0)
    MAX_STRING = atoi (p);

  long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
  long alloc_bytes = arena_bytes + (STACK_SIZE * sizeof (struct scm));

  g_arena = malloc (alloc_bytes);
  g_cells = g_arena;
  g_stack_array = g_arena + arena_bytes;

  /* The vector that holds the arenea. */
  cell_arena = g_cells;

  cell_zero = cell_arena + M2_CELL_SIZE;

  g_cells = g_cells + M2_CELL_SIZE; /* Hmm? */

  TYPE (cell_arena) = TVECTOR;
  LENGTH (cell_arena) = 1000;
  VECTOR (cell_arena) = cell_zero;

  TYPE (cell_zero) = TCHAR;
  VALUE (cell_zero) = 'c';

  g_free = g_cells + M2_CELL_SIZE;

  /* FIXME: remove MES_MAX_STRING, grow dynamically. */
  g_buf = malloc (MAX_STRING);
}

long
gc_free ()
{
  return (g_free - g_cells) / M2_CELL_SIZE;
}

void
gc_stats_ (char const* where)
{
  long i = g_free - g_cells;
  i = i / M2_CELL_SIZE;
  eputs (where);
  eputs (": [");
  eputs (ltoa (i));
  eputs ("]\n");
}

SCM
alloc (long n)
{
  SCM x = g_free;
  g_free = g_free + (n * M2_CELL_SIZE);
  long i = g_free - g_cells;
  i = i / M2_CELL_SIZE;

  if (i > ARENA_SIZE)
    assert_msg (0, "alloc: out of memory");
  return x;
}

SCM
make_cell (long type, SCM car, SCM cdr)
{
  SCM x = g_free;
  g_free = g_free + M2_CELL_SIZE;
  long i = g_free - g_cells;
  i = i / M2_CELL_SIZE;
  if (i > ARENA_SIZE)
    assert_msg (0, "alloc: out of memory");
  TYPE (x) = type;
  CAR (x) = car;
  CDR (x) = cdr;
  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 * M2_CELL_SIZE);
}

SCM
cons (SCM x, SCM y)
{
  return make_cell (TPAIR, x, y);
}

size_t
bytes_cells (size_t length)
{
  return (sizeof (long) + sizeof (long) + length - 1 + sizeof (SCM)) / sizeof (SCM);
}

SCM
make_bytes (char const *s, size_t length)
{
  size_t size = bytes_cells (length);
  SCM x = alloc (size);
  TYPE (x) = TBYTES;
  LENGTH (x) = length;
  char *p = cell_bytes (x);
  if (length == 0)
    p[0] = 0;
  else
    memcpy (p, s, length);

  return x;
}

SCM
make_char (int n)
{
  return make_cell (TCHAR, 0, n);
}

SCM
make_continuation (long n)
{
  return make_cell (TCONTINUATION, n, g_stack);
}

SCM
make_macro (SCM name, SCM x)    /*:((internal)) */
{
  return make_cell (TMACRO, x, STRING (name));
}

SCM
make_number (long n)
{
  return make_cell (TNUMBER, 0, n);
}

SCM
make_ref (SCM x)                /*:((internal)) */
{
  return make_cell (TREF, x, 0);
}

SCM
make_string (char const *s, size_t length)
{
  if (length > MAX_STRING)
    assert_max_string (length, "make_string", s);
  SCM x = make_cell (TSTRING, length, 0);
  SCM v = make_bytes (s, length + 1);
  CDR (x) = v;
  return x;
}

SCM
make_string0 (char const *s)
{
  return make_string (s, strlen (s));
}

SCM
make_string_port (SCM x)        /*:((internal)) */
{
  return make_cell (TPORT, -length__ (g_ports) - 2, x);
}

void
gc_init_news ()
{
  g_news = g_free;
  SCM ncell_arena = g_news;
  SCM ncell_zero = ncell_arena + M2_CELL_SIZE;

  g_news = g_news + M2_CELL_SIZE;

  NTYPE (ncell_arena) = TVECTOR;
  NLENGTH (ncell_arena) = LENGTH (cell_arena);
  NVECTOR (ncell_arena) = g_news;

  NTYPE (ncell_zero) = TCHAR;
  NVALUE (ncell_zero) = 'n';
}

void
gc_up_arena ()
{
  long old_arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
  if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
    {
      ARENA_SIZE = ARENA_SIZE << 1;
      JAM_SIZE = JAM_SIZE << 1;
      GC_SAFETY = GC_SAFETY << 1;
    }
  else
    ARENA_SIZE = MAX_ARENA_SIZE - JAM_SIZE;
  long arena_bytes = (ARENA_SIZE + JAM_SIZE) * sizeof (struct scm);
  long stack_offset = (arena_bytes * 2);
  long realloc_bytes = (arena_bytes * 2) + (STACK_SIZE * sizeof (struct scm));
  void *p = realloc (g_cells - M2_CELL_SIZE, realloc_bytes);
  if (p == 0)
    {
      eputs ("realloc failed, g_free=");
      eputs (ltoa (g_free));
      eputs (":");
      long i = g_free - g_cells;
      i = i / M2_CELL_SIZE;
      eputs (ltoa (ARENA_SIZE - i));
      eputs ("\n");
      assert_msg (0, "0");
      exit (1);
    }
  g_cells = p;
  memcpy (p + stack_offset, p + old_arena_bytes, STACK_SIZE * sizeof (SCM));
  g_cells = g_cells + M2_CELL_SIZE;
}

/* A pointer relocating memcpy for pointer cells to avoid using only
   half of the allocated cells.

   For number based cells a simply memcpy could be used, as number
   references are relative.

   A simple stop and copy (SICP 5.3) garbage collector allocates twice
   the cell arena size only for the garbage collector.  The garbage
   collector switches back and forth between cells and news, thus
   utilizing only half the allocated memory. */
void
gc_cellcpy (struct scm *dest, struct scm *src, size_t n)
{
  void *p = src;
  void *q = dest;
  long dist = p - q;
  while (n != 0)
    {
      long t = src->type;
      long a = src->car;
      long d = src->cdr;
      dest->type = t;
      if (t == TBROKEN_HEART)
        assert_msg (0, "gc_cellcpy: broken heart");
      if (t == TMACRO
          || t == TPAIR
          || t == TREF
          || t == TVARIABLE)
        dest->car = a - dist;
      else
        dest->car = a;
      if (t == TBYTES
          || t == TCLOSURE
          || t == TCONTINUATION
          || t == TKEYWORD
          || t == TMACRO
          || t == TPAIR
          || t == TPORT
          || t == TSPECIAL
          || t == TSTRING
          || t == TSTRUCT
          || t == TSYMBOL
          || t == TVALUES
          || t == TVECTOR)
        dest->cdr = d - dist;
      else
        dest->cdr = d;
      if (t == TBYTES)
        {
          if (g_debug > 5)
            {
              eputs ("copying bytes[");
              eputs (ntoab (cell_bytes (src), 16, 0));
              eputs (", ");
              eputs (ntoab (a, 10, 0));
              eputs ("]: ");
              eputs (cell_bytes (src));
              eputs ("\n to [");
              eputs (ntoab (cell_bytes (dest), 16, 0));
            }
          memcpy (cell_bytes (dest), cell_bytes (src), a);
          if (g_debug > 5)
            {
              eputs ("]: ");
              eputs (cell_bytes (dest));
              eputs ("\n");
            }
          int i = bytes_cells (a);
          n = n - i;
          int c = i * M2_CELL_SIZE;
          dest = dest + c;
          src = src + c;
        }
      else
        {
          n = n - 1;
          dest = dest + M2_CELL_SIZE;
          src = src + M2_CELL_SIZE;
        }
    }
}

/* We do not actually flip cells and news, instead we move news back to
   cells. */
void
gc_flip ()
{
  if (g_free - g_news > JAM_SIZE)
    JAM_SIZE = (g_free - g_news) + ((g_free - g_news) / 2);

  cell_arena = g_cells - M2_CELL_SIZE; /* For debugging. */
  gc_cellcpy (g_cells, g_news, (g_free - g_news) / M2_CELL_SIZE);

  long dist = g_news - g_cells;
  g_free = g_free - dist;
  g_symbols = g_symbols - dist;
  g_macros = g_macros - dist;
  g_ports = g_ports - dist;
  M0 = M0 - dist;

  long i;
  for (i = g_stack; i < STACK_SIZE; i = i + 1)
    g_stack_array[i] = g_stack_array[i] - dist;

  if (g_debug > 2)
    gc_stats_ (";;; => jam");
}

SCM
gc_copy (SCM old)               /*:((internal)) */
{
  if (TYPE (old) == TBROKEN_HEART)
    return CAR (old);
  SCM new = g_free;
  g_free = g_free + M2_CELL_SIZE;
  copy_news (new, old);
  if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR)
    {
      NVECTOR (new) = g_free;
      long i;
      for (i = 0; i < LENGTH (old); i = i + 1)
        {
          copy_news (g_free, cell_ref (VECTOR (old), i));
          g_free = g_free + M2_CELL_SIZE;
        }
    }
  else if (NTYPE (new) == TBYTES)
    {
      char const *src = cell_bytes (old);
      char *dest = news_bytes (new);
      size_t length = NLENGTH (new);
      memcpy (dest, src, length);
      g_free = g_free + ((bytes_cells (length) - 1) * M2_CELL_SIZE);

      if (g_debug > 4)
        {
          eputs ("gc copy bytes: ");
          eputs (src);
          eputs ("\n");
          eputs ("    length: ");
          eputs (ltoa (LENGTH (old)));
          eputs ("\n");
          eputs ("    nlength: ");
          eputs (ltoa (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)) */
{
  NCAR (new) = car;
  return cell_unspecified;
}

SCM
gc_relocate_cdr (SCM new, SCM cdr)      /*:((internal)) */
{
  NCDR (new) = cdr;
  return cell_unspecified;
}

void
gc_loop (SCM scan)
{
  SCM car;
  SCM cdr;
  while (scan < g_free)
    {
      long t = NTYPE (scan);
      if (t == TBROKEN_HEART)
        assert_msg (0, "gc_loop: broken heart");
      /* *INDENT-OFF* */
      if (t == TMACRO
          || t == TPAIR
          || t == TREF
          || t == TVARIABLE)
        /* *INDENT-ON* */
        {
          car = gc_copy (NCAR (scan));
          gc_relocate_car (scan, car);
        }
      /* *INDENT-OFF* */
      if (t == TCLOSURE
          || t == TCONTINUATION
          || t == TKEYWORD
          || t == TMACRO
          || t == TPAIR
          || t == TPORT
          || t == TSPECIAL
          || t == TSTRING
          /*|| t == TSTRUCT handled by gc_copy */
          || t == TSYMBOL
          || t == TVALUES
          /*|| t == TVECTOR handled by gc_copy */
          )
        /* *INDENT-ON* */
        {
          cdr = gc_copy (NCDR (scan));
          gc_relocate_cdr (scan, cdr);
        }
      if (t == TBYTES)
        scan = scan + (bytes_cells (NLENGTH (scan)) * M2_CELL_SIZE);
      else
        scan = scan + M2_CELL_SIZE;
    }
  gc_flip ();
}

SCM
gc_check ()
{
  long used = ((g_free - g_cells) / M2_CELL_SIZE) + GC_SAFETY;
  if (used >= ARENA_SIZE)
    return gc ();
  return cell_unspecified;
}

void
gc_ ()
{
  gc_init_news ();
  if (g_debug == 2)
    eputs (".");
  if (g_debug > 2)
    {
      gc_stats_ (";;; gc");
      eputs (";;; free: [");
      eputs (ltoa (ARENA_SIZE - gc_free ()));
      eputs ("]...");
    }
  g_free = g_news + M2_CELL_SIZE;

  if (ARENA_SIZE < MAX_ARENA_SIZE && g_cells == g_arena + M2_CELL_SIZE)
    {
      if (g_debug == 2)
        eputs ("+");
      if (g_debug > 2)
        {
          eputs (" up[");
          eputs (ltoa (g_cells));
          eputs (",");
          eputs (ltoa (g_news));
          eputs (":");
          eputs (ltoa (ARENA_SIZE));
          eputs (",");
          eputs (ltoa (MAX_ARENA_SIZE));
          eputs ("]...");
        }
      gc_up_arena ();
    }

  SCM new_cell_nil = g_free;
  SCM s;
  for (s = cell_nil; s < g_symbol_max; s = s + M2_CELL_SIZE)
    gc_copy (s);

  g_symbols = gc_copy (g_symbols);
  g_macros = gc_copy (g_macros);
  g_ports = gc_copy (g_ports);
  M0 = gc_copy (M0);

  long i;
  for (i = g_stack; i < STACK_SIZE; i = i + 1)
    copy_stack (i, gc_copy (g_stack_array[i]));

  gc_loop (new_cell_nil);
}

SCM
gc ()
{
  if (getenv ("MES_DUMP") != 0)
    gc_dump_arena (g_cells, gc_free ());
  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");
    }
  if (getenv ("MES_DUMP") != 0)
    gc_dump_arena (g_cells, gc_free ());
  return cell_unspecified;
}

void
gc_push_frame ()
{
  if (g_stack < FRAME_SIZE)
    assert_msg (0, "STACK FULL");
  g_stack_array[g_stack - 1] = cell_f;
  g_stack_array[g_stack - 2] = R0;
  g_stack_array[g_stack - 3] = R1;
  g_stack_array[g_stack - 4] = R2;
  g_stack_array[g_stack - 5] = R3;
  g_stack = g_stack - FRAME_SIZE;
}

void
gc_peek_frame ()
{
  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];
  g_stack_array[g_stack + FRAME_PROCEDURE];
}

void
gc_pop_frame ()
{
  gc_peek_frame ();
  g_stack = g_stack + FRAME_SIZE;
}

void
dumpc (char c)
{
  fdputc (c, g_dump_filedes);
}

void
dumps (char const *s)
{
  fdputs (s, g_dump_filedes);
}

void
gc_dump_register (char const* n, SCM r)
{
  dumps (n); dumps (": ");
  long i = r;
  long a = g_arena;
  i = i - a;
  i = i / M2_CELL_SIZE;
  dumps (ltoa (i));
  dumps ("\n");
}

void
gc_dump_state ()
{
  gc_dump_register ("R0", R0);
  gc_dump_register ("R1", R1);
  gc_dump_register ("R2", R2);
  gc_dump_register ("R3", R3);
  gc_dump_register ("M0", M0);
  gc_dump_register ("g_symbols", g_symbols);
  gc_dump_register ("g_symbol_max", g_symbol_max);
  gc_dump_register ("g_macros", g_macros);
  gc_dump_register ("g_ports", g_ports);
  gc_dump_register ("cell_zero", cell_zero);
  gc_dump_register ("cell_nil", cell_nil);
}

void
gc_dump_stack ()
{
  long i = g_stack;
  while (i < STACK_SIZE)
    {
      gc_dump_register (itoa (i), g_stack_array[i]);
      i = i + 1;
    }
}

void
gc_dump_arena (struct scm *cells, long size)
{
  SCM end = g_cells + (size * M2_CELL_SIZE);
  struct scm *dist = cells;
  if (g_dump_filedes == 0)
    g_dump_filedes = mes_open ("dump.mo", O_CREAT|O_WRONLY, 0644);
  dumps ("stack="); dumps (ltoa (g_stack)); dumpc ('\n');
  dumps ("size="); dumps (ltoa (size)); dumpc ('\n');
  gc_dump_state ();
  gc_dump_stack ();
  while (TYPE (end) == 0 && CAR (end) == 0 && CDR (end) == 0)
    {
      end = end - M2_CELL_SIZE;
      size = size - 1;
    }
  while (size > 0)
    {
      int i;
      for (i=0; i < 16; i = i + 1)
        {
          long t = cells->type;
          long a = cells->car;
          long d = cells->cdr;
          if (size == 0)
            dumps ("0 0 0");
          else
            {
              dumps (ltoa (t));
              dumpc (' ');
              if (t == TMACRO
                  || t == TPAIR
                  || t == TREF
                  || t == TVARIABLE)
                {
                  dumps (ltoa ((cells->car - dist) / M2_CELL_SIZE));
                  /* dumps ("["); dumps (ltoa (a)); dumps ("]"); */
                }
              else
                dumps (ltoa (a));
              dumpc (' ');
              if (t != TBYTES)
                {
                  if (t == TCLOSURE
                      || t == TCONTINUATION
                      || t == TKEYWORD
                      || t == TMACRO
                      || t == TPAIR
                      || t == TPORT
                      || t == TSPECIAL
                      || t == TSTRING
                      || t == TSTRUCT
                      || t == TSYMBOL
                      || t == TVALUES
                      || t == TVECTOR)
                    {
                      dumps (ltoa ((cells->cdr - dist) / M2_CELL_SIZE));
                      /* dumps ("["); dumps (ltoa (d)); dumps ("]"); */
                    }
                  else if (t == TNUMBER && d > 1000)
                    dumps (ltoa (1001));
                  else
                    dumps (ltoa (d));
                }
              if (t == TBYTES)
                {
                  int c = bytes_cells (a);
                  char *p = cell_bytes (cells);
                  size = size - c;
                  dumpc ('"');
                  while (a > 0)
                    {
                      if (p[0] != 0)
                        dumpc (p[0]);
                      p = p + 1;
                      a = a - 1;
                    }
                  dumpc ('"');
                  cells = cells + c * M2_CELL_SIZE;
                  size = size - c;
                }
              else
                {
                  cells = cells + M2_CELL_SIZE;
                  size = size - 1;
                }
            }
          if (i != 15)
            dumps ("  ");
          else
            dumpc ('\n');
        }
      dumpc ('\n');
    }
}