home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / ABUSESRC.ZIP / AbuseSrc / macabuse / src / lisp_gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-05-20  |  6.7 KB  |  269 lines
  1. /*  Lisp garbage collections :  uses copy/free algorithm
  2.     Places to check :
  3.       symbol 
  4.         values
  5.     functions
  6.     names
  7.       stack
  8.  
  9.  
  10.       
  11.  
  12. */
  13. #include <stdlib.h>
  14. #include "lisp.hpp"
  15.  
  16. #ifdef NO_LIBS
  17. #include "fakelib.hpp"
  18. #else
  19. #include "jmalloc.hpp"
  20. #include "macs.hpp"
  21. #include "dprint.hpp"
  22. #endif
  23.  
  24. #include "stack.hpp"
  25.  
  26. #include <string.h>
  27.  
  28.  
  29. grow_stack<void> l_user_stack(600);       // stack user progs can push data and have it GCed
  30. grow_stack<void *> l_ptr_stack(6000);         // stack of user pointers, user pointers get remapped on GC
  31.  
  32. int reg_ptr_total=0;
  33. int reg_ptr_list_size=0;
  34. void ***reg_ptr_list=NULL;
  35.  
  36. void register_pointer(void **addr)
  37. {
  38.   if (reg_ptr_total>=reg_ptr_list_size)
  39.   {
  40.     reg_ptr_list_size+=0x100;
  41.     reg_ptr_list=(void ***)jrealloc(reg_ptr_list,sizeof(void **)*reg_ptr_list_size,"registered ptr list");
  42.   }
  43.   reg_ptr_list[reg_ptr_total++]=addr;
  44. }
  45.  
  46.  
  47. void unregister_pointer(void **addr)
  48. {
  49.   int i;
  50.   void ***reg_on=reg_ptr_list;
  51.   for (i=0;i<reg_ptr_total;i++,reg_on++)
  52.   {
  53.     if (*reg_on==addr)
  54.     {
  55.       int j;
  56.       reg_ptr_total--;
  57.       for (j=i;j<reg_ptr_total;j++,reg_on++)
  58.         reg_on[0]=reg_on[1];      
  59.       return ;
  60.     }
  61.   }
  62.   dprintf("Unable to locate ptr to unregister");
  63. }
  64.  
  65. static void *collect_object(void *x);
  66. static void *collect_array(void *x)
  67. {
  68.   long s=((lisp_1d_array *)x)->size;
  69.   lisp_1d_array *a=new_lisp_1d_array(s,NULL);
  70.   void **src,**dst;
  71.   src=(void **)(((lisp_1d_array *)x)+1);
  72.   dst=(void **)(a+1);
  73.   for (int i=0;i<s;i++)
  74.     dst[i]=collect_object(src[i]);
  75.  
  76.   return a;
  77. }
  78.  
  79. static uchar *cstart,*cend,*collected_start,*collected_end;
  80.  
  81. inline void *collect_cons_cell(void *x)
  82. {
  83.   cons_cell *last=NULL,*first;
  84.   if (!x) return x;
  85.   for (;x && item_type(x)==L_CONS_CELL;)
  86.   {
  87.     cons_cell *p=new_cons_cell();
  88.     void *old_car=((cons_cell *)x)->car;
  89.     void *old_cdr=((cons_cell *)x)->cdr;
  90.     void *old_x=x;
  91.     x=CDR(x);
  92.     ((lisp_collected_object *)old_x)->type=L_COLLECTED_OBJECT;
  93.     ((lisp_collected_object *)old_x)->new_reference=p;
  94.  
  95.     p->car=collect_object(old_car); 
  96.     p->cdr=collect_object(old_cdr); 
  97.       
  98.     if (last) last->cdr=p;
  99.     else first=p;
  100.     last=p;
  101.   }
  102.   if (x)
  103.     last->cdr=collect_object(x);
  104.   return first;                    // we already set the collection pointers
  105. }
  106.  
  107. static void *collect_object(void *x)
  108. {
  109.   void *ret=x;
  110.  
  111.   if (((uchar *)x)>=cstart && ((uchar *)x)<cend)
  112.   {
  113.     switch (item_type(x))
  114.     {
  115.       case L_BAD_CELL :
  116.       { lbreak("error : GC corrupted cell\n"); } break;
  117.  
  118.       case L_NUMBER : 
  119.       { ret=new_lisp_number(((lisp_number *)x)->num); } break;
  120.  
  121.  
  122.       case L_SYS_FUNCTION :
  123.       { ret=new_lisp_sys_function( ((lisp_sys_function *)x)->min_args,
  124.                       ((lisp_sys_function *)x)->max_args,
  125.                       ((lisp_sys_function *)x)->fun_number);
  126.       } break;
  127.       case L_USER_FUNCTION :
  128.       {
  129. #ifndef NO_LIBS
  130.     ret=new_lisp_user_function( ((lisp_user_function *)x)->alist,
  131.                        ((lisp_user_function *)x)->blist);
  132.  
  133. #else
  134.     void *arg=collect_object(((lisp_user_function *)x)->arg_list);
  135.     void *block=collect_object(((lisp_user_function *)x)->block_list);
  136.     ret=new_lisp_user_function(arg,block);
  137. #endif
  138.       } break;
  139.       case L_STRING :
  140.       { ret=new_lisp_string(lstring_value(x)); } break;
  141.  
  142.       case L_CHARACTER :
  143.       { ret=new_lisp_character(lcharacter_value(x)); } break; 
  144.  
  145.       case L_C_FUNCTION :
  146.       {
  147.     ret=new_lisp_c_function( ((lisp_sys_function *)x)->min_args,
  148.                       ((lisp_sys_function *)x)->max_args,
  149.                       ((lisp_sys_function *)x)->fun);
  150.       } break;
  151.  
  152.       case L_C_BOOL :
  153.       {
  154.     ret=new_lisp_c_bool( ((lisp_sys_function *)x)->min_args,
  155.                       ((lisp_sys_function *)x)->max_args,
  156.                       ((lisp_sys_function *)x)->fun);
  157.       } break;
  158.       case L_L_FUNCTION :
  159.       {
  160.     ret=new_user_lisp_function( ((lisp_sys_function *)x)->min_args,
  161.                       ((lisp_sys_function *)x)->max_args,
  162.                       ((lisp_sys_function *)x)->fun_number);
  163.       } break;
  164.  
  165.       case L_POINTER :
  166.       { ret=new_lisp_pointer(lpointer_value(x)); } break;
  167.       
  168.  
  169.       case L_1D_ARRAY :
  170.       { ret=collect_array(x); } break;
  171.  
  172.       case L_FIXED_POINT :
  173.       { ret=new_lisp_fixed_point(lfixed_point_value(x)); } break;
  174.  
  175.       case L_CONS_CELL :
  176.       { ret=collect_cons_cell((cons_cell *)x); } break;
  177.  
  178.       case L_OBJECT_VAR :
  179.       {
  180.     ret=new_lisp_object_var( ((lisp_object_var *)x)->number);
  181.       } break;
  182.       case L_COLLECTED_OBJECT :
  183.       {
  184.     ret=((lisp_collected_object *)x)->new_reference;
  185.       } break;
  186.  
  187.       default :
  188.       { lbreak("shouldn't happen. collecting bad object\n"); } break;      
  189.     }
  190.     ((lisp_collected_object *)x)->type=L_COLLECTED_OBJECT;
  191.     ((lisp_collected_object *)x)->new_reference=ret;
  192.   } else if ((uchar *)x<collected_start || (uchar *)x>=collected_end)  
  193.   {
  194.     if (item_type(x)==L_CONS_CELL) // still need to remap cons_cells outside of space
  195.     {
  196.       for (;x && item_type(x)==L_CONS_CELL;x=CDR(x))
  197.         ((cons_cell *)x)->car=collect_object(((cons_cell *)x)->car);
  198.       if (x)
  199.         ((cons_cell *)x)->cdr=collect_object(((cons_cell *)x)->cdr);
  200.     }
  201.   }
  202.  
  203.   return ret;
  204. }
  205.  
  206. static void collect_symbols(lisp_symbol *root)
  207. {
  208.   if (root)
  209.   {
  210.     root->value=collect_object(root->value);
  211.     root->function=collect_object(root->function);
  212.     root->name=collect_object(root->name);
  213.     collect_symbols(root->left);
  214.     collect_symbols(root->right);
  215.   }
  216. }
  217.  
  218. static void collect_stacks()
  219. {
  220.   long t=l_user_stack.son;
  221.   void **d=l_user_stack.sdata;
  222.   int i=0;
  223.   for (;i<t;i++,d++)
  224.     *d=collect_object(*d);
  225.  
  226.   t=l_ptr_stack.son;
  227.   void ***d2=l_ptr_stack.sdata;
  228.   for (i=0;i<t;i++,d2++)
  229.   {
  230.     void **ptr=*d2;
  231.     *ptr=collect_object(*ptr);
  232.   }
  233.  
  234.   d2=reg_ptr_list;
  235.   for (t=0;t<reg_ptr_total;t++,d2++)
  236.   {
  237.     void **ptr=*d2;
  238.     *ptr=collect_object(*ptr);
  239.   }    
  240.  
  241. }
  242.  
  243. void collect_space(int which_space) // should be tmp or permenant
  244. {
  245.   int old_space=current_space;
  246.   cstart=(uchar *)space[which_space];
  247.   cend=(uchar *)free_space[which_space];
  248.  
  249.   space_size[GC_SPACE]=space_size[which_space];
  250.   void *new_space=jmalloc(space_size[GC_SPACE],"collect lisp space");
  251.   current_space=GC_SPACE;
  252.   free_space[GC_SPACE]=space[GC_SPACE]=(char *)new_space;
  253.  
  254.   collected_start=(uchar *)new_space;
  255.   collected_end=(((uchar *)new_space)+space_size[GC_SPACE]);
  256.  
  257.   collect_symbols(lsym_root);
  258.   collect_stacks();
  259.  
  260.   memset(space[which_space],0,space_size[which_space]);  // for debuging clear it out
  261.   jfree(space[which_space]);
  262.  
  263.   space[which_space]=(char *)new_space;
  264.   free_space[which_space]=((char *)new_space)+
  265.          (((uchar *)free_space[GC_SPACE])-((uchar *)space[GC_SPACE]));
  266.   current_space=old_space;
  267. }
  268.  
  269.