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

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

lisp: miscellaneous work on type safety.

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