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

Last change on this file since 636 was 636, checked in by Sam Hocevar, 7 years ago

lisp: merge the Lisp and LispGC classes and improve coding style.

File size: 6.7 KB
Line 
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
33GrowStack<void> l_user_stack(150);
34
35// Stack of user pointers
36GrowStack<void *> PtrRef::stack(1500);
37
38static size_t reg_ptr_total = 0;
39static void ***reg_ptr_list = NULL;
40
41static uint8_t *cstart, *cend, *collected_start, *collected_end;
42
43LArray *Lisp::CollectArray(LArray *x)
44{
45    size_t s = x->m_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
55LList *Lisp::CollectList(LList *x)
56{
57    LList *prev = NULL, *first = NULL;
58
59    for (; x && item_type(x) == L_CONS_CELL; )
60    {
61        LList *p = LList::Create();
62        LObject *old_car = x->m_car;
63        LObject *old_x = x;
64        x = (LList *)CDR(x);
65        ((LRedirect *)old_x)->m_type = L_COLLECTED_OBJECT;
66        ((LRedirect *)old_x)->m_ref = p;
67
68        p->m_car = CollectObject(old_car);
69
70        if (prev)
71            prev->m_cdr = p;
72        else
73            first = p;
74        prev = p;
75    }
76    if (x)
77        prev->m_cdr = CollectObject(x);
78
79    return first; // we already set the collection pointers
80}
81
82LObject *Lisp::CollectObject(LObject *x)
83{
84    LObject *ret = x;
85
86    if ((uint8_t *)x >= cstart && (uint8_t *)x < cend)
87    {
88        switch (item_type(x))
89        {
90        case L_BAD_CELL:
91            lbreak("error: collecting corrupted cell\n");
92            break;
93        case L_NUMBER:
94            ret = LNumber::Create(((LNumber *)x)->m_num);
95            break;
96        case L_SYS_FUNCTION:
97            ret = new_lisp_sys_function(((LSysFunction *)x)->min_args,
98                                        ((LSysFunction *)x)->max_args,
99                                        ((LSysFunction *)x)->fun_number);
100            break;
101        case L_USER_FUNCTION:
102        {
103            LUserFunction *fun = (LUserFunction *)x;
104            LList *arg = (LList *)CollectObject(fun->arg_list);
105            LList *block = (LList *)CollectObject(fun->block_list);
106            ret = new_lisp_user_function(arg, block);
107            break;
108        }
109        case L_STRING:
110            ret = LString::Create(lstring_value(x));
111            break;
112        case L_CHARACTER:
113            ret = LChar::Create(((LChar *)x)->m_ch);
114            break;
115        case L_C_FUNCTION:
116            ret = new_lisp_c_function(((LSysFunction *)x)->min_args,
117                                      ((LSysFunction *)x)->max_args,
118                                      ((LSysFunction *)x)->fun_number);
119            break;
120        case L_C_BOOL:
121            ret = new_lisp_c_bool(((LSysFunction *)x)->min_args,
122                                  ((LSysFunction *)x)->max_args,
123                                  ((LSysFunction *)x)->fun_number);
124            break;
125        case L_L_FUNCTION:
126            ret = new_user_lisp_function(((LSysFunction *)x)->min_args,
127                                         ((LSysFunction *)x)->max_args,
128                                         ((LSysFunction *)x)->fun_number);
129            break;
130        case L_POINTER:
131            ret = LPointer::Create(lpointer_value(x));
132            break;
133        case L_1D_ARRAY:
134            ret = CollectArray((LArray *)x);
135            break;
136        case L_FIXED_POINT:
137            ret = LFixedPoint::Create(lfixed_point_value(x));
138            break;
139        case L_CONS_CELL:
140            ret = CollectList((LList *)x);
141            break;
142        case L_OBJECT_VAR:
143            ret = LObjectVar::Create(((LObjectVar *)x)->m_index);
144            break;
145        case L_COLLECTED_OBJECT:
146            ret = ((LRedirect *)x)->m_ref;
147            break;
148        default:
149            lbreak("error: collecting bad object 0x%x\n", item_type(x));
150            break;
151        }
152        ((LRedirect *)x)->m_type = L_COLLECTED_OBJECT;
153        ((LRedirect *)x)->m_ref = ret;
154    }
155    else if ((uint8_t *)x < collected_start || (uint8_t *)x >= collected_end)
156    {
157        // Still need to remap cons_cells lying outside of space, for
158        // instance on the stack.
159        for (LObject *cell = NULL; x; cell = x, x = CDR(x))
160        {
161            if (item_type(x) != L_CONS_CELL)
162            {
163                if (cell)
164                    CDR(cell) = CollectObject(CDR(cell));
165                break;
166            }
167            CAR(x) = CollectObject(CAR(x));
168        }
169    }
170
171    return ret;
172}
173
174void Lisp::CollectSymbols(LSymbol *root)
175{
176    if (!root)
177        return;
178
179    root->m_value = CollectObject(root->m_value);
180    root->m_function = CollectObject(root->m_function);
181    root->m_name = (LString *)CollectObject(root->m_name);
182    CollectSymbols(root->m_left);
183    CollectSymbols(root->m_right);
184}
185
186void Lisp::CollectStacks()
187{
188    void **d = l_user_stack.sdata;
189    for (size_t i = 0; i < l_user_stack.m_size; i++, d++)
190        *d = CollectObject((LObject *)*d);
191
192    void ***d2 = PtrRef::stack.sdata;
193    for (size_t i = 0; i < PtrRef::stack.m_size; i++, d2++)
194    {
195        void **ptr = *d2;
196        *ptr = CollectObject((LObject *)*ptr);
197    }
198
199    void ***d3 = reg_ptr_list;
200    for (size_t i = 0; i < reg_ptr_total; i++, d3++)
201    {
202        void **ptr = *d3;
203        *ptr = CollectObject((LObject *)*ptr);
204    }
205}
206
207void Lisp::CollectSpace(LSpace *which_space, int grow)
208{
209    LSpace *old_space = LSpace::Current;
210    cstart = which_space->m_data;
211    cend = which_space->m_free;
212
213    LSpace::Gc.m_size = which_space->m_size;
214    if (grow)
215    {
216        LSpace::Gc.m_size += which_space->m_size >> 1;
217        LSpace::Gc.m_size -= (LSpace::Gc.m_size & 7);
218    }
219    uint8_t *new_data = (uint8_t *)malloc(LSpace::Gc.m_size);
220    LSpace::Current = &LSpace::Gc;
221    LSpace::Gc.m_free = LSpace::Gc.m_data = new_data;
222
223    collected_start = new_data;
224    collected_end = new_data + LSpace::Gc.m_size;
225
226    CollectSymbols(LSymbol::root);
227    CollectStacks();
228
229    // for debuging clear it out
230    memset(which_space->m_data, 0, which_space->m_size);
231    free(which_space->m_data);
232
233    which_space->m_data = new_data;
234    which_space->m_size = LSpace::Gc.m_size;
235    which_space->m_free = new_data + (LSpace::Gc.m_free - LSpace::Gc.m_data);
236    LSpace::Current = old_space;
237}
238
Note: See TracBrowser for help on using the repository browser.