1 /*
2 * Abuse - dark 2D side-scrolling platform game
3 * Copyright (c) 1995 Crack dot Com
4 * Copyright (c) 2005-2011 Sam Hocevar <sam@hocevar.net>
5 *
6 * This software was released into the Public Domain. As with most public
7 * domain software, no warranty is made or implied by Crack dot Com, by
8 * Jonathan Clark, or by Sam Hocevar.
9 */
10
11 #if defined HAVE_CONFIG_H
12 # include "config.h"
13 #endif
14
15 #include <stdlib.h>
16 #include <string.h>
17
18 #include "lisp.h"
19 #include "lisp_gc.h"
20
21 #include "stack.h"
22
23 /* Lisp garbage collection: uses copy/free algorithm
24 Places to check:
25 symbol
26 values
27 functions
28 names
29 stack
30 */
31
32 // Stack where user programs can push data and have it GCed
33 GrowStack<void> l_user_stack(150);
34
35 // Stack of user pointers
36 GrowStack<void *> PtrRef::stack(1500);
37
38 static size_t reg_ptr_total = 0;
39 static void ***reg_ptr_list = NULL;
40
41 static uint8_t *cstart, *cend, *collected_start, *collected_end;
42
CollectArray(LArray * x)43 LArray *LispGC::CollectArray(LArray *x)
44 {
45 size_t s = x->len;
46 LArray *a = LArray::Create(s, NULL);
47 LObject **src = x->GetData();
48 LObject **dst = a->GetData();
49 for (size_t i = 0; i < s; i++)
50 dst[i] = CollectObject(src[i]);
51
52 return a;
53 }
54
CollectList(LList * x)55 LList *LispGC::CollectList(LList *x)
56 {
57 LList *last = NULL, *first = NULL;
58
59 for (; x && item_type(x) == L_CONS_CELL; )
60 {
61 LList *p = LList::Create();
62 LObject *old_car = x->car;
63 LObject *old_cdr = x->cdr;
64 LObject *old_x = x;
65 x = (LList *)CDR(x);
66 ((LRedirect *)old_x)->type = L_COLLECTED_OBJECT;
67 ((LRedirect *)old_x)->ref = p;
68
69 p->car = CollectObject(old_car);
70 p->cdr = CollectObject(old_cdr);
71
72 if (last)
73 last->cdr = p;
74 else
75 first = p;
76 last = p;
77 }
78 if (x)
79 last->cdr = CollectObject(x);
80 return first; // we already set the collection pointers
81 }
82
CollectObject(LObject * x)83 LObject *LispGC::CollectObject(LObject *x)
84 {
85 LObject *ret = x;
86
87 if ((uint8_t *)x >= cstart && (uint8_t *)x < cend)
88 {
89 switch (item_type(x))
90 {
91 case L_BAD_CELL:
92 lbreak("error: collecting corrupted cell\n");
93 break;
94 case L_NUMBER:
95 ret = LNumber::Create(((LNumber *)x)->num);
96 break;
97 case L_SYS_FUNCTION:
98 ret = new_lisp_sys_function(((LSysFunction *)x)->min_args,
99 ((LSysFunction *)x)->max_args,
100 ((LSysFunction *)x)->fun_number);
101 break;
102 case L_USER_FUNCTION:
103 {
104 LUserFunction *fun = (LUserFunction *)x;
105 LList *arg = (LList *)CollectObject(fun->arg_list);
106 LList *block = (LList *)CollectObject(fun->block_list);
107 ret = new_lisp_user_function(arg, block);
108 break;
109 }
110 case L_STRING:
111 ret = LString::Create(lstring_value(x));
112 break;
113 case L_CHARACTER:
114 ret = LChar::Create(lcharacter_value(x));
115 break;
116 case L_C_FUNCTION:
117 ret = new_lisp_c_function(((LSysFunction *)x)->min_args,
118 ((LSysFunction *)x)->max_args,
119 ((LSysFunction *)x)->fun_number);
120 break;
121 case L_C_BOOL:
122 ret = new_lisp_c_bool(((LSysFunction *)x)->min_args,
123 ((LSysFunction *)x)->max_args,
124 ((LSysFunction *)x)->fun_number);
125 break;
126 case L_L_FUNCTION:
127 ret = new_user_lisp_function(((LSysFunction *)x)->min_args,
128 ((LSysFunction *)x)->max_args,
129 ((LSysFunction *)x)->fun_number);
130 break;
131 case L_POINTER:
132 ret = LPointer::Create(lpointer_value(x));
133 break;
134 case L_1D_ARRAY:
135 ret = CollectArray((LArray *)x);
136 break;
137 case L_FIXED_POINT:
138 ret = LFixedPoint::Create(lfixed_point_value(x));
139 break;
140 case L_CONS_CELL:
141 ret = CollectList((LList *)x);
142 break;
143 case L_OBJECT_VAR:
144 ret = LObjectVar::Create(((LObjectVar *)x)->index);
145 break;
146 case L_COLLECTED_OBJECT:
147 ret = ((LRedirect *)x)->ref;
148 break;
149 default:
150 lbreak("error: collecting bad object 0x%x\n", item_type(x));
151 break;
152 }
153 ((LRedirect *)x)->type = L_COLLECTED_OBJECT;
154 ((LRedirect *)x)->ref = ret;
155 }
156 else if ((uint8_t *)x < collected_start || (uint8_t *)x >= collected_end)
157 {
158 // Still need to remap cons_cells lying outside of space, for
159 // instance on the stack.
160 for (LObject *cell = NULL; x; cell = x, x = CDR(x))
161 {
162 if (item_type(x) != L_CONS_CELL)
163 {
164 if (cell)
165 CDR(cell) = CollectObject(CDR(cell));
166 break;
167 }
168 CAR(x) = CollectObject(CAR(x));
169 }
170 }
171
172 return ret;
173 }
174
CollectSymbols(LSymbol * root)175 void LispGC::CollectSymbols(LSymbol *root)
176 {
177 if (!root)
178 return;
179
180 root->value = CollectObject(root->value);
181 root->function = CollectObject(root->function);
182 root->name = (LString *)CollectObject(root->name);
183 CollectSymbols(root->left);
184 CollectSymbols(root->right);
185 }
186
CollectStacks()187 void LispGC::CollectStacks()
188 {
189 void **d = l_user_stack.sdata;
190 for (size_t i = 0; i < l_user_stack.m_size; i++, d++)
191 *d = CollectObject((LObject *)*d);
192
193 void ***d2 = PtrRef::stack.sdata;
194 for (size_t i = 0; i < PtrRef::stack.m_size; i++, d2++)
195 {
196 void **ptr = *d2;
197 *ptr = CollectObject((LObject *)*ptr);
198 }
199
200 void ***d3 = reg_ptr_list;
201 for (size_t i = 0; i < reg_ptr_total; i++, d3++)
202 {
203 void **ptr = *d3;
204 *ptr = CollectObject((LObject *)*ptr);
205 }
206 }
207
CollectSpace(int which_space,int grow)208 void LispGC::CollectSpace(int which_space, int grow)
209 {
210 int old_space = current_space;
211 cstart = space[which_space];
212 cend = free_space[which_space];
213
214 space_size[GC_SPACE] = space_size[which_space];
215 if (grow)
216 {
217 space_size[GC_SPACE] += space_size[which_space] >> 1;
218 space_size[GC_SPACE] -= (space_size[GC_SPACE] & 7);
219 }
220 uint8_t *new_space = (uint8_t *)malloc(space_size[GC_SPACE]);
221 current_space = GC_SPACE;
222 free_space[GC_SPACE] = space[GC_SPACE] = new_space;
223
224 collected_start = new_space;
225 collected_end = new_space + space_size[GC_SPACE];
226
227 CollectSymbols(LSymbol::root);
228 CollectStacks();
229
230 // for debuging clear it out
231 memset(space[which_space], 0, space_size[which_space]);
232 free(space[which_space]);
233
234 space[which_space] = new_space;
235 space_size[which_space] = space_size[GC_SPACE];
236 free_space[which_space] = new_space
237 + (free_space[GC_SPACE] - space[GC_SPACE]);
238 current_space = old_space;
239 }
240
241