home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / copy.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-07-07  |  32.5 KB  |  1,221 lines
  1. /* ******************************************************************** */
  2. /*  copy.c        copyright (c) university of bath 1992            */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: copy.c,v 1.32 1992/06/18 10:02:09 pab Exp pab $
  9.  *
  10.  * $Log: copy.c,v $
  11.  * Revision 1.32  1992/06/18  10:02:09  pab
  12.  * corrected macros, etc
  13.  *
  14.  * Revision 1.31  1992/06/16  19:36:24  pab
  15.  * weak wrapper code
  16.  *
  17.  * Revision 1.30  1992/06/14  16:43:45  pab
  18.  * incorporated branch from V1.26
  19.  *
  20.  * Revision 1.29  1992/05/29  12:18:03  pab
  21.  * changed headers
  22.  *
  23.  * Revision 1.28  1992/05/29  09:53:44  rjb
  24.  * ALIGN8 and a NULL -> 0
  25.  *
  26.  * Revision 1.27  1992/05/29  09:47:44  djb
  27.  * hooks for CGC mark+sweep (all #ifdef CGC)
  28.  *
  29.  * Revision 1.26  1992/04/30  19:41:21  pab
  30.  * fiddled with tracing
  31.  *
  32.  * Revision 1.25  1992/04/30  11:07:31  pab
  33.  * lost end-page bug. Lowered rounding
  34.  *
  35.  * Revision 1.24  1992/04/29  12:33:18  pab
  36.  * tracing code added
  37.  *
  38.  * Revision 1.23  1992/04/27  21:55:42  pab
  39.  * if it moves, round it
  40.  *
  41.  * Revision 1.22  1992/04/26  20:55:46  pab
  42.  * fixes for generic version, plus static vector type preliminary support,
  43.  * no-sockets fixes
  44.  *
  45.  * Revision 1.21  1992/03/13  18:06:51  pab
  46.  * SysV fixes (mainly relinquishing pages and synchonisation)
  47.  *
  48.  * Revision 1.20  1992/02/27  15:46:57  pab
  49.  * bytecode + error changes
  50.  *
  51.  * Revision 1.19  1992/02/13  13:49:58  pab
  52.  * *** empty log message ***
  53.  *
  54.  * Revision 1.17  1992/02/11  13:38:04  pab
  55.  * removed printing gc_enabled
  56.  *
  57.  * Revision 1.16  1992/02/10  12:11:41  pab
  58.  * fixed circular lists
  59.  * gc_enabaled now global
  60.  *
  61.  * revision 1.12  1991/04/02  21:25:30  kjp
  62.  * compiler tidying.
  63.  * copying garbage collector. Replaces allocate + garbage.c */
  64.  
  65. #include "defs.h"
  66. #include "structs.h"
  67. #include "funcalls.h"
  68. #include "global.h"
  69. #include "state.h"
  70. #include "copy.h"
  71. #include "weak.h"
  72.  
  73. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  74. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  75.  
  76. #define OTHER_SPACE(x) 1-(x)
  77.  
  78. #define is_newspace(x) \
  79.   ((gcof(x)&1) ==wspace)
  80.  
  81. #define forwardof(x) \
  82.   (lval_classof(x))
  83.  
  84. #define set_forwarded(x, new) \
  85.   ( *(&gcof(x))|=0x2 , forwardof(x)=new)
  86.  
  87. #define is_forwarded(x) \
  88.   ((gcof(x))&0x2)
  89.   
  90. #define HEADERSIZE sizeof(Object_t)
  91. /* should not need to allocate any fixed objects yet... */
  92. #ifdef ALIGN8
  93. #define ROUNDTO 8
  94. #else
  95. #define ROUNDTO 4
  96. #endif
  97. #define ROUND_ADDR(x) ((((int)x)&(ROUNDTO-1))==0 ? x : x+(ROUNDTO-((int)x&(ROUNDTO-1))))
  98. #define is_fixed(x) 0
  99.  
  100. #ifndef NODEBUG
  101. #define TRACE_GC  /* writes allocation logging to a file */
  102. #endif
  103. #ifdef TRACE_GC
  104. #include <time.h>
  105.   FILE *trace_file;
  106.   int counters[256];
  107.   int total_moved;
  108. #endif
  109.  
  110. /* which space are we in */
  111. static int wspace;
  112. static char *free_ptr;
  113. static char *pg_end;
  114. int gc_paranoia=0;
  115. static int collect_count;
  116.  
  117. /* BSD + SYSV */
  118. static LispObject GC_thread;
  119.   
  120. /* SYSV only */
  121. SYSTEM_GLOBAL(SystemSemaphore,GC_sem);
  122. SYSTEM_GLOBAL(SystemSemaphore,Rig_sem);
  123. SYSTEM_GLOBAL(int,GC_state);
  124. static SYSTEM_GLOBAL(int,GC_register);      /* Who's arrived so far... */
  125. static SYSTEM_GLOBAL(int,GC_exit_register); /* Who's left... */
  126. static SYSTEM_GLOBAL(int,GC_turn);         /* whose go */
  127. static SYSTEM_GLOBAL(int,gc_enabled);         /* can we... */
  128. static SYSTEM_GLOBAL_ARRAY1(LispObject,GC_register_array,MAX_PROCESSORS);
  129. static LispObject GC_tame_continue;
  130. static SYSTEM_GLOBAL(PageList, old_pages);
  131. /* Valid only in non-gc time */
  132. static SYSTEM_GLOBAL(PageList, free_pages);
  133. static SYSTEM_GLOBAL(int,npages);
  134. static SYSTEM_GLOBAL(int,pagelim);
  135.  
  136. static SYSTEM_GLOBAL(LispObject, weak_list);
  137.  
  138. static PageList current_page;
  139. static PageList used_pages;
  140.  
  141. /* Called from inside copier */
  142. #define ALLOC_SPACE(new,type,ptr,size) \
  143.   {  \
  144.     new= (type) ptr;         \
  145.     ptr+=size;             \
  146.     if (ptr>=pg_end) \
  147.       {                \
  148.     GRAB_PAGE(NULL,ptr,pg_end);    \
  149.     new= (type) ptr;         \
  150.     ptr+=size;        \
  151.        }            \
  152.       }
  153.  
  154. #ifdef MACHINE_ANY
  155. #define GRAB_PAGE_INTERNAL(stacktop,ptr,top)         \
  156.    {                     \
  157.       ptr=free_pages->start;         \
  158.       top=free_pages->end;         \
  159.       current_page=free_pages;        \
  160.       free_pages=free_pages->next;         \
  161.       current_page->next=used_pages;         \
  162.       used_pages=current_page;              \
  163.       npages++;                    \
  164.       COPY_BUG(fprintf(stderr,"{Grab: %d}",    \
  165.                current_page->id));    \
  166.     }
  167.  
  168. #define GRAB_PAGE(x,y,z) GRAB_PAGE_INTERNAL(x,y,z)
  169.  
  170. #else
  171. #define GRAB_PAGE_INTERNAL(stacktop,ptr,top)         \
  172.    {                     \
  173.       ptr=ROUND_ADDR(S_G_V(free_pages)->start);         \
  174.       top=S_G_V(free_pages)->end;         \
  175.       current_page=S_G_V(free_pages);        \
  176.       S_G_V(free_pages)=S_G_V(free_pages)->next;         \
  177.       current_page->next=used_pages;         \
  178.       used_pages=current_page;              \
  179.       S_G_V(npages)++;                    \
  180.       COPY_BUG(fprintf(stderr,"{Grab(%d): %d}",    \
  181.                system_scheduler_number,        \
  182.                current_page->id));        \
  183.       COPY_BUG(memset(ptr,'x',top-ptr));        \
  184.     }
  185.  
  186. #define GRAB_PAGE(stacktop,ptr,top)         \
  187.   {                            \
  188.     system_open_semaphore(stacktop,&S_G_V(GC_sem));     \
  189.     GRAB_PAGE_INTERNAL(stacktop,ptr,top);        \
  190.     system_close_semaphore(&S_G_V(GC_sem));        \
  191.   }
  192.  
  193. #endif
  194.  
  195. #define MAYBE_GRAB_PAGE(res,stacktop,ptr,top)             \
  196. {                            \
  197.     system_open_semaphore(stacktop,&S_G_V(GC_sem));     \
  198.     if (S_G_V(npages)<S_G_V(pagelim))            \
  199.       {                            \
  200.         GRAB_PAGE_INTERNAL(stacktop,ptr,top);        \
  201.         res=1;                        \
  202.       }                            \
  203.     else                        \
  204.       res=0;                    \
  205.   /**/                        \
  206.     system_close_semaphore(&S_G_V(GC_sem)); \
  207.   }
  208.   
  209. #define PRINT_LISTS(stream)        \
  210. {            \
  211.     PageList xx;        \
  212.     fputs("Free: ",stream);    \
  213.     xx=S_G_V(free_pages);        \
  214.     while (xx!=NULL)        \
  215.       { fprintf(stream,"%d ",xx->id);        \
  216.     xx=xx->next;        \
  217.       }                \
  218.     fputs("\nUsed: ",stream);    \
  219.     xx=used_pages;        \
  220.     while (xx!=NULL)        \
  221.       { fprintf(stream,"%d ",xx->id);        \
  222.     xx=xx->next;        \
  223.       }        \
  224.     fputc('\n',stream);        \
  225.   }
  226.  
  227.  
  228. void init_allocator(int size)
  229. {
  230. #ifndef CGC
  231.   PageList *newpage;
  232.   char *space;
  233.   char *end;
  234.   int allocated=0;
  235.   int pg_count=0;
  236.  
  237. #ifndef MACHINE_ANY
  238.  
  239.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,GC_sem,NULL);
  240.   system_allocate_semaphore(&S_G_V(GC_sem));
  241.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,Rig_sem,NULL);
  242.   system_allocate_semaphore(&S_G_V(Rig_sem));
  243.   SYSTEM_INITIALISE_GLOBAL(int,GC_state,GC_DONE);
  244.   SYSTEM_INITIALISE_GLOBAL(int,GC_register,0);
  245.   SYSTEM_INITIALISE_GLOBAL(int,GC_exit_register,0);
  246.   SYSTEM_INITIALISE_GLOBAL(int,pagelim,0);
  247.   SYSTEM_INITIALISE_GLOBAL(PageList,free_pages,NULL);
  248.   SYSTEM_INITIALISE_GLOBAL(PageList,old_pages,NULL);
  249.   SYSTEM_INITIALISE_GLOBAL(int,npages,NULL);
  250.   SYSTEM_INITIALISE_GLOBAL(int,GC_turn,NULL);
  251.   SYSTEM_INITIALISE_GLOBAL_ARRAY1(LispObject,
  252.                   GC_register_array,MAX_PROCESSORS,NULL);
  253. #endif
  254.  
  255.   SYSTEM_INITIALISE_GLOBAL(int,gc_enabled,0);
  256.   SYSTEM_INITIALISE_GLOBAL(LispObject,weak_list,NULL);
  257.   newpage= &S_G_V(free_pages);  
  258. #undef SYSTEM_MAX_SHARED_SIZE
  259. #define SYSTEM_MAX_SHARED_SIZE 512*1024
  260.  
  261.   while (allocated<size)
  262.     {
  263.       space=system_malloc(SYSTEM_MAX_SHARED_SIZE);
  264.       end=space+SYSTEM_MAX_SHARED_SIZE;
  265.       COPY_BUG(memset(space,'T',2*size));
  266.   
  267.       while (space<end)
  268.     {    
  269.       *newpage=(PageList) space;
  270.       (*newpage)->status=PAGE_FREE;
  271.       (*newpage)->end= ((space+PAGE_SIZE) < end ? space+PAGE_SIZE : end);
  272.       (*newpage)->id=pg_count;
  273.       (*newpage)->next=NULL;
  274.       newpage= &((*newpage)->next);
  275.       space+=PAGE_SIZE;
  276.       pg_count++;
  277.     }
  278.       allocated+=SYSTEM_MAX_SHARED_SIZE;
  279.     }
  280.  
  281.   *newpage=NULL;
  282.   
  283.   printf("Initialised with: %x [%d pages]\n",size,pg_count);
  284.   COPY_BUG(PRINT_LISTS(stderr));
  285.   used_pages=NULL;
  286.   wspace=0;
  287.   S_G_V(pagelim)=pg_count/2;
  288.   S_G_V(npages)=0;
  289.   GRAB_PAGE(NULL,free_ptr,pg_end);
  290.  
  291. #endif
  292. }
  293.  
  294.  
  295. void runtime_initialise_garbage_collector(LispObject *stacktop)
  296. {
  297.   (GC_tame_continue)=allocate_continue(stacktop);
  298.   GC_thread=nil;
  299.  
  300.   add_root(&GC_tame_continue);
  301.   add_root(&GC_thread);
  302. }
  303.  
  304. void initialise_garbage(LispObject *stacktop)
  305. {  /* Pretend we're a module */
  306.   LispObject garbage_collect(LispObject *);
  307.  
  308.   GC_thread = allocate_thread(stacktop,2048,1024,0);
  309.   (void) make_module_function(stacktop,"GC",garbage_collect,0);
  310. }
  311.  
  312. /* Called when a new process forks */
  313. #ifndef MACHINE_ANY
  314. void runtime_reset_allocator(LispObject *stacktop)
  315. {
  316.   COPY_BUG(fprintf(stderr,"Proc: %d starting\n",system_scheduler_number));
  317.  
  318.   used_pages=NULL;
  319.   GRAB_PAGE(NULL,free_ptr,pg_end);
  320.  
  321.   GC_thread = allocate_thread(stacktop,2048,1024,0);
  322.   add_root(&GC_thread);
  323.   (GC_tame_continue)=allocate_continue(stacktop);
  324.   add_root(&GC_tame_continue);
  325.   system_open_semaphore(stacktop,&S_G_V(Rig_sem));
  326.   RIG_GC_THREAD(stacktop);
  327.   system_close_semaphore(&S_G_V(Rig_sem));
  328.  
  329. }
  330. #endif
  331.  
  332. EUFUN_0(garbage_collect)
  333. {
  334.   void do_gc_sync(LispObject *);
  335.  
  336.   do_gc_sync(stacktop);
  337.   return nil;
  338.  
  339. }
  340. EUFUN_CLOSE
  341.  
  342. int current_space()
  343. {
  344.   return wspace;
  345. }
  346.  
  347. #ifndef MACHINE_ANY
  348. extern void rig_gc_thread(LispObject *stacktop)
  349. {
  350. #ifndef MACHINE_ANY
  351.   RIG_GC_THREAD(stacktop);
  352. #endif
  353. }
  354. #endif
  355.  
  356. /* c-roots */
  357. #define MAXROOTS 300
  358. static int nroots=0;
  359.  
  360. LispObject *roots[MAXROOTS];
  361.  
  362. int add_root(LispObject *root)
  363. {    
  364.   int x=nroots;
  365.  
  366.   roots[nroots++]=root;
  367.   
  368.   return x;
  369. }
  370.  
  371. void copy_root(LispObject *x)
  372. {
  373.   LispObject copy_object(LispObject);
  374.   *x=copy_object(*x);
  375. }
  376.  
  377. void copy_on()
  378. {
  379.   S_G_V(gc_enabled)++;
  380.   COPY_BUG(fprintf(stderr,"{+%d}",S_G_V(gc_enabled)));
  381. }
  382.  
  383. void copy_off()
  384. {
  385.   S_G_V(gc_enabled)--;
  386.   COPY_BUG(fprintf(stderr,"{-%d}",S_G_V(gc_enabled)));
  387. }
  388.  
  389. /* These will have to more complicated eventually */
  390. void ON_collect()
  391. {
  392.   S_G_V(gc_enabled)++;
  393.   COPY_BUG(fprintf(stderr,"{+%d}",S_G_V(gc_enabled)));
  394. }
  395.  
  396. void OFF_collect()
  397. {
  398.   S_G_V(gc_enabled)--;
  399.   COPY_BUG(fprintf(stderr,"{-%d}",S_G_V(gc_enabled)));
  400. }
  401. /****************************************
  402.  * allocation 
  403.  ****************************************/
  404.  
  405. static int a_count;
  406. #define ALLOC_GAP 2048
  407. int alloc_gap=ALLOC_GAP;
  408.  
  409. #ifdef CGC
  410. LispObject allocate_nbytes(LispObject *stacktop,int n,int type)
  411. {
  412.   LispObject object;
  413.  
  414.   object=(LispObject)gc_malloc(n);
  415.   lval_typeof(object)=type;
  416.   return(object);
  417. }
  418. #else
  419. LispObject allocate_nbytes(LispObject *stacktop,int n,int type)
  420. {
  421.   void do_gc_sync(LispObject *);
  422.   LispObject object;
  423.   char *new;
  424.   
  425.   COPY_BUG(if (n<HEADERSIZE) fprintf(stderr,"Object too small to hold header\n") );
  426.  
  427. #ifdef TRACE_GC
  428.   counters[type&255]++;
  429. #endif
  430.  
  431. #ifndef NODEBUG  
  432.   if (gc_paranoia)
  433.     fprintf(stdout,"{%x:%d}",type,n);
  434. #endif
  435.   n=ROUND_ADDR(n);
  436.   a_count+=n;
  437. #ifdef NODEBUG
  438.   if ( !(free_ptr+n<pg_end))
  439. #else
  440.   if ((gc_paranoia && a_count>alloc_gap && S_G_V(gc_enabled))
  441.       || !(free_ptr+n<pg_end))
  442. #endif    
  443.     {
  444.       int res;
  445.       MAYBE_GRAB_PAGE(res,stacktop,free_ptr,pg_end);
  446.       
  447.       if (!res)
  448.     {
  449.       a_count=0;
  450.       if (S_G_V(gc_enabled)<1)
  451.         { 
  452.           fprintf(stderr,"{Grabbed Page 'cos I couldn't GC[%d]}\n",S_G_V(gc_enabled));
  453.           GRAB_PAGE(stacktop,free_ptr,pg_end);
  454.         }
  455.       else
  456.         {
  457.           do_gc_sync(stacktop);
  458.         }
  459.     }
  460.     }
  461.   ALLOC_SPACE(object,LispObject,free_ptr,n);
  462.  
  463.   lval_typeof(object)=type;
  464.   gcof(object)=(short)wspace;
  465.   return(object);
  466. }
  467. #endif
  468.  
  469. #ifdef MACHINE_ANY
  470. void do_gc_sync(LispObject *stacktop)
  471. {
  472.   static void free_old_pgs(void);
  473.   static void swap_spaces(LispObject *);    
  474.   static void free_weak_ptrs(void);
  475.   fprintf(stderr,"Collection %d initiated: %d used, %d bytes (%d%%) remaining\n",
  476.       collect_count,S_G_V(npages)*PAGE_SIZE,(S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,0);
  477.   
  478.    S_G_V(old_pages)=NULL;
  479.    S_G_V(npages)=0;
  480.    S_G_V(weak_list)=NULL;
  481.    swap_spaces(stacktop);
  482.   
  483.    free_old_pgs();
  484.    free_weak_ptrs();
  485.  }
  486. #else /* ! MACHINE_ANY */
  487. void do_gc_sync(LispObject *stacktop)
  488. {
  489.   static void free_weak_ptrs(void);
  490.   static void free_old_pgs(void);
  491.   int i;
  492.  
  493.   /* we must save state early */
  494.   save_state(stacktop,CURRENT_THREAD()->THREAD.state);
  495.   /* Wait for the last gc to finish */
  496.   while (  S_G_V(GC_state)!=GC_DONE
  497.      &&S_G_V(GC_state)!=GC_SINKING)
  498.     ;
  499.   /* register myself */
  500.   system_open_semaphore(stacktop,&S_G_V(GC_sem));
  501.   ++S_G_V(GC_register);
  502.   if (S_G_V(GC_register) == 1)
  503.     {                    /* First */
  504.       S_G_V(GC_state) = GC_SINKING;
  505.       fprintf(stderr,"GC sinking(%d) ---  ",S_G_V(gc_enabled));
  506.     }
  507.  
  508.   fprintf(stderr,"%d ",system_scheduler_number);
  509.   /* if last, set flag */
  510.   if (S_G_V(GC_register) == RUNNING_PROCESSORS())
  511.     { /* Last */
  512.       S_G_V(GC_state) = GC_REGISTERED;
  513.       fprintf(stderr,"\n"); fflush(stdout);
  514.       fprintf(stderr,"Collection %d initiated: %d used, %d bytes (%d%%) remaining\n",
  515.           collect_count,S_G_V(npages)*PAGE_SIZE,(S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,0);
  516.       S_G_V(GC_turn)=0;
  517.       S_G_V(npages)=0;
  518.       S_G_V(old_pages) = NULL;
  519.       S_G_V(weak_list)=NULL;
  520.     }        
  521.   
  522.   system_close_semaphore(&S_G_V(GC_sem));
  523.   
  524.  
  525.   SYSTEM_GLOBAL_ARRAY1_VALUE(GC_register_array,system_scheduler_number) 
  526.     = CURRENT_THREAD();
  527.   
  528.   /* boot any sleepers */
  529.  
  530.   system_kick_sleepers();
  531.  
  532.   /* wait until all get the idea */
  533.   while (S_G_V(GC_state)!=GC_REGISTERED)
  534.     ;
  535.   /* Save myself */
  536.  
  537.   /* we all copy --- in serial 'cos its easier that way */
  538.  
  539.   while(S_G_V(GC_turn)!=system_scheduler_number)
  540.     ;
  541.  
  542.   if (!set_continue(stacktop,(GC_tame_continue)))
  543.     {
  544.       LispObject temp = CURRENT_THREAD();
  545.       LispObject *newstack;
  546.  
  547.       COPY_BUG(fprintf(stderr," {Proc: %d leaping %x %x %x}\n",system_scheduler_number,
  548.                (GC_tame_continue)->CONTINUE.thread,GC_thread,temp));
  549.       newstack = load_thread(GC_thread);
  550.       call_continue(newstack,GC_thread->THREAD.state,temp);
  551.     }
  552.   
  553.   /* done: should signal this */
  554.  
  555.   S_G_V(GC_turn)++;
  556.   
  557.   if (system_scheduler_number==RUNNING_PROCESSORS()-1)
  558.     {    
  559.       free_old_pgs();
  560.       free_weak_ptrs();
  561.       S_G_V(GC_state)=GC_MARKED;
  562.     }
  563.  
  564.   while(S_G_V(GC_state)!=GC_MARKED)
  565.       ;
  566.   /* Now we can go */
  567.  
  568.   system_open_semaphore(stacktop,&S_G_V(GC_sem));
  569.   --S_G_V(GC_register);
  570.   if (S_G_V(GC_register)==0)
  571.     S_G_V(GC_state)=GC_DONE;
  572.   system_close_semaphore(&S_G_V(GC_sem));
  573.  
  574.   
  575.   fprintf(stderr,"GC done\n");
  576.   
  577. }
  578.  
  579.  
  580. void first_gc_mark_call(LispObject *stacktop)
  581. {
  582.   void swap_spaces(LispObject *stacktop);
  583.  
  584.   LispObject ret;
  585.  
  586.   COPY_BUG(printf("First invokation of GC mark: %x\n",stacktop); fflush(stdout));
  587.   stacktop=GC_thread->THREAD.gc_stack_base;
  588.  reset:
  589.  
  590.   ret = GC_thread->THREAD.state->CONTINUE.value;
  591.  
  592.   COPY_BUG(printf("Laying continue in GC mark: %x\n",stacktop); fflush(stdout));    
  593.   if (set_continue(stacktop,(GC_thread->THREAD.state)))
  594.     {    
  595.       goto reset;
  596.     }
  597.   STACK_TMP(ret);
  598.  
  599.   COPY_BUG(printf("Marking in GC mark\n"); fflush(stdout));
  600.  
  601.   swap_spaces(stacktop);
  602.   UNSTACK_TMP(ret);
  603.   COPY_BUG(fprintf(stderr,"Jumping back: target: (%x %d) %x %d %d %d %d\n  gc_thread: (%x %d) %x %d %d\n",
  604.            ret,ret->THREAD.header.gc,
  605.            ret->THREAD.state, 
  606.            ret->THREAD.state->CONTINUE.header.gc,
  607.            ret->THREAD.state->CONTINUE.header.type,
  608.            ret->THREAD.state->CONTINUE.handler_stack->CONS.header.type,
  609.            ret->THREAD.state->CONTINUE.handler_stack->CONS.header.gc,
  610.            GC_thread,
  611.            GC_thread->THREAD.header.gc,
  612.            GC_thread->THREAD.state, 
  613.            GC_thread->THREAD.state->CONTINUE.header.gc,
  614.            GC_thread->THREAD.state->CONTINUE.header.type);
  615.        fflush(stdout));
  616.   /**save_state(stacktop,GC_thread);**/
  617.   (void) load_thread(ret); /* this returns the wrong value for our porpoises */
  618.   call_continue(NULL,(GC_tame_continue),nil);
  619. }
  620. #endif
  621.  
  622.  
  623.  
  624. /* Collection */
  625.  
  626. void swap_spaces(LispObject *stacktop)
  627. {
  628.   void copy_root(LispObject *);
  629.   void show_stack_space(void);
  630.   static void free_old_pgs(void);
  631.  
  632.   char *oldspace;
  633.   PageList pg,tmp,*ptr;
  634.   int i;
  635.  
  636. #ifdef TRACE_GC
  637.   {
  638.     long time_now;
  639.     char *str;
  640.     int k,j=0;
  641.     
  642.     if (trace_file==NULL)
  643.       {    
  644.       char *buf[20];
  645.       sprintf(buf,"/tmp/gc.%d",getpid());
  646.   
  647.       trace_file=fopen(buf,"w");
  648.       }
  649.  
  650.     time_now=time(NULL);
  651.     str=ctime(&time_now);
  652.     fprintf(trace_file,"GC %d started: %s\n",collect_count,str);
  653.     fprintf(trace_file,"Used: %d\n",S_G_V(npages)*PAGE_SIZE);
  654.  
  655.     for (k=0; k<255; k++)
  656.       {    
  657.     if (counters[k]!=0)
  658.       {
  659.         fprintf(trace_file,"%d: %6d ",k,counters[k]);
  660.         if ((++j)%6==0)
  661.           fputc('\n',trace_file);
  662.       }
  663.     counters[k]=0;
  664.       }    
  665.     total_moved=0;
  666.     fputc('\n',trace_file);
  667.     PRINT_LISTS(trace_file);
  668.     fflush(trace_file);
  669.   }
  670. #endif
  671.   
  672.   /* make sure that all is well */
  673.   save_state(stacktop,CURRENT_THREAD()->THREAD.state);
  674.   COPY_BUG(PRINT_LISTS(stderr));
  675.   
  676.   pg=current_page;
  677.   used_pages=NULL;
  678.   wspace=1-wspace;
  679.   /* begin the copy process */
  680.   GRAB_PAGE(stacktop,free_ptr,pg_end);
  681.  
  682.   for (i=0; i < nroots; i++)
  683.     copy_root(roots[i]);
  684.  
  685.   /* Free all oldspace */
  686.   /* Assumes that free_pages is unlocked */
  687.   while (pg!=NULL)
  688.     { /* insertion sort on the old pages */
  689.       tmp=pg->next;
  690.  
  691.       ptr=&S_G_V(old_pages);
  692.       if (*ptr!=NULL)
  693.     {
  694.       while ((*ptr)->next!=NULL
  695.          && (*ptr)->next->id < pg->id)
  696.         ptr=&(*ptr)->next;
  697.       
  698.       pg->next=(*ptr)->next;
  699.       (*ptr)->next=pg;
  700.     }
  701.       else 
  702.     {
  703.       *ptr=pg;
  704.       pg->next=NULL;
  705.     }
  706.       pg=tmp;
  707.     }
  708.  
  709.   fprintf(stderr,"Collection Completed: %d used, %d bytes (%d%%) remaining\n",
  710.       S_G_V(npages)*PAGE_SIZE,
  711.       (S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,
  712.       ((S_G_V(pagelim)-S_G_V(npages))*100)/
  713.       S_G_V(pagelim));
  714.   show_stack_space();
  715.   collect_count++;
  716.   COPY_BUG(PRINT_LISTS(stderr));
  717.  
  718. #ifdef TRACE_GC
  719.   {
  720.     long time_now;
  721.     char *str;
  722.     int k,j;
  723.     time_now=time(NULL);
  724.     str=ctime(&time_now);
  725.     fprintf(trace_file,"Using: %d\n",S_G_V(npages)*PAGE_SIZE);
  726.     PRINT_LISTS(trace_file);
  727.     fprintf(trace_file,"Totals: %d\n",total_moved);    
  728.     for (k=0,j=0; k<255; k++)
  729.       {    
  730.     if (counters[k]!=0)
  731.       {
  732.         fprintf(trace_file,"%d: %6d ",k,counters[k]);
  733.         if ((++j)%6==0)
  734.           fputc('\n',trace_file);
  735.         counters[k]=0;
  736.       }
  737.       }
  738.     fprintf(trace_file,"GC %d complete: %s\n",collect_count,str);
  739.     fflush(trace_file);
  740.   }
  741. #endif
  742.   return;
  743. }
  744.  
  745. static void free_old_pgs()
  746. {
  747.   PageList tmp;
  748.  
  749.   tmp=S_G_V(free_pages);
  750.   
  751.   if (tmp==NULL)
  752.     S_G_V(free_pages)=S_G_V(old_pages);
  753.   else 
  754.     {
  755.       while(tmp->next!=NULL)
  756.     {
  757.       tmp=tmp->next;
  758.     }
  759.       tmp->next=S_G_V(old_pages);
  760.     }
  761. }
  762.  
  763. void free_weak_ptrs()
  764. {
  765.   LispObject wptr;
  766.   
  767.   wptr=S_G_V(weak_list);
  768.   
  769.   while (wptr!=NULL)
  770.     {
  771.       if (is_forwarded(weak_ptr_val(wptr)))
  772.     weak_ptr_val(wptr)=forwardof(weak_ptr_val(wptr));
  773.       else
  774.     weak_ptr_val(wptr)=nil;
  775.       
  776.       wptr=weak_ptr_chain(wptr);
  777.     }
  778.   S_G_V(weak_list)=NULL;
  779. }
  780. #ifndef NODEBUG
  781. #define CAREFUL_DECLS   \
  782.    LispObject copied; 
  783.  
  784. #ifdef NOLOWTAGINTS
  785. #define copy_obj_careful(x) \
  786.   (copied=copy_object(x),  \
  787.    copied==NULL || ((gcof(copied)&1)==wspace)  \
  788.    ? copied             \
  789.    : (fprintf(stderr,"Wrong space\n"), system_lisp_exit(0), nil))
  790. #else 
  791. #define  copy_obj_careful(x) \
  792.    (copied=copy_object(x),    \
  793.     (copied==NULL || is_fixnum(x) || ((gcof(copied)&1)==wspace))  \
  794.     ? copied \
  795.     : (fprintf(stderr,"Wrong space\n"), system_lisp_exit(0), nil))
  796.  
  797. #endif /*NOLOWTAGINTS*/
  798. #else
  799. #define CAREFUL_DECLS 
  800. #define copy_obj_careful(x) (copy_object(x))
  801. #endif
  802.  
  803. #define FORWARD_HEADER(new,obj) \
  804.   lval_typeof(new)=lval_typeof(obj);    \
  805.   gcof(new)=wspace;            \
  806.   class=lval_classof(obj);        \
  807.   set_forwarded(obj,new);
  808.  
  809. #define COPY_ALLOC_SPACE(ptr,size)        \
  810.   ALLOC_SPACE(new,LispObject,ptr,ROUND_ADDR(size)); 
  811.  
  812. /* Hack the stackpointer for GRAB_PAGE */
  813.  
  814. LispObject copy_object(LispObject obj)
  815. {
  816.   int i;
  817.   LispObject new;
  818.   LispObject class;
  819.   CAREFUL_DECLS;
  820.  
  821.   if (obj==NULL) return NULL;
  822. #ifndef NOLOWTAGINTS
  823.   if (is_fixnum(obj)) return obj;
  824. #endif
  825.  
  826.   if (is_forwarded(obj))
  827.     return forwardof(obj);
  828.  
  829.   if (is_newspace(obj))
  830.     return obj;
  831.   else
  832.     {
  833. #ifdef TRACE_GC
  834.       counters[lval_typeof(obj)&255]++;
  835. #endif
  836.  
  837.       switch(lval_typeof(obj))
  838.     {
  839.     case TYPE_NULL:
  840. #if 0
  841.     case TYPE_CONS:
  842. #endif
  843.       /* Null is (cons nil  nil) with hacked type */
  844.       COPY_ALLOC_SPACE(free_ptr,  sizeof(struct cons_structure));
  845.       FORWARD_HEADER(new,obj);
  846.       lval_classof(new)=copy_obj_careful(class);
  847.       CAR(new)=copy_obj_careful(CAR(obj));
  848.       CDR(new)=copy_obj_careful(CDR(obj));
  849.       break;
  850. #if 1
  851.     case TYPE_CONS:
  852.       /* allocate space */
  853.       {    
  854.         LispObject walker,newcons;
  855.         int count, max;
  856.         COPY_ALLOC_SPACE(free_ptr,  sizeof(struct cons_structure));
  857.         FORWARD_HEADER(new,obj);
  858.  
  859.         CAR(new)=class;
  860.         walker=CDR(obj);
  861.         max=1;
  862.         /* Note: this loop does not copy anything */
  863.         while (   walker!=NULL
  864. #ifdef NOLOWTAGINTS
  865.            && !is_fixnum(walker)
  866. #endif
  867.            && is_cons(walker)
  868.            && !is_forwarded(walker)
  869.            && !is_newspace(walker))
  870.           {
  871.         ALLOC_SPACE(newcons,LispObject,free_ptr,  sizeof(struct cons_structure));
  872.         FORWARD_HEADER(newcons,walker);
  873.         /* Keep the class safe */
  874.         CAR(newcons)=class;
  875.         walker=CDR(walker);
  876.         max++;
  877.           }
  878.         /* COPY_BUG(fprintf(stderr,"(List: %d elts",max)); */
  879.  
  880.         newcons=new;
  881.         /* This loop does all the copying 
  882.            end is now the stopping point */
  883.         
  884.         count=0;
  885.         walker=obj;
  886.         while (count<max)
  887.           {
  888.         lval_classof(newcons)=copy_obj_careful(CAR(newcons));
  889.         CAR(newcons)=copy_obj_careful(CAR(walker));
  890.         /* except for the end case equiv to CDR(newcons)=newcons+a bit */
  891.         CDR(newcons)=copy_obj_careful(CDR(walker));
  892.         walker=CDR(walker);
  893.         newcons=CDR(newcons);
  894.         count++;
  895.           }    
  896.       }
  897.       break;
  898. #endif
  899. #ifdef NOLOWTAGINTS      
  900.     case TYPE_INT:
  901.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct integer_structure));
  902.       FORWARD_HEADER(new,obj);
  903.       lval_classof(new)=copy_obj_careful(class);
  904.       intval(new)=intval(obj);
  905.       break;
  906. #endif
  907.     case TYPE_ENV:
  908.        COPY_ALLOC_SPACE(free_ptr,sizeof(struct envobject));
  909.       FORWARD_HEADER(new,obj);
  910.       lval_classof(new)=copy_obj_careful(class);
  911.       new->ENV.variable = copy_obj_careful(obj->ENV.variable);
  912.       new->ENV.value = copy_obj_careful(obj->ENV.value);
  913.       new->ENV.next = (Env) copy_obj_careful((LispObject)obj->ENV.next);
  914.       new->ENV.mutable = copy_obj_careful(obj->ENV.mutable);
  915.       break;
  916.  
  917.     case TYPE_B_MACRO:
  918.     case TYPE_METHOD:
  919.     case TYPE_GENERIC:
  920.     case TYPE_B_FUNCTION:
  921.     case TYPE_INSTANCE:
  922.       /* allocate space */
  923.       i=lval_classof(obj)->CLASS.local_count;
  924.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  925.       FORWARD_HEADER(new,obj);
  926.       
  927.       lval_classof(new)=copy_obj_careful(class);
  928.       for (i=0 ; i<class->CLASS.local_count ; i++)
  929.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  930.       break;
  931.       
  932.     case TYPE_VECTOR:
  933.     case TYPE_VECTOR|STATIC_TYPE:
  934.       if (is_static(obj))
  935.         {
  936.          gcof(obj)=wspace; new=obj;
  937.          class=lval_classof(obj);
  938.         }
  939.       else
  940.         {
  941.           COPY_ALLOC_SPACE(free_ptr,sizeof(Object_t)+sizeof(int)+sizeof(LispObject)*obj->VECTOR.length);
  942.           FORWARD_HEADER(new,obj);
  943.         }
  944.       lval_classof(new)= copy_obj_careful(class);
  945.       new->VECTOR.length=obj->VECTOR.length;
  946.       for (i=0; i<obj->VECTOR.length; i++)
  947.         vref(new,i) = copy_obj_careful(vref(obj,i));
  948.       break;
  949.  
  950.     case TYPE_STRING:
  951.       COPY_ALLOC_SPACE(free_ptr,ROUND_ADDR(sizeof(Object_t)+obj->STRING.length+sizeof(int)));
  952.       FORWARD_HEADER(new,obj);
  953.       lval_classof(new)=copy_obj_careful(class);
  954.       new->STRING.length=obj->STRING.length;
  955.       memcpy(stringof(new),stringof(obj),obj->STRING.length);
  956.       break;
  957.  
  958.     case TYPE_CLASS:
  959.       i=lval_classof(obj)->CLASS.local_count;
  960.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  961.       FORWARD_HEADER(new,obj);
  962.       lval_classof(new)=copy_obj_careful(class);
  963.       (new->CLASS).name = copy_obj_careful(obj->CLASS.name);
  964.       (new->CLASS).superclasses = copy_obj_careful(obj->CLASS.superclasses);
  965.       (new->CLASS).subclasses = copy_obj_careful(obj->CLASS.subclasses);
  966.       (new->CLASS).slot_table = copy_obj_careful(obj->CLASS.slot_table);
  967.       (new->CLASS).slot_list = copy_obj_careful(obj->CLASS.slot_list);
  968.       (new->CLASS).direct_slot_list = copy_obj_careful(obj->CLASS.direct_slot_list);
  969.       (new->CLASS).precedence = copy_obj_careful(obj->CLASS.precedence);
  970.       (new->CLASS).local_count = obj->CLASS.local_count;
  971.       for (i=N_SLOTS_IN_CLASS ; i<class->CLASS.local_count ; i++)
  972.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  973.       break;
  974.  
  975.     case TYPE_CHAR:
  976.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct character_structure));
  977.       FORWARD_HEADER(new,obj);
  978.       lval_classof(new)=copy_obj_careful(class);
  979.       new->CHAR.font=obj->CHAR.font;
  980.       new->CHAR.code=obj->CHAR.code;
  981.       break; 
  982.  
  983.     case TYPE_TABLE:
  984.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct table_structure));
  985.       FORWARD_HEADER(new,obj);
  986.       lval_classof(new)=copy_obj_careful(class);
  987.       new->TABLE.comparator=obj->TABLE.comparator;
  988.       new->TABLE.lisp_comparator= copy_obj_careful(obj->TABLE.lisp_comparator);
  989.       new->TABLE.tree= copy_obj_careful(obj->TABLE.tree);
  990.       break;
  991.  
  992.     case TYPE_CONTINUE:
  993.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct continue_structure));
  994.       FORWARD_HEADER(new,obj);
  995.       lval_classof(new)=copy_obj_careful(class);
  996.       (new->CONTINUE).thread = copy_obj_careful(obj->CONTINUE.thread);
  997.       
  998.       (new->CONTINUE).value = copy_obj_careful(obj->CONTINUE.value);
  999.       (new->CONTINUE).target = copy_obj_careful((obj->CONTINUE).target);
  1000.  
  1001.       bcopy((char*)(obj->CONTINUE).machine_state, 
  1002.         (char *)new->CONTINUE.machine_state,
  1003.         sizeof(new->CONTINUE.machine_state));
  1004.       (new->CONTINUE).gc_stack_pointer = obj->CONTINUE.gc_stack_pointer;
  1005.  
  1006.       (new->CONTINUE).dynamic_env = (Env)copy_obj_careful((LispObject)obj->CONTINUE.dynamic_env);
  1007.       (new->CONTINUE).last_continue = copy_obj_careful(obj->CONTINUE.last_continue);
  1008.       (new->CONTINUE).handler_stack = copy_obj_careful(obj->CONTINUE.handler_stack);
  1009.       (new->CONTINUE).dp = copy_obj_careful(obj->CONTINUE.dp);
  1010.  
  1011.       (new->CONTINUE).live = obj->CONTINUE.live;
  1012.       (new->CONTINUE).unwind = obj->CONTINUE.unwind;  
  1013.       break;
  1014.       
  1015.     case TYPE_SPECIAL:
  1016.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct special_structure));
  1017.       FORWARD_HEADER(new,obj);
  1018.       lval_classof(new)=copy_obj_careful(class);
  1019.       new->SPECIAL.name = copy_obj_careful(obj->SPECIAL.name);
  1020.       new->SPECIAL.env = (Env)copy_obj_careful((LispObject)obj->SPECIAL.env);
  1021.       new->SPECIAL.func = obj->SPECIAL.func;
  1022.       break;
  1023.  
  1024.     case TYPE_SYMBOL:    
  1025.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct symbol_structure));
  1026.       FORWARD_HEADER(new,obj);
  1027.       lval_classof(new)=copy_obj_careful(class);
  1028.       (new->SYMBOL).pname = copy_obj_careful(obj->SYMBOL.pname);
  1029.       (new->SYMBOL).lvalue = copy_obj_careful(obj->SYMBOL.lvalue);
  1030.       (new->SYMBOL).lmodule = copy_obj_careful(obj->SYMBOL.lmodule);
  1031.       (new->SYMBOL).gvalue = copy_obj_careful(obj->SYMBOL.gvalue);
  1032.       (new->SYMBOL).plist = copy_obj_careful(obj->SYMBOL.plist);
  1033.       (new->SYMBOL).left = copy_obj_careful(obj->SYMBOL.left);
  1034.       (new->SYMBOL).right = copy_obj_careful(obj->SYMBOL.right);
  1035.       (new->SYMBOL).hash = (obj->SYMBOL.hash);
  1036.       break;
  1037.  
  1038.     case TYPE_STREAM:
  1039.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct stream_structure));
  1040.       FORWARD_HEADER(new,obj);
  1041.       lval_classof(new) = copy_obj_careful(class);
  1042.       (new->STREAM).handle = obj->STREAM.handle;
  1043.       (new->STREAM).name = copy_obj_careful(obj->STREAM.name);
  1044.       (new->STREAM).mode = obj->STREAM.mode;
  1045.       (new->STREAM).curchar = new->STREAM.curchar;
  1046.       break;
  1047.       
  1048.     case TYPE_C_MODULE: /* These are statically allocated, so just mark */
  1049.       /* forward to here -- unset fwd bit+ set right space */
  1050.       gcof(obj)=wspace; new=obj;
  1051.       class=lval_classof(obj);
  1052.       lval_classof(obj)=copy_obj_careful(class);
  1053.       obj->C_MODULE.name=copy_obj_careful(obj->C_MODULE.name);
  1054.       obj->C_MODULE.home=copy_obj_careful(obj->C_MODULE.home);
  1055.       obj->C_MODULE.imported_modules=copy_obj_careful(obj->C_MODULE.imported_modules);
  1056.       obj->C_MODULE.exported_names=copy_obj_careful(obj->C_MODULE.exported_names);
  1057.       obj->C_MODULE.bindings=copy_obj_careful(obj->C_MODULE.bindings);
  1058.       obj->C_MODULE.entry_count=copy_obj_careful(obj->C_MODULE.entry_count);
  1059.       obj->C_MODULE.values=copy_obj_careful(obj->C_MODULE.values);
  1060.  
  1061.       break;
  1062.  
  1063.     case TYPE_I_MODULE:
  1064.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct i_module_structure));
  1065.       FORWARD_HEADER(new,obj);
  1066.       lval_classof(new)= copy_obj_careful(class);
  1067.       new->I_MODULE.name= copy_obj_careful(obj->I_MODULE.name);
  1068.       new->I_MODULE.home= copy_obj_careful(obj->I_MODULE.home);
  1069.       new->I_MODULE.imported_modules= copy_obj_careful(obj->I_MODULE.imported_modules);
  1070.       new->I_MODULE.exported_names= copy_obj_careful(obj->I_MODULE.exported_names);
  1071.       new->I_MODULE.bindings= copy_obj_careful(obj->I_MODULE.bindings);
  1072.       new->I_MODULE.bounce_flag= obj->I_MODULE.bounce_flag;
  1073.       break;
  1074.  
  1075.     case TYPE_C_FUNCTION:
  1076.     case TYPE_C_MACRO:
  1077.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct c_function_structure));
  1078.       FORWARD_HEADER(new,obj);
  1079.       lval_classof(new) = copy_obj_careful(class);
  1080.       new->C_FUNCTION.name = copy_obj_careful(obj->C_FUNCTION.name);
  1081.       new->C_FUNCTION.home = copy_obj_careful(obj->C_FUNCTION.home);
  1082.       new->C_FUNCTION.env = (Env)copy_obj_careful((LispObject)obj->C_FUNCTION.env);
  1083.       new->C_FUNCTION.argtype = obj->C_FUNCTION.argtype;
  1084.       new->C_FUNCTION.func=obj->C_FUNCTION.func;
  1085.       break;
  1086.       
  1087.     case TYPE_I_FUNCTION:    
  1088.     case TYPE_I_MACRO:
  1089.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct i_function_structure));
  1090.       FORWARD_HEADER(new,obj);
  1091.       lval_classof(new)=copy_obj_careful(class);
  1092.       new->I_FUNCTION.name=copy_obj_careful(obj->I_FUNCTION.name);
  1093.       new->I_FUNCTION.home=copy_obj_careful(obj->I_FUNCTION.home);
  1094.       new->I_FUNCTION.env=(Env)copy_obj_careful((LispObject)obj->I_FUNCTION.env);
  1095.       new->I_FUNCTION.bvl=copy_obj_careful(obj->I_FUNCTION.bvl);
  1096.       new->I_FUNCTION.body=copy_obj_careful(obj->I_FUNCTION.body);
  1097.       new->I_FUNCTION.argtype=obj->I_FUNCTION.argtype;
  1098.       break;
  1099.  
  1100.     case TYPE_FLOAT:
  1101.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct float_structure));
  1102.       FORWARD_HEADER(new,obj);
  1103.       lval_classof(new)=copy_obj_careful(class);
  1104.       new->FLOAT.fvalue=obj->FLOAT.fvalue;
  1105.       break;
  1106. #if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
  1107.     case TYPE_LISTENER:
  1108.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct listener_structure));
  1109.       FORWARD_HEADER(new,obj);
  1110.       lval_classof(new)=copy_obj_careful(class);
  1111.       bcopy(&(obj->LISTENER.socket),&(new->LISTENER.socket),sizeof(new->LISTENER.socket));
  1112.       bcopy(&(obj->LISTENER.name),&(new->LISTENER.name),sizeof(new->LISTENER.name));
  1113.       bcopy(&(obj->LISTENER.state),&(new->LISTENER.state),sizeof(new->LISTENER.state));
  1114.       break;
  1115.  
  1116.     case TYPE_SOCKET:
  1117.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct socket_structure));
  1118.       FORWARD_HEADER(new,obj);
  1119.       lval_classof(new)=copy_obj_careful(class);
  1120.       bcopy(&(obj->SOCKET.socket),&(new->SOCKET.socket),sizeof(new->SOCKET.socket));
  1121.       bcopy(&(obj->SOCKET.name),&(new->SOCKET.name),sizeof(new->SOCKET.name));
  1122.       bcopy(&(obj->SOCKET.state),&(new->SOCKET.state),sizeof(new->SOCKET.state));
  1123.       bcopy((obj->SOCKET.buffer),(new->SOCKET.buffer),sizeof(new->SOCKET.buffer));
  1124.       break;
  1125. #endif
  1126.     case TYPE_THREAD:
  1127.       i=lval_classof(obj)->CLASS.local_count;
  1128.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  1129.       FORWARD_HEADER(new,obj);
  1130.       lval_classof(new) = copy_obj_careful(class);
  1131.       new->THREAD.stack_size = obj->THREAD.stack_size;
  1132.       new->THREAD.gc_stack_size = obj->THREAD.gc_stack_size; 
  1133.  
  1134.       new->THREAD.fun = copy_obj_careful(obj->THREAD.fun);
  1135.       new->THREAD.args = copy_obj_careful(obj->THREAD.args);
  1136.       new->THREAD.value = copy_obj_careful(obj->THREAD.value);
  1137.  
  1138.       new->THREAD.status = obj->THREAD.status;
  1139.  
  1140.       new->THREAD.parent = copy_obj_careful(obj->THREAD.parent);
  1141.       new->THREAD.cochain = copy_obj_careful(obj->THREAD.cochain);
  1142.   
  1143.       new->THREAD.state = copy_obj_careful(obj->THREAD.state);
  1144.     
  1145.       new->THREAD.stack_base = obj->THREAD.stack_base;
  1146.       new->THREAD.gc_stack_base = obj->THREAD.gc_stack_base;
  1147.       for (i=N_SLOTS_IN_THREAD ; i<class->CLASS.local_count ; i++)
  1148.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  1149.       /* hack */
  1150.       if (obj->THREAD.gc_stack_base+obj->THREAD.gc_stack_size < obj->THREAD.state->CONTINUE.gc_stack_pointer)
  1151.         fprintf(stderr,"GC Stack overflow detected\n");
  1152.  
  1153.       {         
  1154.         LispObject *x=obj->THREAD.gc_stack_base;
  1155.         
  1156.         while (x<obj->THREAD.state->CONTINUE.gc_stack_pointer)
  1157.           { 
  1158.         if (!(((int) *x)&1)) /* Check for tags here */
  1159.           *x = copy_obj_careful(*x);
  1160.         ++x;
  1161.           }
  1162.       }
  1163.       break;
  1164.       
  1165.     case TYPE_WEAK_WRAPPER:
  1166.       COPY_ALLOC_SPACE(free_ptr,WEAK_PTR_SIZE*sizeof(LispObject)+sizeof(Object_t));
  1167.       FORWARD_HEADER(new,obj);    
  1168.       lval_classof(new) = copy_obj_careful(class);  
  1169.       weak_ptr_chain(new)=S_G_V(weak_list);
  1170.       weak_ptr_val(new)=weak_ptr_val(obj);
  1171.       S_G_V(weak_list)=new;
  1172.       break;
  1173.  
  1174.     default:
  1175.       fprintf(stderr,"Can't copy: %x\n",typeof(obj));
  1176.       return obj;
  1177.       break;
  1178.     }
  1179.       return new;
  1180.     }
  1181. }
  1182.  
  1183. /*****************************************/
  1184. /* Old code */
  1185.  
  1186. #ifdef NOWAY     /* Attempt to allocate n objects --- not really viable */
  1187. static char * allocate_bytes(LispObject *stacktop,int n);
  1188. LispObject allocate_nbytes(LispObject *stacktop, int size, int type)
  1189. {
  1190.   LispObject object;
  1191.  
  1192.   object=(LispObject) allocate_bytes(stacktop,size);
  1193.  
  1194.   lval_typeof(object)=type;
  1195.   gcof(object)=(short)wspace;
  1196.   return(object);
  1197. }
  1198.  
  1199. LispObject allocate_cbytes(LispObject *stacktop, int n, int size, int type)
  1200. {
  1201.   char *space,*ptr;
  1202.   int i;
  1203.  
  1204.   /* Hope to get lucky of alignment */
  1205.   space= allocate_bytes(stacktop,size*n);
  1206.   ptr=space;
  1207.  
  1208.   for (i=0; i<n; i++)
  1209.     {
  1210.       LispObject new;
  1211.       new=(LispObject)ptr;
  1212.       lval_typeof(new)=type;
  1213.       gcof(new)=wspace;
  1214.       
  1215.       ptr+=size;
  1216.     }
  1217.   return (LispObject) space;
  1218. }    
  1219. #endif
  1220.  
  1221.