source: abuse/trunk/src/lisp_gc.cpp @ 2

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