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