ghc/rts/Storage.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Storage.c,v 1.2 1998/12/02 13:28:57 simonm Exp $
   3  *
   4  * Storage manager front end
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 #include "Rts.h"
   9 #include "RtsUtils.h"
  10 #include "RtsFlags.h"
  11 #include "Stats.h"
  12 #include "Hooks.h"
  13 #include "BlockAlloc.h"
  14 #include "gmp.h"
  15 #include "Weak.h"
  16
  17 #include "Storage.h"
  18 #include "StoragePriv.h"
  19
  20 bdescr *nursery;                /* chained-blocks in the nursery */
  21 bdescr *current_nursery;        /* next available nursery block, or NULL */
  22 nat nursery_blocks;             /* number of blocks in the nursery */
  23
  24 StgClosure    *caf_list         = NULL;
  25
  26 bdescr *small_alloc_list;       /* allocate()d small objects */
  27 bdescr *large_alloc_list;       /* allocate()d large objects */
  28 nat alloc_blocks;               /* number of allocate()d blocks since GC */
  29 nat alloc_blocks_lim;           /* approximate limit on alloc_blocks */
  30
  31 StgPtr alloc_Hp    = NULL;      /* next free byte in small_alloc_list */
  32 StgPtr alloc_HpLim = NULL;      /* end of block at small_alloc_list   */
  33
  34 /*
  35  * Forward references
  36  */
  37 static void *stgAllocForGMP   (size_t size_in_bytes);
  38 static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
  39 static void  stgDeallocForGMP (void *ptr, size_t size);
  40
  41 void
  42 initStorage (void)
  43 {
  44   initBlockAllocator();
  45
  46   nursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
  47
  48   weak_ptr_list = NULL;
  49   caf_list = NULL;
  50
  51   /* initialise the allocate() interface */
  52   small_alloc_list = NULL;
  53   large_alloc_list = NULL;
  54   alloc_blocks = 0;
  55   alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
  56
  57 #ifdef COMPILER
  58   /* Tell GNU multi-precision pkg about our custom alloc functions */
  59   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
  60 #endif
  61 }
  62
  63 bdescr *
  64 allocNursery (bdescr *last_bd, nat blocks)
  65 {
  66   bdescr *bd;
  67   nat i;
  68
  69   /* Allocate a nursery */
  70   for (i=0; i < blocks; i++) {
  71     bd = allocBlock();
  72     bd->link = last_bd;
  73     bd->step = 0;
  74     bd->free = bd->start;
  75     last_bd = bd;
  76   }
  77   nursery_blocks = blocks;
  78   current_nursery = last_bd;
  79   return last_bd;
  80 }
  81
  82 void
  83 exitStorage (void)
  84 {
  85   lnat allocated;
  86   bdescr *bd;
  87
  88   /* Return code ignored for now */
  89   /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
  90   allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
  91   for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
  92     allocated -= BLOCK_SIZE_W;
  93   }
  94   stat_exit(allocated);
  95 }
  96
  97 void
  98 newCAF(StgClosure* caf)
  99 {
 100   const StgInfoTable *info = get_itbl(caf);
 101
 102   ASSERT(info->type == IND_STATIC);
 103   STATIC_LINK2(info,caf) = caf_list;
 104   caf_list = caf;
 105 }
 106
 107 /* -----------------------------------------------------------------------------
 108    The allocate() interface
 109
 110    allocate(n) always succeeds, and returns a chunk of memory n words
 111    long.  n can be larger than the size of a block if necessary, in
 112    which case a contiguous block group will be allocated.
 113    -------------------------------------------------------------------------- */
 114
 115 StgPtr
 116 allocate(nat n)
 117 {
 118   bdescr *bd;
 119   StgPtr p;
 120
 121   TICK_ALLOC_PRIM(n,wibble,wibble,wibble)
 122   CCS_ALLOC(CCCS,n);
 123
 124   /* big allocation (>LARGE_OBJECT_THRESHOLD) */
 125   if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
 126     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 127     bd = allocGroup(req_blocks);
 128     bd->link = large_alloc_list;
 129     bd->back = NULL;
 130     if (large_alloc_list) {
 131       large_alloc_list->back = bd; /* double-link the list */
 132     }
 133     large_alloc_list = bd;
 134     bd->step = 0;
 135     /* don't add these blocks to alloc_blocks, since we're assuming
 136      * that large objects are likely to remain live for quite a while
 137      * (eg. running threads), so garbage collecting early won't make
 138      * much difference.
 139      */
 140     return bd->start;
 141
 142   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
 143   } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
 144     if (small_alloc_list) {
 145       small_alloc_list->free = alloc_Hp;
 146     }
 147     bd = allocBlock();
 148     bd->link = small_alloc_list;
 149     small_alloc_list = bd;
 150     bd->step = 0;
 151     alloc_Hp = bd->start;
 152     alloc_HpLim = bd->start + BLOCK_SIZE_W;
 153     alloc_blocks++;
 154   }
 155
 156   p = alloc_Hp;
 157   alloc_Hp += n;
 158   return p;
 159 }
 160
 161 lnat allocated_bytes(void)
 162 {
 163   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 164 }
 165
 166 /* -----------------------------------------------------------------------------
 167    Allocation functions for GMP.
 168
 169    These all use the allocate() interface - we can't have any garbage
 170    collection going on during a gmp operation, so we use allocate()
 171    which always succeeds.  The gmp operations which might need to
 172    allocate will ask the storage manager (via doYouWantToGC()) whether
 173    a garbage collection is required, in case we get into a loop doing
 174    only allocate() style allocation.
 175    -------------------------------------------------------------------------- */
 176
 177 static void *
 178 stgAllocForGMP (size_t size_in_bytes)
 179 {
 180   StgArrWords* arr;
 181   nat data_size_in_words, total_size_in_words;
 182
 183   /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
 184   ASSERT(size_in_bytes % sizeof(W_) == 0);
 185
 186   data_size_in_words  = size_in_bytes / sizeof(W_);
 187   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 188
 189   /* allocate and fill it in. */
 190   arr = (StgArrWords *)allocate(total_size_in_words);
 191   SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
 192
 193   /* and return a ptr to the goods inside the array */
 194   return(BYTE_ARR_CTS(arr));
 195 }
 196
 197 static void *
 198 stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
 199 {
 200     void *new_stuff_ptr = stgAllocForGMP(new_size);
 201     nat i = 0;
 202     char *p = (char *) ptr;
 203     char *q = (char *) new_stuff_ptr;
 204
 205     for (; i < old_size; i++, p++, q++) {
 206         *q = *p;
 207     }
 208
 209     return(new_stuff_ptr);
 210 }
 211
 212 static void
 213 stgDeallocForGMP (void *ptr STG_UNUSED,
 214                   size_t size STG_UNUSED)
 215 {
 216     /* easy for us: the garbage collector does the dealloc'n */
 217 }