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

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