native/relocate.c

   1 #include "factor.h"
   2
   3 void fixup(CELL* cell)
   4 {
   5         if(TAG(*cell) != FIXNUM_TYPE)
   6                 *cell += (active->base - relocation_base);
   7 }
   8
   9 void relocate_object()
  10 {
  11         CELL size;
  12         size = untagged_object_size(relocating);
  13         switch(untag_header(get(relocating)))
  14         {
  15         case ARRAY_TYPE:
  16                 fixup_array((ARRAY*)relocating);
  17                 break;
  18         case VECTOR_TYPE:
  19                 fixup_vector((VECTOR*)relocating);
  20                 break;
  21         case SBUF_TYPE:
  22                 fixup_sbuf((SBUF*)relocating);
  23                 break;
  24         case HANDLE_TYPE:
  25                 fixup_handle((HANDLE*)relocating);
  26         }
  27
  28         relocating += size;
  29 }
  30
  31 void relocate_next()
  32 {
  33         switch(TAG(get(relocating)))
  34         {
  35         case XT_TYPE:
  36                 fixup_word((WORD*)relocating);
  37                 relocating += sizeof(WORD);
  38                 break;
  39         case HEADER_TYPE:
  40                 relocate_object();
  41                 break;
  42         default:
  43                 fixup((CELL*)relocating);
  44                 relocating += CELLS;
  45         }
  46 }
  47
  48 void relocate(CELL r)
  49 {
  50         relocation_base = r;
  51
  52         fixup(&env.boot);
  53         fixup(&env.user[GLOBAL_ENV]);
  54
  55         relocating = active->base;
  56
  57         /* The first three objects in the image must always be
  58            EMPTY, F, T */
  59         if(untag_header(get(relocating)) != EMPTY_TYPE)
  60                 fatal_error("Not empty",get(relocating));
  61         empty = tag_object(relocating);
  62         relocate_next();
  63
  64         if(untag_header(get(relocating)) != F_TYPE)
  65                 fatal_error("Not F",get(relocating));
  66         F = tag_object(relocating);
  67         relocate_next();
  68
  69         if(untag_header(get(relocating)) != T_TYPE)
  70                 fatal_error("Not T",get(relocating));
  71         T = tag_object(relocating);
  72         relocate_next();
  73
  74         for(;;)
  75         {
  76                 if(relocating >= active->here)
  77                         break;
  78
  79                 relocate_next();
  80         }
  81 }