source: golgotha/src/i4/lisp/li_alloc.cc @ 80

Last change on this file since 80 was 80, checked in by Sam Hocevar, 12 years ago
  • Adding the Golgotha source code. Not sure what's going to be interesting in there, but since it's all public domain, there's certainly stuff to pick up.
File size: 13.6 KB
Line 
1/********************************************************************** <BR>
2  This file is part of Crack dot Com's free source code release of
3  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
4  information about compiling & licensing issues visit this URL</a>
5  <PRE> If that doesn't help, contact Jonathan Clark at
6  golgotha_source@usa.net (Subject should have "GOLG" in it)
7***********************************************************************/
8
9#include "init/init.hh"
10#include "memory/malloc.hh"
11#include "lisp/li_types.hh"
12#include "lisp/lisp.hh"
13#include "main/main.hh"
14#include "time/profile.hh"
15#include "threads/threads.hh"
16#include <setjmp.h>
17
18static i4_critical_section_class syms_lock;
19static i4_critical_section_class cell_lock;
20static volatile int threads_need_gc=0;
21
22li_object_pointer *li_object_pointer_list=0;
23i4_profile_class pf_li_gc("li_gc");
24
25
26li_object *li_not(li_object *o, li_environment *env)
27{
28  li_object *v=li_eval(li_car(o,env),env);
29  if (!v || v==li_nil)
30    return li_true_sym;
31  else return li_nil;
32}
33
34li_object *li_progn(li_object *o, li_environment *env)
35{
36  li_object *ret=li_nil;
37  while (o)
38  {
39    ret=li_eval(li_car(o,env),env);
40    o=li_cdr(o,env);
41  }
42  return ret;
43}
44
45li_object *li_if(li_object *o, li_environment *env)
46{
47  li_object *v=li_eval(li_car(o,env), env);
48
49  if (v && v!=li_nil)
50    return li_eval(li_second(o,env),env);
51 
52  o=li_cdr(li_cdr(o,env),env);
53  if (o)
54    return li_eval(li_car(o,env), env);
55  else return li_nil;
56}
57
58li_object *li_equal(li_object *o, li_environment *env)
59{
60  li_object *o1=li_eval(li_first(o,env),env);
61  li_object *o2=li_eval(li_second(o,env),env);
62
63  if (o1->type()==o2->type())
64    if (li_get_type(o1->type())->equal(o1, o2))
65      return li_true_sym;
66 
67  return li_nil;
68}
69
70
71
72li_object_pointer::li_object_pointer(li_object *obj)
73{
74  o=obj;
75  next=li_object_pointer_list;
76  li_object_pointer_list=this;
77}
78
79li_object_pointer::~li_object_pointer()
80{
81  if (this==li_object_pointer_list)
82    li_object_pointer_list=next;
83  else
84  {
85    li_object_pointer *last=0, *p;
86    for (p=li_object_pointer_list; p && p!=this;)
87    {
88      last=p;
89      p=p->next;
90    }
91    if (p!=this)
92      li_error(0, "couldn't find object pointer to unlink");
93    last->next=next;
94  }
95}
96
97
98// global symbols
99li_symbol *li_nil=0,
100  *li_true_sym=0,
101  *li_quote=0,
102  *li_backquote=0,
103  *li_comma=0,
104  *li_function_symbol=0;
105
106static li_gc_object_marker_class *gc_helpers=0;
107
108li_gc_object_marker_class::li_gc_object_marker_class()
109{
110  next=gc_helpers;
111  gc_helpers=this;
112}
113
114li_gc_object_marker_class::~li_gc_object_marker_class()
115{
116  if (gc_helpers==this)
117    gc_helpers=gc_helpers->next;
118  else
119  {
120    li_gc_object_marker_class *last=0, *p;
121    for (p=gc_helpers; p!=this;)
122    {
123      last=p;
124      p=p->next;       
125    }
126    if (!p)
127      li_error(0,"gc_object marker not in list");
128    last->next=p->next;
129  }
130}
131
132void li_mark_symbols(int set);
133
134
135li_symbol *li_root=0;
136
137extern li_symbol *li_root;
138
139
140
141li_symbol *li_find_symbol(const char *name)     // if symbol doesn't exsist, it is created
142{
143  syms_lock.lock();
144  if (li_root)
145  {
146    li_symbol *p=li_root;
147    while (1)
148    {
149      int cmp=strcmp(name,p->name()->value());
150      if (cmp<0)
151      {
152        if (p->left())
153          p=p->left();
154        else
155        {
156          syms_lock.unlock();
157          return 0;
158        }
159      } else if (cmp>0)
160      {
161        if (p->right())
162          p=p->right();
163        else
164        {
165          syms_lock.unlock();
166          return 0;
167        }
168      } else
169      {
170        syms_lock.unlock();
171        return p;
172      }
173    }
174  }
175
176  syms_lock.unlock();
177  return 0;
178}
179
180li_symbol *li_get_symbol(const char *name)     // if symbol doesn't exsist, it is created
181{
182  syms_lock.lock();
183  if (!li_root)
184  {
185    li_root=new li_symbol(new li_string(name));
186    syms_lock.unlock();
187    return li_root;
188  }
189  else
190  {
191    li_symbol *p=li_root;
192    while (1)
193    {
194      int cmp=strcmp(name,p->name()->value());
195      if (cmp<0)
196      {
197        if (p->left())
198          p=p->left();
199        else
200        {
201          p->set_left(new li_symbol(new li_string(name)));
202          syms_lock.unlock();
203          return p->left();
204        }
205      } else if (cmp>0)
206      {
207        if (p->right())
208          p=p->right();
209        else
210        {
211          p->set_right(new li_symbol(new li_string(name)));
212          syms_lock.unlock();
213          return p->right();
214        }
215      } else
216      {
217        syms_lock.unlock();
218        return p;
219      }
220    }
221  }
222
223  syms_lock.unlock();
224  return 0;
225}
226
227li_symbol *li_get_symbol(char *name, li_symbol *&cache_to)
228{
229  if (cache_to) return cache_to;
230  cache_to=li_get_symbol(name);
231  return cache_to;
232}
233
234void li_recursive_mark(li_symbol *p, int set)
235{
236  if (p)
237  {
238    li_get_type(LI_SYMBOL)->mark(p, set);
239    li_recursive_mark(p->left(), set);
240    li_recursive_mark(p->right(), set);
241  }
242}
243
244void li_mark_symbols(int set)
245{
246  li_recursive_mark(li_root, set);   
247}
248
249
250
251void li_mark_symbol_tree(li_symbol *s, int set)
252{
253  if (s)
254  {
255    if (set!=s->is_marked())
256      li_get_type(LI_SYMBOL)->mark(s, set);
257
258    li_mark_symbol_tree(s->left(), set);
259    li_mark_symbol_tree(s->right(), set);
260  }
261}
262
263void li_mark_memory_region(li_list **start, li_list **end,
264                           li_list *c1, li_list *c2, int set)
265{
266  if (set)
267  {
268    for (li_list **s=start; s!=end; s++)         
269      if ( ((long)(*s)&7)==0 &&  *s>=c1 && *s<c2 && (*s)->type() && !(*s)->is_marked())
270        li_get_type( (*s)->unmarked_type() )->mark(*s,1);
271  }
272  else
273    for (li_list **s=start; s!=end; s++)
274      if (((long)(*s)&7)==0 && *s>=c1 && *s<c2 && (*s)->is_marked())
275        li_get_type( (*s)->unmarked_type() )->mark(*s,0);
276 
277}
278
279li_object *li_setf(li_object *o, li_environment *env)
280{
281  li_symbol *s=li_symbol::get(li_car(o,env),env);  o=li_cdr(o,env);
282  li_object *value=li_eval(li_car(o,env), env);
283  li_set_value(s, value, env);
284  return value;
285}
286
287li_object *li_quote_fun(li_object *o, li_environment *env)
288{
289  return li_car(o,env);
290}
291
292li_object *li_new(li_object *o, li_environment *env)
293{
294  int type=li_type::get(li_eval(li_car(o,env)),env)->value();
295  return li_get_type(type)->create(li_cdr(o,env), env);
296}
297
298int li_max_cells=20*1024;
299
300li_object *li_ptr(li_object *o, li_environment *env)
301{
302  return (li_object *)(li_get_int(li_eval(li_car(o,env), env),env));
303}
304
305
306class li_memory_manager_class : public i4_init_class
307{
308public:
309  li_list *cells, *cstart;
310  li_list *first_free;
311
312  void get_stack_range(li_object *&start, li_object *&end)
313  {
314    void *current_stack_object;
315    li_object *current_stack=(li_object *)(&current_stack_object);
316
317    li_list **stack_start=((li_list **)i4_stack_base);
318
319    if ((long)stack_start<(long)current_stack)
320    {
321      start=(li_object *)stack_start;
322      end=current_stack;
323    }
324    else
325    {
326      end=(li_object *)stack_start;
327      start=current_stack;
328    }
329  }
330
331  i4_bool valid_object(li_object *o)
332  {
333    if ((li_list *)o>=cstart && ((li_list *)o)<cstart+li_max_cells && li_valid_type(o->type()))
334      return i4_T;
335    else
336    {
337      if (i4_stack_base!=0)
338      {
339        li_object *s,*e;
340        get_stack_range(s,e);
341       
342        if (o>=s && o<e)
343          return i4_T;
344      }
345
346      return i4_F;
347    }
348  }
349
350  int init_type() { return I4_INIT_TYPE_LISP_MEMORY; }
351
352  void mark_stacks(int mark)
353  {
354    int id=i4_get_first_thread_id();
355    do
356    {
357      void *base, *top;
358      i4_get_thread_stack(id, base,top);
359      if (base<top)
360        li_mark_memory_region((li_list **)base,(li_list **)top,                               
361                              cells, cells+li_max_cells, mark);
362      else
363        li_mark_memory_region((li_list **)top,(li_list **)base,
364                              cells, cells+li_max_cells, mark);
365    } while (i4_get_next_thread_id(id, id));
366  }
367
368
369  // gc : Garbage Collection
370  // scans & marks all cells referenced by
371  // symbols, main stack, thread stacks, global_pointers, & helper objects
372  int gc()
373  {
374    int t_free=0;
375
376    if (i4_get_thread_id()!=i4_get_main_thread_id())
377    {
378      // if this is called from a thread stop and let main program do gc()
379      threads_need_gc=1;
380      while (threads_need_gc)
381        i4_thread_yield();
382
383      cell_lock.lock();
384      for (int i=0; i<li_max_cells; i++)
385      {
386        if (cells[i]._type==LI_INVALID_TYPE)
387          t_free++;
388      }
389      cell_lock.unlock();
390    }
391    else
392    {
393      li_object_pointer *pl;
394      int i;
395
396      if (!i4_stack_base)
397        i4_error("gc:: need to call li_gc_init() from main prog");
398     
399      pf_li_gc.start();
400
401      cell_lock.lock();
402
403      i4_suspend_other_threads();
404      mark_stacks(1);
405
406      li_mark_symbols(1);
407
408      if (li_root)     // if the system has shut down, don't mark type's objects
409      {
410        for (i=1; i<li_max_types(); i++)
411        {
412          li_type_function_table *t=li_get_type(i);
413          if (t)
414            t->mark(1);
415        }
416      }
417
418      li_gc_object_marker_class *helpers;
419      for (helpers=gc_helpers; helpers; helpers=helpers->next)
420        helpers->mark_objects(1);
421
422      for (pl=li_object_pointer_list; pl; pl=pl->next)
423        if (pl->o && !pl->o->is_marked())
424          li_get_type(pl->o->type())->mark(pl->o, 1);
425
426      first_free=0;
427      for (i=0; i<li_max_cells; i++)
428      {
429        if (!cells[i].is_marked())
430        {
431          if (cells[i].type()!=LI_INVALID_TYPE)
432          {
433            li_get_type(cells[i].type())->free(cells+i);
434            cells[i].mark_free();
435            cells[i]._type=LI_INVALID_TYPE;
436          }
437
438
439          // add to free_list
440          cells[i].set_next_free(first_free);
441          first_free=cells+i;
442          t_free++;
443        }
444      }
445
446
447      // unmark the stacks
448      mark_stacks(0);
449
450      // unmark symbols
451      li_mark_symbols(0);
452
453      if (li_root)
454      {
455        for (i=1; i<li_max_types(); i++)
456        {
457          li_type_function_table *t=li_get_type(i);
458          if (t)
459            t->mark(0);
460        }
461      }
462
463
464      for (helpers=gc_helpers; helpers; helpers=helpers->next)
465        helpers->mark_objects(0);
466
467      for (pl=li_object_pointer_list; pl; pl=pl->next)
468        if (pl->o && pl->o->is_marked())
469          li_get_type(pl->o->unmarked_type())->mark(pl->o, 0);
470
471      cell_lock.unlock();
472      threads_need_gc=0;
473      i4_resume_other_threads();
474      pf_li_gc.stop();
475    }
476
477    return t_free;
478  }
479
480  li_list *alloc_list()
481  {
482    if (!first_free)
483    {
484      if (!gc())
485        i4_error("li_alloc : out of li_list");     
486    }
487   
488    cell_lock.lock();
489    li_list *ret=first_free;
490    first_free=first_free->get_next_free();
491    cell_lock.unlock();
492
493
494    return ret;
495  }
496
497  void free_list(li_list *l)
498  {
499    cell_lock.lock();
500    int i=l-cells;
501
502    // add to free_list
503    cells[i]._type=LI_INVALID_TYPE;
504    cells[i].set_next_free(first_free);
505    first_free=cells+i;
506
507    cell_lock.unlock();
508  }
509
510
511  void init()
512  {
513    if (sizeof(li_list)!=8 || sizeof(li_int)!=8)
514      li_error(0, "this code assumes lisp objects are size 8");
515
516
517    cells=(li_list *)i4_malloc(li_max_cells * sizeof(li_list),"");
518    cstart=cells;
519
520    if (((long)cells)&7)  // pointer needs to alligned to 8 byte boundary
521    {
522      cells=((li_list *)(((long)cells&(~7))+8));
523      li_max_cells--;
524    }
525
526    for (int i=0; i<li_max_cells-1; i++)
527    {
528      cells[i].mark_free();
529      cells[i].set_next_free(cells+i+1);
530    }
531
532    cells[li_max_cells-1].set_next_free(0);
533    cells[li_max_cells-1].mark_free();
534
535    first_free=cells;
536
537    li_nil=li_get_symbol("nil");        li_set_value(li_nil, li_nil);
538
539    li_true_sym=li_get_symbol("T");     li_set_value(li_true_sym, li_true_sym);
540    li_quote=li_get_symbol("'");
541    li_backquote==li_get_symbol("`");
542    li_comma=li_get_symbol(",");
543    li_function_symbol=li_get_symbol("#");
544
545    li_add_function("not", li_not);
546    li_add_function("progn", li_progn);
547    li_add_function("equal", li_equal);
548    li_add_function("if", li_if);
549    li_add_function("load", li_load);
550    li_add_function("setf", li_setf);
551    li_add_function("print", li_print);
552    li_add_function(li_quote, li_quote_fun);
553    li_add_function("new", li_new);
554    li_add_function("read-eval", li_read_eval);
555    li_add_function("ptr", li_ptr);
556  }
557
558
559  void uninit()
560  {
561    li_root=0;
562
563    // clear all pointer references
564    for (li_object_pointer *pl=li_object_pointer_list; pl; pl=pl->next)
565      pl->o=0;
566
567    int t_free=gc();
568
569
570    if (t_free!=li_max_cells)
571    {
572      i4_warning("li_cleanup : possibly %d items still referenced",
573                 li_max_cells-t_free);
574
575      for (int i=0; i<li_max_cells; i++)
576        cells[i].mark_free();
577    }
578
579    // delete all types
580    for (int t=0; t<li_max_types(); t++)
581      if (t==0 || li_valid_type(t))
582        li_remove_type(t);
583
584    li_cleanup_types();
585
586    i4_free(cstart);
587  }
588
589} li_mem_man;
590
591
592void *li_cell8_alloc()
593{
594  if (threads_need_gc && i4_get_thread_id()==i4_get_main_thread_id())
595   li_gc();
596   
597  return li_mem_man.alloc_list();
598}
599
600
601void li_cell8_free(void *ptr)
602{
603  li_mem_man.free_list((li_list *)ptr);
604}
605
606int li_gc()
607{
608  jmp_buf env;       // save all registers on the stack
609  setjmp(env);
610
611
612  return li_mem_man.gc();
613}
614
615
616i4_bool li_valid_object(li_object *o)
617{
618  return li_mem_man.valid_object(o);
619}
Note: See TracBrowser for help on using the repository browser.