view release on metacpan or  search on metacpan

radamsa/c/libradamsa.c  view on Meta::CPAN

         h = objsize(*new);
         if (old == new) {
            old += h;
            new += h;
         } else {
            while (--h)
               *++new = *++old;
            old++;
            new++;
         }
      } else {
         /* if (teardown_needed(val))
            printf("gc: would teardown\n"); */
         old += objsize(val);
      }
   }
   return new;
}

static void fix_pointers(word *pos, wdiff delta) {
   for (;;) {
      word hdr = *pos;
      hval n = objsize(hdr);
      if (hdr == 0) /* end marker reached. only dragons beyond this point. */
         return;
      if (rawp(hdr)) {
         pos += n; /* no pointers in raw objects */
      } else {
         for (++pos; --n; ++pos) {
            word val = *pos;
            if (allocp(val))
               *pos = val + delta;
         }
      }
   }
}


/* emulate sbrk with malloc'd memory, because sbrk is no longer properly supported */
/* n-cells-wanted → heap-delta (to be added to pointers), updates memstart and memend */
static wdiff adjust_heap(wdiff cells) {
   word *old = memstart;
   word nwords = memend - memstart + MEMPAD; /* MEMPAD is after memend */
   word new_words = nwords + (cells > 0xffffff ? 0xffffff : cells); /* limit heap growth speed */
   if (((cells > 0) && (new_words*W < nwords*W)) || ((cells < 0) && (new_words*W > nwords*W)))
      return 0; /* don't try to adjust heap, if the size_t would overflow in realloc */
   memstart = realloc(memstart, new_words*W);
   if (!memstart) {
      catch_signal(SIGGC);
      return 0;
   } else {
      wdiff delta = (word)memstart - (word)old;
      memend = memstart + new_words - MEMPAD; /* leave MEMPAD words alone */
      if (delta)
         fix_pointers(memstart, delta); /* d'oh! we need to O(n) all the pointers... */
      return delta;
   }
}

/* input desired allocation size and (the only) pointer to root object
   return a pointer to the same object after heap compaction, possible heap size change and relocation */
static word *gc(int size, word *regs) {
   word *root;
   word *realend = memend;
   wdiff nfree;
   fp = regs + objsize(*regs);
   root = fp+1;
   *root = (word) regs;
   memend = fp;
   nalloc += fp - genstart;
   mark(root, fp);
   fp = compact();
   regs = (word *)*root;
   memend = realend;
   nfree = (word)memend - (word)regs;
   if (genstart == memstart) {
      word heapsize = (word) memend - (word) memstart;
      word nused = heapsize - nfree;
      if (maxheap < nused)
         maxheap = nused;
      if (heapsize / (1024 * 1024) > max_heap_mb)
         catch_signal(SIGGC);
      nfree -= size*W + MEMPAD; /* how much really could be snipped off */
      if (nfree < (heapsize / 3) || nfree < 0) {
         /* increase heap size if less than 33% is free by ~10% of heap size (growth usually implies more growth) */
         regs[objsize(*regs)] = 0; /* use an invalid descriptor to denote end live heap data */
         regs = (word *) ((word)regs + adjust_heap(size*W + nused/10 + 4096));
         nfree = memend - regs;
         if (nfree <= size)
            catch_signal(SIGGC);
      } else if (nfree > (heapsize/2)) {
         /* decrease heap size if more than 50% is free by 10% of the free space */
         wdiff dec = -(nfree / 10);
         wdiff new = nfree - dec;
         if (new > size*W*2 + MEMPAD) {
            regs[objsize(*regs)] = 0; /* as above */
            regs = (word *) ((word)regs + adjust_heap(dec+MEMPAD*W));
            heapsize = (word)memend - (word)memstart;
            nfree = (word)memend - (word)regs;
         }
      }
      genstart = regs; /* always start new generation */
   } else if (nfree < MINGEN || nfree < size*W*2) {
      genstart = memstart; /* start full generation */
      return gc(size, regs);
   } else {
      genstart = regs; /* start new generation */
   }
   return regs;
}

/*** OS Interaction and Helpers ***/



/* list length, no overflow or valid termination checks */
static uint llen(word *ptr) {
   uint len = 0;
   while (pairp(ptr)) {
      len++;
      ptr = (word *) ptr[2];