source: abuse/trunk/src/lisp/lisp_gc.cpp @ 482

Last change on this file since 482 was 482, checked in by Sam Hocevar, 12 years ago

lisp: make all lisp object inherit a common type.

File size: 7.5 KB
RevLine 
[56]1/*
2 *  Abuse - dark 2D side-scrolling platform game
3 *  Copyright (c) 1995 Crack dot Com
4 *
5 *  This software was released into the Public Domain. As with most public
6 *  domain software, no warranty is made or implied by Crack dot Com or
7 *  Jonathan Clark.
8 */
[2]9
[56]10#include "config.h"
[2]11
[56]12#include <stdlib.h>
13#include <string.h>
[2]14
[481]15#include "lisp.h"
[2]16#ifdef NO_LIBS
[481]17#include "fakelib.h"
[2]18#else
[481]19#include "macs.h"
[2]20#endif
21
[481]22#include "stack.h"
[2]23
[480]24/*  Lisp garbage collection: uses copy/free algorithm
25    Places to check:
[124]26      symbol
[56]27        values
[124]28    functions
29    names
[56]30      stack
31*/
[2]32
[75]33// Stack where user programs can push data and have it GCed
34grow_stack<void> l_user_stack(150);
35// Stack of user pointers
36grow_stack<void *> l_ptr_stack(1500);
[2]37
[480]38size_t reg_ptr_total = 0;
39size_t reg_ptr_list_size = 0;
[75]40void ***reg_ptr_list = NULL;
[2]41
[480]42static uint8_t *cstart, *cend, *collected_start, *collected_end;
43
44static void dump_memory(void *mem, int before, int after)
45{
46  uint8_t *p = (uint8_t *)mem;
47
48  fprintf(stderr, "dumping memory around %p:\n", p);
49  for (int i = -before; i < after; i++)
50  {
51    if (!(i & 15))
52      fprintf(stderr, "%p: ", p + i);
53    fprintf(stderr, "%c%02x%c", i ? ' ' : '[', p[i], i ? ' ' : ']');
54    if (!((i + 1) & 15))
55      fprintf(stderr, "\n");
56  }
57}
58
[2]59void register_pointer(void **addr)
60{
[480]61  if (reg_ptr_total >= reg_ptr_list_size)
[2]62  {
[480]63    reg_ptr_list_size += 0x100;
64    reg_ptr_list = (void ***)realloc(reg_ptr_list, sizeof(void **) * reg_ptr_list_size);
[2]65  }
[480]66  reg_ptr_list[reg_ptr_total++] = addr;
[2]67}
68
69void unregister_pointer(void **addr)
70{
[480]71  void ***reg_on = reg_ptr_list;
72  for (size_t i = 0; i < reg_ptr_total; i++, reg_on++)
[2]73  {
[480]74    if (*reg_on == addr)
[2]75    {
76      reg_ptr_total--;
[480]77      for (size_t j = i; j < reg_ptr_total; j++, reg_on++)
78        reg_on[0] = reg_on[1];
[2]79      return ;
80    }
81  }
[480]82  fprintf(stderr, "Unable to locate ptr to unregister");
[2]83}
84
85static void *collect_object(void *x);
86static void *collect_array(void *x)
87{
[482]88  long s = ((LispArray *)x)->size;
89  LispArray *a = new_lisp_1d_array(s, NULL);
[480]90  void **src, **dst;
[482]91  src = (void **)(((LispArray *)x)+1);
[480]92  dst = (void **)(a+1);
93  for (int i = 0; i<s; i++)
94    dst[i] = collect_object(src[i]);
[2]95
96  return a;
97}
98
99inline void *collect_cons_cell(void *x)
100{
[482]101  LispList *last = NULL, *first = NULL;
[2]102  if (!x) return x;
[480]103  for (; x && item_type(x) == L_CONS_CELL; )
[2]104  {
[482]105    LispList *p = new_cons_cell();
106    void *old_car = ((LispList *)x)->car;
107    void *old_cdr = ((LispList *)x)->cdr;
[480]108    void *old_x = x;
109    x = CDR(x);
[482]110    ((LispRedirect *)old_x)->type = L_COLLECTED_OBJECT;
111    ((LispRedirect *)old_x)->new_reference = p;
[2]112
[480]113    p->car = collect_object(old_car);
114    p->cdr = collect_object(old_cdr);
[124]115   
[480]116    if (last) last->cdr = p;
117    else first = p;
118    last = p;
[2]119  }
120  if (x)
[480]121    last->cdr = collect_object(x);
[2]122  return first;                    // we already set the collection pointers
123}
124
125static void *collect_object(void *x)
126{
[480]127  void *ret = x;
[2]128
[480]129  if (((uint8_t *)x) >= cstart && ((uint8_t *)x) < cend)
[2]130  {
[480]131    //dump_memory(x, 32, 48);
[2]132    switch (item_type(x))
133    {
[480]134      case L_BAD_CELL:
135        lbreak("error: GC corrupted cell\n");
136        break;
137      case L_NUMBER:
[482]138        ret = new_lisp_number(((LispNumber *)x)->num);
[480]139        break;
140      case L_SYS_FUNCTION:
[482]141        ret = new_lisp_sys_function(((LispSysFunction *)x)->min_args,
142                                    ((LispSysFunction *)x)->max_args,
143                                    ((LispSysFunction *)x)->fun_number);
[480]144        break;
145      case L_USER_FUNCTION:
[2]146#ifndef NO_LIBS
[482]147        ret = new_lisp_user_function(((LispUserFunction *)x)->alist,
148                                     ((LispUserFunction *)x)->blist);
[2]149
150#else
[480]151        {
[482]152          void *arg = collect_object(((LispUserFunction *)x)->arg_list);
153          void *block = collect_object(((LispUserFunction *)x)->block_list);
[480]154          ret = new_lisp_user_function(arg, block);
155        }
[2]156#endif
[480]157        break;
158      case L_STRING:
159        ret = new_lisp_string(lstring_value(x));
160        break;
161      case L_CHARACTER:
162        ret = new_lisp_character(lcharacter_value(x));
163        break;
164      case L_C_FUNCTION:
[482]165        ret = new_lisp_c_function(((LispSysFunction *)x)->min_args,
166                                  ((LispSysFunction *)x)->max_args,
167                                  ((LispSysFunction *)x)->fun_number);
[480]168        break;
169      case L_C_BOOL:
[482]170        ret = new_lisp_c_bool(((LispSysFunction *)x)->min_args,
171                              ((LispSysFunction *)x)->max_args,
172                              ((LispSysFunction *)x)->fun_number);
[480]173        break;
174      case L_L_FUNCTION:
[482]175        ret = new_user_lisp_function(((LispSysFunction *)x)->min_args,
176                                     ((LispSysFunction *)x)->max_args,
177                                     ((LispSysFunction *)x)->fun_number);
[480]178        break;
179      case L_POINTER:
180        ret = new_lisp_pointer(lpointer_value(x));
181        break;
182      case L_1D_ARRAY:
183        ret = collect_array(x);
184        break;
185      case L_FIXED_POINT:
186        ret = new_lisp_fixed_point(lfixed_point_value(x));
187        break;
188      case L_CONS_CELL:
[482]189        ret = collect_cons_cell((LispList *)x);
[480]190        break;
191      case L_OBJECT_VAR:
[482]192        ret = new_lisp_object_var(((LispObjectVar *)x)->number);
[480]193        break;
194      case L_COLLECTED_OBJECT:
[482]195        ret = ((LispRedirect *)x)->new_reference;
[480]196        break;
197      default:
198        dump_memory(x, 8, 196);
199        //*(char *)NULL = 0;
200        lbreak("shouldn't happen. collecting bad object 0x%x\n",
201               item_type(x));
202        break;
[2]203    }
[482]204    ((LispRedirect *)x)->type = L_COLLECTED_OBJECT;
205    ((LispRedirect *)x)->new_reference = ret;
[480]206  }
207  else if ((uint8_t *)x < collected_start || (uint8_t *)x >= collected_end)
[2]208  {
[480]209    if (item_type(x) == L_CONS_CELL) // still need to remap cons_cells outside of space
[2]210    {
[480]211      for (; x && item_type(x) == L_CONS_CELL; x = CDR(x))
[482]212        ((LispList *)x)->car = collect_object(((LispList *)x)->car);
[2]213      if (x)
[482]214        ((LispList *)x)->cdr = collect_object(((LispList *)x)->cdr);
[2]215    }
216  }
217
218  return ret;
219}
220
[482]221static void collect_symbols(LispSymbol *root)
[2]222{
223  if (root)
224  {
[480]225    root->value = collect_object(root->value);
226    root->function = collect_object(root->function);
227    root->name = collect_object(root->name);
[2]228    collect_symbols(root->left);
229    collect_symbols(root->right);
230  }
231}
232
233static void collect_stacks()
234{
[480]235  long t = l_user_stack.son;
[2]236
[480]237  void **d = l_user_stack.sdata;
238  for (int i = 0; i < t; i++, d++)
239    *d = collect_object(*d);
240
241  t = l_ptr_stack.son;
242  void ***d2 = l_ptr_stack.sdata;
243  for (int i = 0; i < t; i++, d2++)
[2]244  {
[480]245    void **ptr = *d2;
246    *ptr = collect_object(*ptr);
[2]247  }
248
[480]249  d2 = reg_ptr_list;
250  for (size_t i = 0; i < reg_ptr_total; i++, d2++)
[2]251  {
[480]252    void **ptr = *d2;
253    *ptr = collect_object(*ptr);
[124]254  }
[2]255}
256
[480]257void collect_space(int which_space) // should be tmp or permanent
[2]258{
[20]259  return; /* XXX */
260
[480]261  int old_space = current_space;
262  cstart = space[which_space];
263  cend = free_space[which_space];
[2]264
[480]265  space_size[GC_SPACE] = space_size[which_space];
266  uint8_t *new_space = (uint8_t *)malloc(space_size[GC_SPACE]);
267  current_space = GC_SPACE;
268  free_space[GC_SPACE] = space[GC_SPACE] = new_space;
[2]269
[480]270  collected_start = new_space;
271  collected_end = new_space + space_size[GC_SPACE];
[2]272
[480]273//dump_memory((char *)lsym_root->name, 128, 196);
274//dump_memory((char *)0xb6782025, 32, 48);
[2]275  collect_symbols(lsym_root);
276  collect_stacks();
277
[480]278  // for debuging clear it out
279  memset(space[which_space], 0, space_size[which_space]);
[129]280  free(space[which_space]);
[2]281
[480]282  space[which_space] = new_space;
283  free_space[which_space] = new_space
284                          + (free_space[GC_SPACE] - space[GC_SPACE]);
285  current_space = old_space;
[2]286}
287
Note: See TracBrowser for help on using the repository browser.