divide packages into "core" and "extra" packages
[ghc-hetmet.git] / rts / MBlock.c
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team 1998-1999
4  *
5  * MegaBlock Allocator Interface.  This file contains all the dirty
6  * architecture-dependent hackery required to get a chunk of aligned
7  * memory from the operating system.
8  *
9  * ---------------------------------------------------------------------------*/
10
11 /* This is non-posix compliant. */
12 /* #include "PosixSource.h" */
13
14 #include "Rts.h"
15 #include "RtsUtils.h"
16 #include "RtsFlags.h"
17 #include "MBlock.h"
18 #include "BlockAlloc.h"
19 #include "Trace.h"
20
21 #ifdef HAVE_STDLIB_H
22 #include <stdlib.h>
23 #endif
24 #ifdef HAVE_STRING_H
25 #include <string.h>
26 #endif
27 #ifdef HAVE_UNISTD_H
28 #include <unistd.h>
29 #endif
30 #ifdef HAVE_SYS_TYPES_H
31 #include <sys/types.h>
32 #endif
33 #ifndef mingw32_HOST_OS
34 # ifdef HAVE_SYS_MMAN_H
35 # include <sys/mman.h>
36 # endif
37 #endif
38 #ifdef HAVE_FCNTL_H
39 #include <fcntl.h>
40 #endif
41 #if HAVE_WINDOWS_H
42 #include <windows.h>
43 #endif
44 #if darwin_HOST_OS
45 #include <mach/vm_map.h>
46 #endif
47
48 #include <errno.h>
49
50 lnat mblocks_allocated = 0;
51
52 /* -----------------------------------------------------------------------------
53    The MBlock Map: provides our implementation of HEAP_ALLOCED()
54    -------------------------------------------------------------------------- */
55
56 #if SIZEOF_VOID_P == 4
57 StgWord8 mblock_map[MBLOCK_MAP_SIZE]; // initially all zeros
58 #elif SIZEOF_VOID_P == 8
59 static MBlockMap dummy_mblock_map;
60 MBlockMap *mblock_cache = &dummy_mblock_map;
61 int mblock_map_count = 0;
62 MBlockMap **mblock_maps = NULL;
63
64 static MBlockMap *
65 findMBlockMap(void *p)
66 {
67     int i;
68     StgWord32 hi = (StgWord32) (((StgWord)p) >> 32);
69     for( i = 0; i < mblock_map_count; i++ )
70     {
71         if(mblock_maps[i]->addrHigh32 == hi)
72         {
73             return mblock_maps[i];
74         }
75     }
76     return NULL;
77 }
78
79 StgBool
80 slowIsHeapAlloced(void *p)
81 {
82     MBlockMap *map = findMBlockMap(p);
83     if(map)
84     {
85         mblock_cache = map;
86         return map->mblocks[MBLOCK_MAP_ENTRY(p)];
87     }
88     else
89         return 0;
90 }
91 #endif
92
93 static void
94 markHeapAlloced(void *p)
95 {
96 #if SIZEOF_VOID_P == 4
97     mblock_map[MBLOCK_MAP_ENTRY(p)] = 1;
98 #elif SIZEOF_VOID_P == 8
99     MBlockMap *map = findMBlockMap(p);
100     if(map == NULL)
101     {
102         mblock_map_count++;
103         mblock_maps = realloc(mblock_maps,
104                               sizeof(MBlockMap*) * mblock_map_count);
105         map = mblock_maps[mblock_map_count-1] = calloc(1,sizeof(MBlockMap));
106         map->addrHigh32 = (StgWord32) (((StgWord)p) >> 32);
107     }
108     map->mblocks[MBLOCK_MAP_ENTRY(p)] = 1;
109     mblock_cache = map;
110 #endif
111 }
112
113 /* -----------------------------------------------------------------------------
114    Allocate new mblock(s)
115    -------------------------------------------------------------------------- */
116
117 void *
118 getMBlock(void)
119 {
120   return getMBlocks(1);
121 }
122
123 /* -----------------------------------------------------------------------------
124    The mmap() method
125
126    On Unix-like systems, we use mmap() to allocate our memory.  We
127    want memory in chunks of MBLOCK_SIZE, and aligned on an MBLOCK_SIZE
128    boundary.  The mmap() interface doesn't give us this level of
129    control, so we have to use some heuristics.
130
131    In the general case, if we want a block of n megablocks, then we
132    allocate n+1 and trim off the slop from either side (using
133    munmap()) to get an aligned chunk of size n.  However, the next
134    time we'll try to allocate directly after the previously allocated
135    chunk, on the grounds that this is aligned and likely to be free.
136    If it turns out that we were wrong, we have to munmap() and try
137    again using the general method.
138
139    Note on posix_memalign(): this interface is available on recent
140    systems and appears to provide exactly what we want.  However, it
141    turns out not to be as good as our mmap() implementation, because
142    it wastes extra space (using double the address space, in a test on
143    x86_64/Linux).  The problem seems to be that posix_memalign()
144    returns memory that can be free()'d, so the library must store
145    extra information along with the allocated block, thus messing up
146    the alignment.  Hence, we don't use posix_memalign() for now.
147
148    -------------------------------------------------------------------------- */
149
150 #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS)
151
152 // A wrapper around mmap(), to abstract away from OS differences in
153 // the mmap() interface.
154
155 static void *
156 my_mmap (void *addr, lnat size)
157 {
158     void *ret;
159
160 #if defined(solaris2_HOST_OS) || defined(irix_HOST_OS)
161     { 
162         int fd = open("/dev/zero",O_RDONLY);
163         ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0);
164         close(fd);
165     }
166 #elif hpux_HOST_OS
167     ret = mmap(addr, size, PROT_READ | PROT_WRITE, 
168                MAP_ANONYMOUS | MAP_PRIVATE, -1, 0);
169 #elif darwin_HOST_OS
170     // Without MAP_FIXED, Apple's mmap ignores addr.
171     // With MAP_FIXED, it overwrites already mapped regions, whic
172     // mmap(0, ... MAP_FIXED ...) is worst of all: It unmaps the program text
173     // and replaces it with zeroes, causing instant death.
174     // This behaviour seems to be conformant with IEEE Std 1003.1-2001.
175     // Let's just use the underlying Mach Microkernel calls directly,
176     // they're much nicer.
177     
178     kern_return_t err;
179     ret = addr;
180     if(addr)    // try to allocate at adress
181         err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, FALSE);
182     if(!addr || err)    // try to allocate anywhere
183         err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, TRUE);
184         
185     if(err) {
186         // don't know what the error codes mean exactly, assume it's
187         // not our problem though.
188         errorBelch("memory allocation failed (requested %lu bytes)", size);
189         stg_exit(EXIT_FAILURE);
190     } else {
191         vm_protect(mach_task_self(),ret,size,FALSE,VM_PROT_READ|VM_PROT_WRITE);
192     }
193 #else
194     ret = mmap(addr, size, PROT_READ | PROT_WRITE | PROT_EXEC, 
195                MAP_ANON | MAP_PRIVATE, -1, 0);
196 #endif
197
198     if (ret == (void *)-1) {
199         if (errno == ENOMEM || 
200             (errno == EINVAL && sizeof(void*)==4 && size >= 0xc0000000)) {
201             // If we request more than 3Gig, then we get EINVAL
202             // instead of ENOMEM (at least on Linux).
203             errorBelch("out of memory (requested %lu bytes)", size);
204             stg_exit(EXIT_FAILURE);
205         } else {
206             barf("getMBlock: mmap: %s", strerror(errno));
207         }
208     }
209
210     return ret;
211 }
212
213 // Implements the general case: allocate a chunk of memory of 'size'
214 // mblocks.
215
216 static void *
217 gen_map_mblocks (lnat size)
218 {
219     int slop;
220     void *ret;
221
222     // Try to map a larger block, and take the aligned portion from
223     // it (unmap the rest).
224     size += MBLOCK_SIZE;
225     ret = my_mmap(0, size);
226     
227     // unmap the slop bits around the chunk we allocated
228     slop = (W_)ret & MBLOCK_MASK;
229     
230     if (munmap(ret, MBLOCK_SIZE - slop) == -1) {
231       barf("gen_map_mblocks: munmap failed");
232     }
233     if (slop > 0 && munmap(ret+size-slop, slop) == -1) {
234       barf("gen_map_mblocks: munmap failed");
235     }
236
237     // ToDo: if we happened to get an aligned block, then don't
238     // unmap the excess, just use it. For this to work, you
239     // need to keep in mind the following:
240     //     * Calling my_mmap() with an 'addr' arg pointing to
241     //       already my_mmap()ed space is OK and won't fail.
242     //     * If my_mmap() can't satisfy the request at the
243     //       given 'next_request' address in getMBlocks(), that
244     //       you unmap the extra mblock mmap()ed here (or simply
245     //       satisfy yourself that the slop introduced isn't worth
246     //       salvaging.)
247     // 
248
249     // next time, try after the block we just got.
250     ret += MBLOCK_SIZE - slop;
251     return ret;
252 }
253
254
255 // The external interface: allocate 'n' mblocks, and return the
256 // address.
257
258 void *
259 getMBlocks(nat n)
260 {
261   static caddr_t next_request = (caddr_t)HEAP_BASE;
262   caddr_t ret;
263   lnat size = MBLOCK_SIZE * n;
264   nat i;
265  
266   if (next_request == 0) {
267       // use gen_map_mblocks the first time.
268       ret = gen_map_mblocks(size);
269   } else {
270       ret = my_mmap(next_request, size);
271
272       if (((W_)ret & MBLOCK_MASK) != 0) {
273           // misaligned block!
274 #if 0 // defined(DEBUG)
275           errorBelch("warning: getMBlock: misaligned block %p returned when allocating %d megablock(s) at %p", ret, n, next_request);
276 #endif
277
278           // unmap this block...
279           if (munmap(ret, size) == -1) {
280               barf("getMBlock: munmap failed");
281           }
282           // and do it the hard way
283           ret = gen_map_mblocks(size);
284       }
285   }
286
287   // Next time, we'll try to allocate right after the block we just got.
288   // ToDo: check that we haven't already grabbed the memory at next_request
289   next_request = ret + size;
290
291   debugTrace(DEBUG_gc, "allocated %d megablock(s) at %p",n,ret);
292
293   // fill in the table
294   for (i = 0; i < n; i++) {
295       markHeapAlloced( ret + i * MBLOCK_SIZE );
296   }
297
298   mblocks_allocated += n;
299
300   return ret;
301 }
302
303 void
304 freeAllMBlocks(void)
305 {
306   /* XXX Do something here */
307 }
308
309 #else /* defined(mingw32_HOST_OS) || defined(cygwin32_HOST_OS) */
310
311 /* alloc_rec keeps the info we need to have matching VirtualAlloc and
312    VirtualFree calls.
313 */
314 typedef struct alloc_rec_ {
315     char* base;     /* non-aligned base address, directly from VirtualAlloc */
316     int size;       /* Size in bytes */
317     struct alloc_rec_* next;
318 } alloc_rec;
319
320 typedef struct block_rec_ {
321     char* base;         /* base address, non-MBLOCK-aligned */
322     int size;           /* size in bytes */
323     struct block_rec_* next;
324 } block_rec;
325
326 static alloc_rec* allocs = 0;
327 static block_rec* free_blocks = 0;
328
329 static
330 alloc_rec*
331 allocNew(nat n) {
332     alloc_rec* rec;
333     rec = (alloc_rec*)stgMallocBytes(sizeof(alloc_rec),"getMBlocks: allocNew");
334     rec->size = (n+1)*MBLOCK_SIZE;
335     rec->base = 
336         VirtualAlloc(NULL, rec->size, MEM_RESERVE, PAGE_READWRITE);
337     if(rec->base==0) {
338         stgFree((void*)rec);
339         rec=0;
340         errorBelch(
341             "getMBlocks: VirtualAlloc MEM_RESERVE %d blocks failed with: %ld\n"
342             , n, GetLastError());
343     } else {
344         if(allocs==0) {
345             allocs=rec;
346             rec->next=0;
347         } else {
348             alloc_rec* it;
349             it=allocs;
350             for(; it->next!=0 && it->next->base<rec->base; it=it->next) ;
351             rec->next=it->next;
352             it->next=rec;
353         }
354         debugTrace(DEBUG_gc, "allocated %d megablock(s) at 0x%x",n,(nat)rec->base);
355     }
356     return rec;
357 }
358
359 static
360 void
361 insertFree(char* alloc_base, int alloc_size) {
362     block_rec temp;
363     block_rec* it;
364     block_rec* prev;
365
366     temp.base=0; temp.size=0; temp.next=free_blocks;
367     it = free_blocks;
368     prev = &temp;
369     for( ; it!=0 && it->base<alloc_base; prev=it, it=it->next) {}
370
371     if(it!=0 && alloc_base+alloc_size == it->base) {
372         if(prev->base + prev->size == alloc_base) {        /* Merge it, alloc, prev */
373             prev->size += alloc_size + it->size;
374             prev->next = it->next;
375             stgFree(it);
376         } else {                                            /* Merge it, alloc */
377             it->base = alloc_base;
378             it->size += alloc_size;
379         }
380     } else if(prev->base + prev->size == alloc_base) {     /* Merge alloc, prev */
381         prev->size += alloc_size;
382     } else {                                                /* Merge none */
383         block_rec* rec;
384         rec = (block_rec*)stgMallocBytes(sizeof(block_rec),"getMBlocks: insertFree");
385         rec->base=alloc_base;
386         rec->size=alloc_size;
387         rec->next = it;
388         prev->next=rec;
389     }
390     free_blocks=temp.next;
391 }
392
393 static
394 void*
395 findFreeBlocks(nat n) {
396     void* ret=0;
397     block_rec* it;
398     block_rec temp;
399     block_rec* prev;
400
401     int required_size;
402     it=free_blocks;
403     required_size = n*MBLOCK_SIZE;
404     temp.next=free_blocks; temp.base=0; temp.size=0;
405     prev=&temp;
406     /* TODO: Don't just take first block, find smallest sufficient block */
407     for( ; it!=0 && it->size<required_size; prev=it, it=it->next ) {}
408     if(it!=0) {
409         if( (((unsigned long)it->base) & MBLOCK_MASK) == 0) { /* MBlock aligned */
410             ret = (void*)it->base;
411             if(it->size==required_size) {
412                 prev->next=0;
413                 stgFree(it);
414             } else {
415                 it->base += required_size;
416                 it->size -=required_size;
417             }
418         } else {
419             char* need_base;
420             block_rec* next;
421             int new_size;
422             need_base = (char*)(((unsigned long)it->base) & ((unsigned long)~MBLOCK_MASK)) + MBLOCK_SIZE;
423             next = (block_rec*)stgMallocBytes(
424                     sizeof(block_rec)
425                     , "getMBlocks: findFreeBlocks: splitting");
426             new_size = need_base - it->base;
427             next->base = need_base +required_size;
428             next->size = it->size - (new_size+required_size);
429             it->size = new_size;
430             next->next = it->next;
431             it->next = next;
432             ret=(void*)need_base;
433         }
434     }
435     free_blocks=temp.next;
436     return ret;
437 }
438
439 /* VirtualAlloc MEM_COMMIT can't cross boundaries of VirtualAlloc MEM_RESERVE,
440    so we might need to do many VirtualAlloc MEM_COMMITs.  We simply walk the
441    (ordered) allocated blocks. */
442 static void
443 commitBlocks(char* base, int size) {
444     alloc_rec* it;
445     it=allocs;
446     for( ; it!=0 && (it->base+it->size)<base; it=it->next ) {}
447     for( ; it!=0 && size>0; it=it->next ) {
448         int size_delta;
449         void* temp;
450         size_delta = it->size - (base-it->base);
451         if(size_delta>size) size_delta=size;
452         temp = VirtualAlloc(base, size_delta, MEM_COMMIT, PAGE_READWRITE);
453         if(temp==0)
454             debugBelch("getMBlocks: VirtualAlloc MEM_COMMIT failed: %ld", GetLastError());
455         size-=size_delta;
456         base+=size_delta;
457     }
458 }
459
460 void *
461 getMBlocks(nat n) {
462     void* ret;
463     ret = findFreeBlocks(n);
464     if(ret==0) {
465         alloc_rec* alloc;
466         alloc = allocNew(n);
467         /* We already belch in allocNew if it fails */
468         if(alloc!=0) {
469             insertFree(alloc->base, alloc->size);
470             ret = findFreeBlocks(n);
471         }
472     }
473
474     if(ret!=0) {
475         /* (In)sanity tests */
476         if (((W_)ret & MBLOCK_MASK) != 0) {
477             barf("getMBlocks: misaligned block returned");
478         }
479
480         commitBlocks(ret, MBLOCK_SIZE*n);
481
482         /* Global bookkeeping */
483         mblocks_allocated += n;
484         int i;
485         for(i=0; i<(int)n; ++i) {
486             markHeapAlloced( ret + i * MBLOCK_SIZE );
487         }
488     }
489
490     return ret;
491 }
492
493 void
494 freeAllMBlocks(void)
495 {
496     {
497         block_rec* next;
498         block_rec* it;
499         next=0;
500         it = free_blocks;
501         for(; it!=0; ) {
502             next = it->next;
503             stgFree(it);
504             it=next;
505         }
506     }
507     {
508         alloc_rec* next;
509         alloc_rec* it;
510         next=0;
511         it=allocs;
512         for(; it!=0; ) {
513             if(!VirtualFree((void*)it->base, 0, MEM_RELEASE)) {
514                 debugBelch("freeAllMBlocks: VirtualFree MEM_RELEASE failed with %ld", GetLastError());
515             }
516             next = it->next;
517             stgFree(it);
518             it=next;
519         }
520     }
521 }
522
523 #endif