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

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