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

Last change on this file since 490 was 490, checked in by Sam Hocevar, 11 years ago

lisp: implement LispList::GetLength?.

File size: 7.7 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{
[483]88    long s = ((LispArray *)x)->size;
89    LispArray *a = LispArray::Create(s, NULL);
90    LispObject **src = ((LispArray *)x)->GetData();
91    LispObject **dst = a->GetData();
92    for (int i = 0; i < s; i++)
93        dst[i] = (LispObject *)collect_object(src[i]);
[2]94
[483]95    return a;
[2]96}
97
98inline void *collect_cons_cell(void *x)
99{
[482]100  LispList *last = NULL, *first = NULL;
[2]101  if (!x) return x;
[480]102  for (; x && item_type(x) == L_CONS_CELL; )
[2]103  {
[482]104    LispList *p = new_cons_cell();
105    void *old_car = ((LispList *)x)->car;
106    void *old_cdr = ((LispList *)x)->cdr;
[480]107    void *old_x = x;
108    x = CDR(x);
[482]109    ((LispRedirect *)old_x)->type = L_COLLECTED_OBJECT;
110    ((LispRedirect *)old_x)->new_reference = p;
[2]111
[490]112    p->car = (LispObject *)collect_object(old_car);
113    p->cdr = (LispObject *)collect_object(old_cdr);
114
[480]115    if (last) last->cdr = p;
116    else first = p;
117    last = p;
[2]118  }
119  if (x)
[490]120    last->cdr = (LispObject *)collect_object(x);
[2]121  return first;                    // we already set the collection pointers
122}
123
124static void *collect_object(void *x)
125{
[480]126  void *ret = x;
[2]127
[480]128  if (((uint8_t *)x) >= cstart && ((uint8_t *)x) < cend)
[2]129  {
[480]130    //dump_memory(x, 32, 48);
[2]131    switch (item_type(x))
132    {
[480]133      case L_BAD_CELL:
134        lbreak("error: GC corrupted cell\n");
135        break;
136      case L_NUMBER:
[486]137        ret = LispNumber::Create(((LispNumber *)x)->num);
[480]138        break;
139      case L_SYS_FUNCTION:
[482]140        ret = new_lisp_sys_function(((LispSysFunction *)x)->min_args,
141                                    ((LispSysFunction *)x)->max_args,
142                                    ((LispSysFunction *)x)->fun_number);
[480]143        break;
144      case L_USER_FUNCTION:
[2]145#ifndef NO_LIBS
[482]146        ret = new_lisp_user_function(((LispUserFunction *)x)->alist,
147                                     ((LispUserFunction *)x)->blist);
[2]148
149#else
[480]150        {
[482]151          void *arg = collect_object(((LispUserFunction *)x)->arg_list);
152          void *block = collect_object(((LispUserFunction *)x)->block_list);
[480]153          ret = new_lisp_user_function(arg, block);
154        }
[2]155#endif
[480]156        break;
157      case L_STRING:
[488]158        ret = LispString::Create(lstring_value(x));
[480]159        break;
160      case L_CHARACTER:
161        ret = new_lisp_character(lcharacter_value(x));
162        break;
163      case L_C_FUNCTION:
[482]164        ret = new_lisp_c_function(((LispSysFunction *)x)->min_args,
165                                  ((LispSysFunction *)x)->max_args,
166                                  ((LispSysFunction *)x)->fun_number);
[480]167        break;
168      case L_C_BOOL:
[482]169        ret = new_lisp_c_bool(((LispSysFunction *)x)->min_args,
170                              ((LispSysFunction *)x)->max_args,
171                              ((LispSysFunction *)x)->fun_number);
[480]172        break;
173      case L_L_FUNCTION:
[482]174        ret = new_user_lisp_function(((LispSysFunction *)x)->min_args,
175                                     ((LispSysFunction *)x)->max_args,
176                                     ((LispSysFunction *)x)->fun_number);
[480]177        break;
178      case L_POINTER:
179        ret = new_lisp_pointer(lpointer_value(x));
180        break;
181      case L_1D_ARRAY:
182        ret = collect_array(x);
183        break;
184      case L_FIXED_POINT:
185        ret = new_lisp_fixed_point(lfixed_point_value(x));
186        break;
187      case L_CONS_CELL:
[482]188        ret = collect_cons_cell((LispList *)x);
[480]189        break;
190      case L_OBJECT_VAR:
[482]191        ret = new_lisp_object_var(((LispObjectVar *)x)->number);
[480]192        break;
193      case L_COLLECTED_OBJECT:
[482]194        ret = ((LispRedirect *)x)->new_reference;
[480]195        break;
196      default:
197        dump_memory(x, 8, 196);
198        //*(char *)NULL = 0;
199        lbreak("shouldn't happen. collecting bad object 0x%x\n",
200               item_type(x));
201        break;
[2]202    }
[482]203    ((LispRedirect *)x)->type = L_COLLECTED_OBJECT;
204    ((LispRedirect *)x)->new_reference = ret;
[480]205  }
206  else if ((uint8_t *)x < collected_start || (uint8_t *)x >= collected_end)
[2]207  {
[480]208    if (item_type(x) == L_CONS_CELL) // still need to remap cons_cells outside of space
[2]209    {
[480]210      for (; x && item_type(x) == L_CONS_CELL; x = CDR(x))
[490]211        ((LispList *)x)->car = (LispObject *)collect_object(((LispList *)x)->car);
[2]212      if (x)
[490]213        ((LispList *)x)->cdr = (LispObject *)collect_object(((LispList *)x)->cdr);
[2]214    }
215  }
216
217  return ret;
218}
219
[482]220static void collect_symbols(LispSymbol *root)
[2]221{
222  if (root)
223  {
[489]224    root->value = (LispObject *)collect_object(root->value);
225    root->function = (LispObject *)collect_object(root->function);
[484]226    root->name = (LispString *)collect_object(root->name);
[2]227    collect_symbols(root->left);
228    collect_symbols(root->right);
229  }
230}
231
232static void collect_stacks()
233{
[480]234  long t = l_user_stack.son;
[2]235
[480]236  void **d = l_user_stack.sdata;
237  for (int i = 0; i < t; i++, d++)
238    *d = collect_object(*d);
239
240  t = l_ptr_stack.son;
241  void ***d2 = l_ptr_stack.sdata;
242  for (int i = 0; i < t; i++, d2++)
[2]243  {
[480]244    void **ptr = *d2;
245    *ptr = collect_object(*ptr);
[2]246  }
247
[480]248  d2 = reg_ptr_list;
249  for (size_t i = 0; i < reg_ptr_total; i++, d2++)
[2]250  {
[480]251    void **ptr = *d2;
252    *ptr = collect_object(*ptr);
[124]253  }
[2]254}
255
[480]256void collect_space(int which_space) // should be tmp or permanent
[2]257{
[20]258  return; /* XXX */
259
[480]260  int old_space = current_space;
261  cstart = space[which_space];
262  cend = free_space[which_space];
[2]263
[480]264  space_size[GC_SPACE] = space_size[which_space];
265  uint8_t *new_space = (uint8_t *)malloc(space_size[GC_SPACE]);
266  current_space = GC_SPACE;
267  free_space[GC_SPACE] = space[GC_SPACE] = new_space;
[2]268
[480]269  collected_start = new_space;
270  collected_end = new_space + space_size[GC_SPACE];
[2]271
[480]272//dump_memory((char *)lsym_root->name, 128, 196);
273//dump_memory((char *)0xb6782025, 32, 48);
[2]274  collect_symbols(lsym_root);
275  collect_stacks();
276
[480]277  // for debuging clear it out
278  memset(space[which_space], 0, space_size[which_space]);
[129]279  free(space[which_space]);
[2]280
[480]281  space[which_space] = new_space;
282  free_space[which_space] = new_space
283                          + (free_space[GC_SPACE] - space[GC_SPACE]);
284  current_space = old_space;
[2]285}
286
Note: See TracBrowser for help on using the repository browser.