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

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

lisp: count how deep the garbage collector and the evaluator recurse. The
values are unused for now.

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