source: abuse/tags/pd/macabuse/src/lisp_gc.c @ 49

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