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   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
  26   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
  27   g_cells = (struct scm*)p;
  28   g_cells++;
  29   gc_init_news ();
  30 }
  31
  32 SCM
  33 gc_flip () ///((internal))
  34 {
  35   struct scm *cells = g_cells;
  36   g_cells = g_news;
  37   g_news = cells;
  38   if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
  39   return g_stack;
  40 }
  41
  42 SCM
  43 gc_copy (SCM old) ///((internal))
  44 {
  45   if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
  46   SCM new = g_free++;
  47   g_news[new] = g_cells[old];
  48   if (NTYPE (new) == TVECTOR)
  49     {
  50       g_news[new].vector = g_free;
  51       for (int i=0; i<LENGTH (old); i++)
  52         g_news[g_free++] = g_cells[VECTOR (old)+i];
  53     }
  54   g_cells[old].type = TBROKEN_HEART;
  55   g_cells[old].car = new;
  56   return new;
  57 }
  58
  59 SCM
  60 gc_relocate_car (SCM new, SCM car) ///((internal))
  61 {
  62   g_news[new].car = car;
  63   return cell_unspecified;
  64 }
  65
  66 SCM
  67 gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
  68 {
  69   g_news[new].cdr = cdr;
  70   return cell_unspecified;
  71 }
  72
  73 SCM
  74 gc_loop (SCM scan) ///((internal))
  75 {
  76   while (scan < g_free)
  77     {
  78       if (NTYPE (scan) == TCLOSURE
  79           || NTYPE (scan) == TCONTINUATION
  80           || NTYPE (scan) == TFUNCTION
  81           || NTYPE (scan) == TKEYWORD
  82           || NTYPE (scan) == TMACRO
  83           || NTYPE (scan) == TPAIR
  84           || NTYPE (scan) == TREF
  85           || scan == 1 // null
  86           || NTYPE (scan) == TSPECIAL
  87           || NTYPE (scan) == TSTRING
  88           || NTYPE (scan) == TSYMBOL)
  89         {
  90           SCM car = gc_copy (g_news[scan].car);
  91           gc_relocate_car (scan, car);
  92         }
  93       if ((NTYPE (scan) == TCLOSURE
  94            || NTYPE (scan) == TCONTINUATION
  95            || NTYPE (scan) == TMACRO
  96            || NTYPE (scan) == TPAIR
  97            || NTYPE (scan) == TVALUES)
  98           && g_news[scan].cdr) // allow for 0 terminated list of symbols
  99         {
 100           SCM cdr = gc_copy (g_news[scan].cdr);
 101           gc_relocate_cdr (scan, cdr);
 102         }
 103       scan++;
 104     }
 105   return gc_flip ();
 106 }
 107
 108 SCM
 109 gc ()
 110 {
 111   if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
 112   g_free = 1;
 113   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
 114   for (int i=g_free; i<g_symbol_max; i++)
 115     gc_copy (i);
 116   make_tmps (g_news);
 117   g_symbols = gc_copy (g_symbols);
 118   SCM new = gc_copy (g_stack);
 119   if (g_debug) fprintf (stderr, "new=%d\n", new, g_stack);
 120   g_stack = new;
 121   return gc_loop (1);
 122 }