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

Last change on this file since 129 was 129, checked in by Sam Hocevar, 14 years ago
  • Get rid of jmalloc and replace it with standard malloc. Modern operating systems certainly perform a lot better than this custom implementation, and we have superior tools (eg. valgrind) to debug and profile memory usage without interfering with the code itself.
File size: 6.8 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.hpp"
16#ifdef NO_LIBS
17#include "fakelib.hpp"
18#else
19#include "macs.hpp"
20#endif
21
22#include "stack.hpp"
23
24/*  Lisp garbage collections :  uses copy/free algorithm
25    Places to check :
26      symbol
27        values
28    functions
29    names
30      stack
31*/
32
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);
37
38int reg_ptr_total = 0;
39int reg_ptr_list_size = 0;
40void ***reg_ptr_list = NULL;
41
42void register_pointer(void **addr)
43{
44  if (reg_ptr_total>=reg_ptr_list_size)
45  {
46    reg_ptr_list_size+=0x100;
47    reg_ptr_list=(void ***)realloc(reg_ptr_list,sizeof(void **)*reg_ptr_list_size);
48  }
49  reg_ptr_list[reg_ptr_total++]=addr;
50}
51
52
53void unregister_pointer(void **addr)
54{
55  int i;
56  void ***reg_on=reg_ptr_list;
57  for (i=0;i<reg_ptr_total;i++,reg_on++)
58  {
59    if (*reg_on==addr)
60    {
61      int j;
62      reg_ptr_total--;
63      for (j=i;j<reg_ptr_total;j++,reg_on++)
64        reg_on[0]=reg_on[1];
65      return ;
66    }
67  }
68  fprintf(stderr,"Unable to locate ptr to unregister");
69}
70
71static void *collect_object(void *x);
72static void *collect_array(void *x)
73{
74  long s=((lisp_1d_array *)x)->size;
75  lisp_1d_array *a=new_lisp_1d_array(s,NULL);
76  void **src,**dst;
77  src=(void **)(((lisp_1d_array *)x)+1);
78  dst=(void **)(a+1);
79  for (int i=0;i<s;i++)
80    dst[i]=collect_object(src[i]);
81
82  return a;
83}
84
85static uint8_t *cstart,*cend,*collected_start,*collected_end;
86
87inline void *collect_cons_cell(void *x)
88{
89  cons_cell *last=NULL,*first=NULL;
90  if (!x) return x;
91  for (;x && item_type(x)==L_CONS_CELL;)
92  {
93    cons_cell *p=new_cons_cell();
94    void *old_car=((cons_cell *)x)->car;
95    void *old_cdr=((cons_cell *)x)->cdr;
96    void *old_x=x;
97    x=CDR(x);
98    ((lisp_collected_object *)old_x)->type=L_COLLECTED_OBJECT;
99    ((lisp_collected_object *)old_x)->new_reference=p;
100
101    p->car=collect_object(old_car);
102    p->cdr=collect_object(old_cdr);
103   
104    if (last) last->cdr=p;
105    else first=p;
106    last=p;
107  }
108  if (x)
109    last->cdr=collect_object(x);
110  return first;                    // we already set the collection pointers
111}
112
113static void *collect_object(void *x)
114{
115  void *ret=x;
116
117  if (((uint8_t *)x)>=cstart && ((uint8_t *)x)<cend)
118  {
119    switch (item_type(x))
120    {
121      case L_BAD_CELL :
122      { lbreak("error : GC corrupted cell\n"); } break;
123
124      case L_NUMBER :
125      { ret=new_lisp_number(((lisp_number *)x)->num); } break;
126
127
128      case L_SYS_FUNCTION :
129      { ret=new_lisp_sys_function( ((lisp_sys_function *)x)->min_args,
130                      ((lisp_sys_function *)x)->max_args,
131                      ((lisp_sys_function *)x)->fun_number);
132      } break;
133      case L_USER_FUNCTION :
134      {
135#ifndef NO_LIBS
136    ret=new_lisp_user_function( ((lisp_user_function *)x)->alist,
137                       ((lisp_user_function *)x)->blist);
138
139#else
140    void *arg=collect_object(((lisp_user_function *)x)->arg_list);
141    void *block=collect_object(((lisp_user_function *)x)->block_list);
142    ret=new_lisp_user_function(arg,block);
143#endif
144      } break;
145      case L_STRING :
146      { ret=new_lisp_string(lstring_value(x)); } break;
147
148      case L_CHARACTER :
149      { ret=new_lisp_character(lcharacter_value(x)); } break;
150
151      case L_C_FUNCTION :
152      {
153    ret=new_lisp_c_function( ((lisp_sys_function *)x)->min_args,
154                      ((lisp_sys_function *)x)->max_args,
155                      ((lisp_sys_function *)x)->fun_number);
156      } break;
157
158      case L_C_BOOL :
159      {
160    ret=new_lisp_c_bool( ((lisp_sys_function *)x)->min_args,
161                      ((lisp_sys_function *)x)->max_args,
162                      ((lisp_sys_function *)x)->fun_number);
163      } break;
164      case L_L_FUNCTION :
165      {
166    ret=new_user_lisp_function( ((lisp_sys_function *)x)->min_args,
167                      ((lisp_sys_function *)x)->max_args,
168                      ((lisp_sys_function *)x)->fun_number);
169      } break;
170
171      case L_POINTER :
172      { ret=new_lisp_pointer(lpointer_value(x)); } break;
173
174
175      case L_1D_ARRAY :
176      { ret=collect_array(x); } break;
177
178      case L_FIXED_POINT :
179      { ret=new_lisp_fixed_point(lfixed_point_value(x)); } break;
180
181      case L_CONS_CELL :
182      { ret=collect_cons_cell((cons_cell *)x); } break;
183
184      case L_OBJECT_VAR :
185      {
186    ret=new_lisp_object_var( ((lisp_object_var *)x)->number);
187      } break;
188      case L_COLLECTED_OBJECT :
189      {
190    ret=((lisp_collected_object *)x)->new_reference;
191      } break;
192
193      default :
194      { lbreak("shouldn't happen. collecting bad object\n"); } break;
195    }
196    ((lisp_collected_object *)x)->type=L_COLLECTED_OBJECT;
197    ((lisp_collected_object *)x)->new_reference=ret;
198  } else if ((uint8_t *)x<collected_start || (uint8_t *)x>=collected_end)
199  {
200    if (item_type(x)==L_CONS_CELL) // still need to remap cons_cells outside of space
201    {
202      for (;x && item_type(x)==L_CONS_CELL;x=CDR(x))
203        ((cons_cell *)x)->car=collect_object(((cons_cell *)x)->car);
204      if (x)
205        ((cons_cell *)x)->cdr=collect_object(((cons_cell *)x)->cdr);
206    }
207  }
208
209  return ret;
210}
211
212static void collect_symbols(lisp_symbol *root)
213{
214  if (root)
215  {
216    root->value=collect_object(root->value);
217    root->function=collect_object(root->function);
218    root->name=collect_object(root->name);
219    collect_symbols(root->left);
220    collect_symbols(root->right);
221  }
222}
223
224static void collect_stacks()
225{
226  long t=l_user_stack.son;
227  void **d=l_user_stack.sdata;
228  int i=0;
229  for (;i<t;i++,d++)
230    *d=collect_object(*d);
231
232  t=l_ptr_stack.son;
233  void ***d2=l_ptr_stack.sdata;
234  for (i=0;i<t;i++,d2++)
235  {
236    void **ptr=*d2;
237    *ptr=collect_object(*ptr);
238  }
239
240  d2=reg_ptr_list;
241  for (t=0;t<reg_ptr_total;t++,d2++)
242  {
243    void **ptr=*d2;
244    *ptr=collect_object(*ptr);
245  }
246
247}
248
249void collect_space(int which_space) // should be tmp or permenant
250{
251  return; /* XXX */
252
253  int old_space=current_space;
254  cstart=(uint8_t *)space[which_space];
255  cend=(uint8_t *)free_space[which_space];
256
257  space_size[GC_SPACE]=space_size[which_space];
258  void *new_space=malloc(space_size[GC_SPACE]);
259  current_space=GC_SPACE;
260  free_space[GC_SPACE]=space[GC_SPACE]=(char *)new_space;
261
262  collected_start=(uint8_t *)new_space;
263  collected_end=(((uint8_t *)new_space)+space_size[GC_SPACE]);
264
265  collect_symbols(lsym_root);
266  collect_stacks();
267
268  memset(space[which_space],0,space_size[which_space]);  // for debuging clear it out
269  free(space[which_space]);
270
271  space[which_space]=(char *)new_space;
272  free_space[which_space]=((char *)new_space)+
273         (((uint8_t *)free_space[GC_SPACE])-((uint8_t *)space[GC_SPACE]));
274  current_space=old_space;
275}
276
Note: See TracBrowser for help on using the repository browser.