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 #if _POSIX_SOURCE
  25   ARENA_SIZE *= 2;
  26   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
  27 #else
  28   ARENA_SIZE = ARENA_SIZE * 2;
  29   //p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
  30   int size = ARENA_SIZE * 2;
  31   size = size * 12;
  32   char *p = size;
  33   p = realloc (g_cells-1, size);
  34   g_cells = p;
  35 #endif
  36
  37 #if _POSIX_SOURCE
  38   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
  39   g_cells = (struct scm*)p;
  40   g_cells++;
  41 #else
  42   //assert (p);
  43   //g_cells = (struct scm*)p;
  44 #endif
  45   gc_init_news ();
  46   return 0;
  47 }
  48
  49 SCM
  50 gc_flip () ///((internal))
  51 {
  52   struct scm *cells = g_cells;
  53   g_cells = g_news;
  54   g_news = cells;
  55 #if _POSIX_SOURCE
  56   if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
  57 #else
  58   if (g_debug)
  59     {
  60       eputs (" => jam[");
  61       eputs (itoa (g_free));
  62       eputs ("]\n");
  63     }
  64 #endif
  65   return g_stack;
  66 }
  67
  68 SCM
  69 gc_copy (SCM old) ///((internal))
  70 {
  71   if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
  72   SCM new = g_free++;
  73 #if 0
  74   g_news[new] = g_cells[old];
  75 #else
  76   SCM y = new;
  77   SCM z = old;
  78   SCM zz = TYPE (z);
  79   NTYPE (y) = zz;
  80   zz = CAR (z);
  81   NCAR (y) = zz;
  82   zz = CDR (z);
  83   NCDR (y) = zz;
  84 #endif
  85   if (NTYPE (new) == TVECTOR)
  86     {
  87       NVECTOR (new) = g_free;
  88       for (int i=0; i<LENGTH (old); i++)
  89 #if 0
  90         //__GNUC__
  91         g_news[g_free++] = g_cells[VECTOR (old)+i];
  92 #else
  93       {
  94         //eputs ("gc_copy\n");
  95         y = g_free;
  96         g_free++;
  97         z = VECTOR (old);
  98         z = z + i;
  99         //z = g_cells[z];
 100         zz = TYPE (z);
 101         NTYPE (y) = zz;
 102         zz = CAR (z);
 103         NCAR (y) = zz;
 104         zz = CDR (z);
 105         NCDR (y) = zz;
 106       }
 107 #endif
 108     }
 109   TYPE (old) = TBROKEN_HEART;
 110   CAR (old) = new;
 111   return new;
 112 }
 113
 114 SCM
 115 gc_relocate_car (SCM new, SCM car) ///((internal))
 116 {
 117   g_news[new].car = car;
 118   return cell_unspecified;
 119 }
 120
 121 SCM
 122 gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
 123 {
 124   g_news[new].cdr = cdr;
 125   return cell_unspecified;
 126 }
 127
 128 SCM
 129 gc_loop (SCM scan) ///((internal))
 130 {
 131   while (scan < g_free)
 132     {
 133       if (NTYPE (scan) == TCLOSURE
 134           || NTYPE (scan) == TCONTINUATION
 135           || NTYPE (scan) == TFUNCTION
 136           || NTYPE (scan) == TKEYWORD
 137           || NTYPE (scan) == TMACRO
 138           || NTYPE (scan) == TPAIR
 139           || NTYPE (scan) == TREF
 140           || scan == 1 // null
 141           || NTYPE (scan) == TSPECIAL
 142           || NTYPE (scan) == TSTRING
 143           || NTYPE (scan) == TSYMBOL)
 144         {
 145           SCM car = gc_copy (g_news[scan].car);
 146           gc_relocate_car (scan, car);
 147         }
 148       if ((NTYPE (scan) == TCLOSURE
 149            || NTYPE (scan) == TCONTINUATION
 150            || NTYPE (scan) == TMACRO
 151            || NTYPE (scan) == TPAIR
 152            || NTYPE (scan) == TVALUES)
 153           && g_news[scan].cdr) // allow for 0 terminated list of symbols
 154         {
 155           SCM cdr = gc_copy (g_news[scan].cdr);
 156           gc_relocate_cdr (scan, cdr);
 157         }
 158       scan++;
 159     }
 160   return gc_flip ();
 161 }
 162
 163 SCM
 164 gc ()
 165 {
 166 #if _POSIX_SOURCE
 167   if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
 168 #else
 169   if (g_debug)
 170     {
 171       eputs ("***gc[");
 172       eputs (itoa (g_free));
 173       eputs ("]...");
 174     }
 175 #endif
 176   g_free = 1;
 177   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
 178   for (int i=g_free; i<g_symbol_max; i++)
 179     gc_copy (i);
 180   make_tmps (g_news);
 181   g_symbols = gc_copy (g_symbols);
 182   SCM new = gc_copy (g_stack);
 183 #if _POSIX_SOURCE
 184   if (g_debug) fprintf (stderr, "new=%d\n", new);
 185 #else
 186   if (g_debug)
 187     {
 188       eputs ("new=");
 189       eputs (itoa (new));
 190       eputs ("\n");
 191     }
 192 #endif
 193   g_stack = new;
 194   return gc_loop (1);
 195 }