← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/alloc.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/alloc.d
 
1
 
 
2
/*
 
3
    alloc.c --  Memory allocation.
 
4
*/
 
5
/*
 
6
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
7
    Copyright (c) 1990, Giuseppe Attardi.
 
8
    Copyright (c) 2001, Juan Jose Garcia Ripoll.
 
9
 
 
10
    ECL is free software; you can redistribute it and/or
 
11
    modify it under the terms of the GNU Library General Public
 
12
    License as published by the Free Software Foundation; either
 
13
    version 2 of the License, or (at your option) any later version.
 
14
 
 
15
    See file '../Copyright' for full details.
 
16
*/
 
17
 
 
18
 
 
19
/*
 
20
                        Heap and Relocatable Area
 
21
 
 
22
                         heap_end    data_end
 
23
    +------+--------------------+ - - - + - - --------+
 
24
    | text |        heap        | hole  |      stack  |
 
25
    +------+--------------------+ - - - + - - --------+
 
26
 
 
27
   The type_map array covers all pages of memory: those not used for objects
 
28
   are marked as type t_other.
 
29
 
 
30
   The tm_table array holds a struct typemanager for each type, which contains
 
31
   the first element of the free list for the type, and other bookkeeping
 
32
   information.
 
33
*/
 
34
 
 
35
#include <unistd.h>
 
36
#include <string.h>
 
37
#include <ecl/ecl.h>
 
38
#include <ecl/internal.h>
 
39
#include <ecl/page.h>
 
40
 
 
41
#define USE_MMAP
 
42
#if defined(USE_MMAP)
 
43
#include <sys/types.h>
 
44
#include <sys/mman.h>
 
45
#elif defined(HAVE_ULIMIT_H)
 
46
#include <ulimit.h>
 
47
#else
 
48
#include <sys/resource.h>
 
49
#endif
 
50
 
 
51
/******************************* EXPORTS ******************************/
 
52
 
 
53
cl_index real_maxpage;
 
54
cl_index new_holepage;
 
55
char type_map[MAXPAGE];
 
56
struct typemanager tm_table[(int)t_end];
 
57
struct contblock *cb_pointer = NULL;
 
58
 
 
59
cl_index ncb;                   /*  number of contblocks  */
 
60
cl_index ncbpage;               /*  number of contblock pages  */
 
61
cl_index maxcbpage;             /*  maximum number of contblock pages  */
 
62
cl_index cbgccount;             /*  contblock gc count  */
 
63
cl_index holepage;              /*  hole pages  */
 
64
 
 
65
cl_ptr heap_end;                /*  heap end  */
 
66
cl_ptr heap_start;              /*  heap start  */
 
67
cl_ptr data_end;                /*  end of data space  */
 
68
 
 
69
/******************************* ------- ******************************/
 
70
 
 
71
static bool ignore_maximum_pages = TRUE;
 
72
 
 
73
#ifdef NEED_MALLOC
 
74
static cl_object malloc_list;
 
75
#endif
 
76
 
 
77
/*
 
78
   Ensure that the hole is at least "n" pages large. If it is not,
 
79
   allocate space from the operating system.
 
80
*/
 
81
 
 
82
#if defined(USE_MMAP)
 
83
void
 
84
cl_resize_hole(cl_index n)
 
85
{
 
86
#define PAGESIZE 8192
 
87
        cl_index m, bytes;
 
88
        cl_ptr result, last_addr;
 
89
        bytes = n * LISP_PAGESIZE;
 
90
        bytes = (bytes + PAGESIZE-1) / PAGESIZE;
 
91
        bytes = bytes * PAGESIZE;
 
92
        if (heap_start == NULL) {
 
93
                /* First time use. We allocate the memory and keep the first
 
94
                 * address in heap_start.
 
95
                 */
 
96
                result = mmap(0x2E000000, bytes, PROT_READ | PROT_WRITE,
 
97
                              MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1 ,0);
 
98
                if (result == MAP_FAILED)
 
99
                        error("Cannot allocate memory. Good-bye!");
 
100
                data_end = heap_end = heap_start = result;
 
101
                last_addr = heap_start + bytes;
 
102
                holepage = n;
 
103
        } else {
 
104
                /* Next time use. We extend the region of memory that we had
 
105
                 * mapped before.
 
106
                 */
 
107
                m = (data_end - heap_end)/LISP_PAGESIZE;
 
108
                if (n <= m)
 
109
                        return;
 
110
                result = mmap(data_end, bytes, PROT_READ | PROT_WRITE,
 
111
                              MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1, 0);
 
112
                if (result == MAP_FAILED)
 
113
                        error("Cannot resize memory pool. Good-bye!");
 
114
                last_addr = result + bytes;
 
115
                if (result != data_end) {
 
116
                        cl_dealloc(heap_end, data_end - heap_end);
 
117
                        while (heap_end < result) {
 
118
                                cl_index p = page(heap_end);
 
119
                                if (p > real_maxpage)
 
120
                                        error("Memory limit exceeded.");
 
121
                                type_map[p] = t_other;
 
122
                                heap_end += LISP_PAGESIZE;
 
123
                        }
 
124
                }
 
125
                holepage = (last_addr - heap_end) / LISP_PAGESIZE;
 
126
        }
 
127
        while (data_end < last_addr) {
 
128
                type_map[page(data_end)] = t_other;
 
129
                data_end += LISP_PAGESIZE;
 
130
        }
 
131
}
 
132
#else
 
133
void
 
134
cl_resize_hole(cl_index n)
 
135
{
 
136
        cl_ptr e;
 
137
        cl_index m;
 
138
        m = (data_end - heap_end)/LISP_PAGESIZE;
 
139
        if (n <= m)
 
140
                return;
 
141
 
 
142
        /* Create the hole */
 
143
        e = sbrk(0);
 
144
        if (data_end == e) {
 
145
                e = sbrk((n -= m) * LISP_PAGESIZE);
 
146
        } else {
 
147
                cl_dealloc(heap_end, data_end - heap_end);
 
148
                /* FIXME! Horrible hack! */
 
149
                /* mark as t_other pages not allocated by us */
 
150
                heap_end = e;
 
151
                while (data_end < heap_end) {
 
152
                        type_map[page(data_end)] = t_other;
 
153
                        data_end += LISP_PAGESIZE;
 
154
                }
 
155
                holepage = 0;
 
156
                e = sbrk(n * LISP_PAGESIZE + (data_end - e));
 
157
        }
 
158
        if ((cl_fixnum)e < 0)
 
159
                error("Can't allocate.  Good-bye!");
 
160
        data_end = e;
 
161
        holepage += n;
 
162
}
 
163
#endif
 
164
 
 
165
/* Allocates n pages from the hole.  */
 
166
static void *
 
167
alloc_page(cl_index n)
 
168
{
 
169
        cl_ptr e = heap_end;
 
170
        if (n >= holepage) {
 
171
                ecl_gc(t_contiguous);
 
172
                cl_resize_hole(new_holepage+n);
 
173
        }
 
174
        holepage -= n;
 
175
        heap_end += LISP_PAGESIZE*n;
 
176
        return e;
 
177
}
 
178
 
 
179
/*
 
180
 * We have to mark all objects within the page as FREE. However, at
 
181
 * the end of the page there might be extra bytes, which have to be
 
182
 * tagged as useless. Since these bytes are at least 4, x->m points to
 
183
 * data within the page and we can mark this object setting x->m=FREE.
 
184
 */
 
185
static void
 
186
add_page_to_freelist(cl_ptr p, struct typemanager *tm)
 
187
{
 
188
        cl_type t;
 
189
        cl_object x, f;
 
190
        cl_index i;
 
191
        t = tm->tm_type;
 
192
        type_map[page(p)] = t;
 
193
        f = tm->tm_free;
 
194
        for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) {
 
195
                x = (cl_object)p;
 
196
                ((struct freelist *)x)->t = (short)t;
 
197
                ((struct freelist *)x)->m = FREE;
 
198
                ((struct freelist *)x)->f_link = f;
 
199
                f = x;
 
200
        }
 
201
        /* Mark the extra bytes which cannot be used. */
 
202
        if (tm->tm_size * tm->tm_nppage < LISP_PAGESIZE) {
 
203
                x = (cl_object)p;
 
204
                x->d.m = FREE;
 
205
        }
 
206
        tm->tm_free = f;
 
207
        tm->tm_nfree += tm->tm_nppage;
 
208
        tm->tm_npage++;
 
209
}
 
210
 
 
211
cl_object
 
212
cl_alloc_object(cl_type t)
 
213
{
 
214
        register cl_object obj;
 
215
        register struct typemanager *tm;
 
216
        register cl_ptr p;
 
217
 
 
218
        switch (t) {
 
219
        case t_fixnum:
 
220
          return MAKE_FIXNUM(0); /* Immediate fixnum */
 
221
        case t_character:
 
222
          return CODE_CHAR('\0'); /* Immediate character */
 
223
        default:;
 
224
        }
 
225
 
 
226
        start_critical_section();
 
227
        tm = tm_of(t);
 
228
ONCE_MORE:
 
229
        obj = tm->tm_free;
 
230
        if (obj == OBJNULL) {
 
231
                cl_index available = available_pages();
 
232
                if (tm->tm_npage >= tm->tm_maxpage)
 
233
                        goto CALL_GC;
 
234
                if (available < 1) {
 
235
                        ignore_maximum_pages = FALSE;
 
236
                        goto CALL_GC;
 
237
                }
 
238
                p = alloc_page(1);
 
239
                add_page_to_freelist(p, tm);
 
240
                obj = tm->tm_free;
 
241
                /* why this? Beppe
 
242
                if (tm->tm_npage >= tm->tm_maxpage)
 
243
                        goto CALL_GC; */
 
244
        }
 
245
        tm->tm_free = ((struct freelist *)obj)->f_link;
 
246
        --(tm->tm_nfree);
 
247
        (tm->tm_nused)++;
 
248
        obj->d.t = (short)t;
 
249
        obj->d.m = FALSE;
 
250
        /* Now initialize the object so that it can be correctly marked
 
251
         * by the GC
 
252
         */
 
253
        switch (t) {
 
254
        case t_bignum:
 
255
          obj->big.big_dim = obj->big.big_size = 0;
 
256
          obj->big.big_limbs = NULL;
 
257
          break;
 
258
        case t_ratio:
 
259
          obj->ratio.num = OBJNULL;
 
260
          obj->ratio.den = OBJNULL;
 
261
          break;
 
262
        case t_shortfloat:
 
263
        case t_longfloat:
 
264
          break;
 
265
        case t_complex:
 
266
          obj->complex.imag = OBJNULL;
 
267
          obj->complex.real = OBJNULL;
 
268
          break;
 
269
        case t_symbol:
 
270
          obj->symbol.plist = OBJNULL;
 
271
          obj->symbol.gfdef = OBJNULL;
 
272
          obj->symbol.value = OBJNULL;
 
273
          obj->symbol.name = OBJNULL;
 
274
          obj->symbol.hpack = OBJNULL;
 
275
          break;
 
276
        case t_package:
 
277
          obj->pack.name = OBJNULL;
 
278
          obj->pack.nicknames = OBJNULL;
 
279
          obj->pack.shadowings = OBJNULL;
 
280
          obj->pack.uses = OBJNULL;
 
281
          obj->pack.usedby = OBJNULL;
 
282
          obj->pack.internal = OBJNULL;
 
283
          obj->pack.external = OBJNULL;
 
284
          break;
 
285
        case t_cons:
 
286
          CAR(obj) = OBJNULL;
 
287
          CDR(obj) = OBJNULL;
 
288
          break;
 
289
        case t_hashtable:
 
290
          obj->hash.rehash_size = OBJNULL;
 
291
          obj->hash.threshold = OBJNULL;
 
292
          obj->hash.data = NULL;
 
293
          break;
 
294
        case t_array:
 
295
          obj->array.dims = NULL;
 
296
          obj->array.displaced = Cnil;
 
297
          obj->array.elttype = (short)aet_object;
 
298
          obj->array.self.t = NULL;
 
299
          break;
 
300
        case t_vector:
 
301
          obj->array.displaced = Cnil;
 
302
          obj->array.elttype = (short)aet_object;
 
303
          obj->array.self.t = NULL;
 
304
          break;
 
305
        case t_string:
 
306
          obj->string.displaced = Cnil;
 
307
          obj->string.self = NULL;
 
308
          break;
 
309
        case t_bitvector:
 
310
          obj->vector.displaced = Cnil;
 
311
          obj->vector.self.bit = NULL;
 
312
          break;
 
313
#ifndef CLOS
 
314
        case t_structure:
 
315
          obj->str.name = OBJNULL;
 
316
          obj->str.self = NULL;
 
317
          break;
 
318
#endif /* CLOS */
 
319
        case t_stream:
 
320
          obj->stream.mode = (short)smm_broadcast;
 
321
          obj->stream.file = NULL;
 
322
          obj->stream.object0 = OBJNULL;
 
323
          obj->stream.object1 = OBJNULL;
 
324
          obj->stream.buffer = NULL;
 
325
          break;
 
326
        case t_random:
 
327
          break;
 
328
        case t_readtable:
 
329
          obj->readtable.table = NULL;
 
330
          break;
 
331
        case t_pathname:
 
332
          obj->pathname.host = OBJNULL;
 
333
          obj->pathname.device = OBJNULL;
 
334
          obj->pathname.directory = OBJNULL;
 
335
          obj->pathname.name = OBJNULL;
 
336
          obj->pathname.type = OBJNULL;
 
337
          obj->pathname.version = OBJNULL;
 
338
          break;
 
339
        case t_bytecodes:
 
340
          obj->bytecodes.lex = Cnil;
 
341
          obj->bytecodes.name = Cnil;
 
342
          obj->bytecodes.definition = Cnil;
 
343
          obj->bytecodes.specials = Cnil;
 
344
          obj->bytecodes.code_size = 0;
 
345
          obj->bytecodes.code = NULL;
 
346
          obj->bytecodes.data_size = 0;
 
347
          obj->bytecodes.data = NULL;
 
348
          break;
 
349
        case t_cfun:
 
350
          obj->cfun.name = OBJNULL;
 
351
          obj->cfun.block = NULL;
 
352
          break;
 
353
        case t_cclosure:
 
354
          obj->cclosure.env = OBJNULL;
 
355
          obj->cclosure.block = NULL;
 
356
          break;
 
357
/*
 
358
        case t_spice:
 
359
          break;
 
360
*/
 
361
#ifdef ECL_THREADS
 
362
        case t_process:
 
363
          obj->process.name = OBJNULL;
 
364
          obj->process.function = OBJNULL;
 
365
          obj->process.args = OBJNULL;
 
366
          obj->process.env = NULL;
 
367
          obj->process.interrupt = OBJNULL;
 
368
          break;
 
369
        case t_lock:
 
370
          obj->lock.mutex = OBJNULL;
 
371
          break;
 
372
#endif
 
373
#ifdef CLOS
 
374
        case t_instance:
 
375
          obj->instance.length = 0;
 
376
          CLASS_OF(obj) = OBJNULL;
 
377
          obj->instance.sig = Cnil;
 
378
          obj->instance.isgf = 0;
 
379
          obj->instance.slots = NULL;
 
380
          break;
 
381
#endif /* CLOS */
 
382
        case t_codeblock:
 
383
          obj->cblock.locked = 0;
 
384
          obj->cblock.name = Cnil;
 
385
          obj->cblock.handle = NULL;
 
386
          obj->cblock.entry = NULL;
 
387
          obj->cblock.data = NULL;
 
388
          obj->cblock.data_size = 0;
 
389
          obj->cblock.data_text = NULL;
 
390
          obj->cblock.data_text_size = 0;
 
391
          obj->cblock.links = Cnil;
 
392
          obj->cblock.next = Cnil;
 
393
          break;
 
394
        case t_foreign:
 
395
          obj->foreign.tag = Cnil;
 
396
          obj->foreign.size = 0;
 
397
          obj->foreign.data = NULL;
 
398
          break;
 
399
        default:
 
400
          printf("\ttype = %d\n", t);
 
401
          error("alloc botch.");
 
402
        }
 
403
        end_critical_section();
 
404
        return(obj);
 
405
CALL_GC:
 
406
        ecl_gc(tm->tm_type);
 
407
        if (tm->tm_nfree != 0 &&
 
408
                (float)tm->tm_nfree * 10.0 >= (float)tm->tm_nused)
 
409
                goto ONCE_MORE;
 
410
 
 
411
/*      EXHAUSTED:      */
 
412
        if (ignore_maximum_pages) {
 
413
                if (tm->tm_maxpage/2 <= 0)
 
414
                        tm->tm_maxpage += 1;
 
415
                else
 
416
                        tm->tm_maxpage += tm->tm_maxpage/2;
 
417
                goto ONCE_MORE;
 
418
        }
 
419
        GC_disable();
 
420
        { cl_object s = make_simple_string(tm_table[(int)t].tm_name+1);
 
421
        GC_enable();
 
422
        CEerror("The storage for ~A is exhausted.~%\
 
423
Currently, ~D pages are allocated.~%\
 
424
Use ALLOCATE to expand the space.",
 
425
                2, s, MAKE_FIXNUM(tm->tm_npage));
 
426
        }
 
427
        goto ONCE_MORE;
 
428
}
 
429
 
 
430
cl_object
 
431
make_cons(cl_object a, cl_object d)
 
432
{
 
433
        register cl_object obj;
 
434
        register cl_ptr p;
 
435
        struct typemanager *tm=(&tm_table[(int)t_cons]);
 
436
 
 
437
        start_critical_section(); 
 
438
 
 
439
ONCE_MORE:
 
440
        obj = tm->tm_free;
 
441
        if (obj == OBJNULL) {
 
442
                if (tm->tm_npage >= tm->tm_maxpage)
 
443
                        goto CALL_GC;
 
444
                if (available_pages() < 1) {
 
445
                        ignore_maximum_pages = FALSE;
 
446
                        goto CALL_GC;
 
447
                }
 
448
                p = alloc_page(1);
 
449
                add_page_to_freelist(p,tm);
 
450
                obj = tm->tm_free;
 
451
                if (tm->tm_npage >= tm->tm_maxpage)
 
452
                        goto CALL_GC;
 
453
        }
 
454
        tm->tm_free = ((struct freelist *)obj)->f_link;
 
455
        --(tm->tm_nfree);
 
456
        (tm->tm_nused)++;
 
457
        obj->d.t = (short)t_cons;
 
458
        obj->d.m = FALSE;
 
459
        CAR(obj) = a;
 
460
        CDR(obj) = d;
 
461
 
 
462
        end_critical_section();
 
463
        return(obj);
 
464
 
 
465
CALL_GC:
 
466
        ecl_gc(t_cons);
 
467
        if ((tm->tm_nfree != 0) && (tm->tm_nfree * 10.0 >= tm->tm_nused))
 
468
                goto ONCE_MORE;
 
469
 
 
470
/*      EXHAUSTED:      */
 
471
        if (ignore_maximum_pages) {
 
472
                if (tm->tm_maxpage/2 <= 0)
 
473
                        tm->tm_maxpage += 1;
 
474
                else
 
475
                        tm->tm_maxpage += tm->tm_maxpage/2;
 
476
                goto ONCE_MORE;
 
477
        }
 
478
        CEerror("The storage for CONS is exhausted.~%\
 
479
Currently, ~D pages are allocated.~%\
 
480
Use ALLOCATE to expand the space.",
 
481
                1, MAKE_FIXNUM(tm->tm_npage));
 
482
        goto ONCE_MORE;
 
483
#undef  tm
 
484
}
 
485
 
 
486
cl_object
 
487
cl_alloc_instance(cl_index slots)
 
488
{
 
489
        cl_object i = cl_alloc_object(t_instance);
 
490
        if (slots >= ECL_SLOTS_LIMIT)
 
491
                FEerror("Limit on instance size exceeded: ~S slots requested.",
 
492
                        1, MAKE_FIXNUM(slots));
 
493
        /* INV: slots > 0 */
 
494
        i->instance.slots = (cl_object*)cl_alloc(sizeof(cl_object) * slots);
 
495
        i->instance.length = slots;
 
496
        return i;
 
497
}
 
498
 
 
499
void *
 
500
cl_alloc(cl_index n)
 
501
{
 
502
        volatile cl_ptr p;
 
503
        struct contblock **cbpp;
 
504
        cl_index i, m;
 
505
        bool g;
 
506
 
 
507
        g = FALSE;
 
508
        n = round_up(n);
 
509
 
 
510
        start_critical_section(); 
 
511
ONCE_MORE:
 
512
        /* Use extra indirection so that cb_pointer can be updated */
 
513
        for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link) 
 
514
                if ((*cbpp)->cb_size >= n) {
 
515
                        p = (cl_ptr)(*cbpp);
 
516
                        i = (*cbpp)->cb_size - n;
 
517
                        *cbpp = (*cbpp)->cb_link;
 
518
                        --ncb;
 
519
                        cl_dealloc(p+n, i);
 
520
 
 
521
                        end_critical_section();
 
522
                        return(p);
 
523
                }
 
524
        m = round_to_page(n);
 
525
        if (ncbpage + m > maxcbpage || available_pages() < m) {
 
526
                if (available_pages() < m)
 
527
                        ignore_maximum_pages = FALSE;
 
528
                if (!g) {
 
529
                        ecl_gc(t_contiguous);
 
530
                        g = TRUE;
 
531
                        goto ONCE_MORE;
 
532
                }
 
533
                if (ignore_maximum_pages) {
 
534
                        if (maxcbpage/2 <= 0)
 
535
                                maxcbpage += 1;
 
536
                        else
 
537
                                maxcbpage += maxcbpage/2;
 
538
                        g = FALSE;
 
539
                        goto ONCE_MORE;
 
540
                }
 
541
                CEerror("Contiguous blocks exhausted.~%\
 
542
Currently, ~D pages are allocated.~%\
 
543
Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
 
544
                        1, MAKE_FIXNUM(ncbpage));
 
545
                g = FALSE;
 
546
                goto ONCE_MORE;
 
547
        }
 
548
        p = alloc_page(m);
 
549
 
 
550
        for (i = 0;  i < m;  i++)
 
551
                type_map[page(p) + i] = (char)t_contiguous;
 
552
        ncbpage += m;
 
553
        cl_dealloc(p+n, LISP_PAGESIZE*m - n);
 
554
 
 
555
        end_critical_section();
 
556
        return memset(p, 0, n);
 
557
}
 
558
 
 
559
/*
 
560
 * adds a contblock to the list of available ones, pointed by cb_pointer,
 
561
 * sorted by increasing size.
 
562
 */
 
563
void
 
564
cl_dealloc(void *p, cl_index s)
 
565
{
 
566
        struct contblock **cbpp, *cbp;
 
567
 
 
568
        if (s < CBMINSIZE)
 
569
                return;
 
570
        ncb++;
 
571
        cbp = (struct contblock *)p;
 
572
        cbp->cb_size = s;
 
573
        for (cbpp = &cb_pointer; *cbpp != NULL; cbpp = &((*cbpp)->cb_link))
 
574
                if ((*cbpp)->cb_size >= s) {
 
575
                        cbp->cb_link = *cbpp;
 
576
                        *cbpp = cbp;
 
577
                        return;
 
578
                }
 
579
        cbp->cb_link = NULL;
 
580
        *cbpp = cbp;
 
581
}
 
582
 
 
583
/*
 
584
 * align must be a power of 2 representing the alignment boundary
 
585
 * required for the block.
 
586
 */
 
587
void *
 
588
cl_alloc_align(cl_index size, cl_index align)
 
589
{
 
590
        void *output;
 
591
        start_critical_section();
 
592
        align--;
 
593
        if (align)
 
594
          output = (void*)(((cl_index)cl_alloc(size + align) + align - 1) & ~align);
 
595
        else
 
596
          output = cl_alloc(size);
 
597
        end_critical_section();
 
598
        return output;
 
599
}
 
600
 
 
601
static void
 
602
init_tm(cl_type t, const char *name, cl_index elsize, cl_index maxpage)
 
603
{
 
604
        int i, j;
 
605
        struct typemanager *tm = &tm_table[(int)t];
 
606
 
 
607
        if (elsize < 2*sizeof(cl_index)) {
 
608
                // A free list cell does not fit into this type
 
609
                elsize = 2*sizeof(cl_index);
 
610
        }
 
611
 
 
612
        tm->tm_name = name;
 
613
        for (i = (int)t_start, j = i-1;  i < (int)t_end;  i++)
 
614
          if (tm_table[i].tm_size >= elsize &&
 
615
              (j < (int)t_start || tm_table[j].tm_size > tm_table[i].tm_size))
 
616
            j = i;
 
617
        if (j >= (int)t_start) {
 
618
                tm->tm_type = (cl_type)j;
 
619
                tm_table[j].tm_maxpage += maxpage;
 
620
                return;
 
621
        }
 
622
        tm->tm_type = t;
 
623
        tm->tm_size = round_up(elsize);
 
624
        tm->tm_nppage = LISP_PAGESIZE/round_up(elsize);
 
625
        tm->tm_free = OBJNULL;
 
626
        tm->tm_nfree = 0;
 
627
        tm->tm_nused = 0;
 
628
        tm->tm_npage = 0;
 
629
        tm->tm_maxpage = maxpage;
 
630
        tm->tm_gccount = 0;
 
631
}
 
632
 
 
633
static int alloc_initialized = FALSE;
 
634
 
 
635
void
 
636
init_alloc(void)
 
637
{
 
638
        cl_index i;
 
639
 
 
640
        if (alloc_initialized) return;
 
641
        alloc_initialized = TRUE;
 
642
 
 
643
        holepage = 0;
 
644
        new_holepage = HOLEPAGE;
 
645
 
 
646
#ifdef USE_MMAP
 
647
        real_maxpage = MAXPAGE;
 
648
#elif defined(MSDOS) || defined(__CYGWIN__)
 
649
        real_maxpage = MAXPAGE;
 
650
#elif !defined(HAVE_ULIMIT_H)
 
651
        {
 
652
          struct rlimit data_rlimit;
 
653
# ifdef __MACH__
 
654
          sbrk(0);
 
655
          getrlimit(RLIMIT_DATA, &data_rlimit);
 
656
          real_maxpage = ((unsigned)get_etext() +
 
657
                          (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE;
 
658
# else
 
659
          extern etext;
 
660
 
 
661
          getrlimit(RLIMIT_DATA, &data_rlimit);
 
662
          real_maxpage = ((unsigned int)&etext +
 
663
                          (unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE;
 
664
# endif
 
665
          if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE;
 
666
        }
 
667
#else /* HAVE_ULIMIT */
 
668
        real_maxpage= ulimit(UL_GMEMLIM)/LISP_PAGESIZE;
 
669
        if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE;
 
670
#endif /* USE_MMAP, MSDOS, or HAVE_ULIMIT */
 
671
 
 
672
#ifdef USE_MMAP
 
673
        heap_start = NULL;
 
674
#else
 
675
        heap_end = sbrk(0);
 
676
        i = ((cl_index)heap_end) % LISP_PAGESIZE;
 
677
        if (i)
 
678
          sbrk(LISP_PAGESIZE - i);
 
679
        heap_end = heap_start = data_end = sbrk(0);
 
680
#endif
 
681
        cl_resize_hole(INIT_HOLEPAGE);
 
682
        for (i = 0;  i < MAXPAGE;  i++)
 
683
                type_map[i] = (char)t_other;
 
684
 
 
685
/*      Initialization must be done in increasing size order:   */
 
686
        init_tm(t_shortfloat, "FSHORT-FLOAT", /* 8 */
 
687
                sizeof(struct ecl_shortfloat), 1);
 
688
        init_tm(t_cons, ".CONS", sizeof(struct ecl_cons), 384); /* 12 */
 
689
        init_tm(t_longfloat, "LLONG-FLOAT", /* 16 */
 
690
                sizeof(struct ecl_longfloat), 1);
 
691
        init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64);
 
692
        init_tm(t_string, "\"STRING", sizeof(struct ecl_string), 64); /* 20 */
 
693
        init_tm(t_array, "aARRAY", sizeof(struct ecl_array), 64); /* 24 */
 
694
        init_tm(t_pathname, "pPATHNAME", sizeof(struct ecl_pathname), 1); /* 28 */
 
695
        init_tm(t_symbol, "|SYMBOL", sizeof(struct ecl_symbol), 64); /* 32 */
 
696
        init_tm(t_package, ":PACKAGE", sizeof(struct ecl_package), 1); /* 36 */
 
697
        init_tm(t_codeblock, "#CODEBLOCK", sizeof(struct ecl_codeblock), 1);
 
698
        init_tm(t_bignum, "BBIGNUM", sizeof(struct ecl_bignum), 16);
 
699
        init_tm(t_ratio, "RRATIO", sizeof(struct ecl_ratio), 1);
 
700
        init_tm(t_complex, "CCOMPLEX", sizeof(struct ecl_complex), 1);
 
701
        init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct ecl_hashtable), 1);
 
702
        init_tm(t_vector, "vVECTOR", sizeof(struct ecl_vector), 2);
 
703
        init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct ecl_vector), 1);
 
704
        init_tm(t_stream, "sSTREAM", sizeof(struct ecl_stream), 1);
 
705
        init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1);
 
706
        init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1);
 
707
        init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32);
 
708
        init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1);
 
709
#ifndef CLOS
 
710
        init_tm(t_structure, "SSTRUCTURE", sizeof(struct ecl_structure), 32);
 
711
#else
 
712
        init_tm(t_instance, "IINSTANCE", sizeof(struct ecl_instance), 32);
 
713
#endif /* CLOS */
 
714
        init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1);
 
715
#ifdef ECL_THREADS
 
716
        init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2);
 
717
        init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2);
 
718
#endif /* THREADS */
 
719
 
 
720
        ncb = 0;
 
721
        ncbpage = 0;
 
722
        maxcbpage = 2048;
 
723
 
 
724
#ifdef NEED_MALLOC
 
725
        malloc_list = Cnil;
 
726
        ecl_register_static_root(&malloc_list);
 
727
#endif
 
728
}
 
729
 
 
730
static int
 
731
t_from_type(cl_object type)
 
732
{  int t;
 
733
 
 
734
   type = cl_string(type);
 
735
   for (t = (int)t_start ; t < (int)t_end ; t++) {
 
736
     struct typemanager *tm = &tm_table[t];
 
737
     if (tm->tm_name &&
 
738
         strncmp((tm->tm_name)+1, type->string.self, type->string.fillp) == 0)
 
739
       return(t);
 
740
   }
 
741
   FEerror("Unrecognized type", 0);
 
742
}
 
743
 
 
744
@(defun si::allocate (type qty &optional (now Cnil))
 
745
        struct typemanager *tm;
 
746
        cl_ptr pp;
 
747
        cl_index i;
 
748
@
 
749
        tm = tm_of(t_from_type(type));
 
750
        i = fixnnint(qty);
 
751
        if (tm->tm_npage > i) i = tm->tm_npage;
 
752
        tm->tm_maxpage = i;
 
753
        if (now == Cnil || tm->tm_maxpage <= tm->tm_npage)
 
754
          @(return Ct)
 
755
        if (available_pages() < tm->tm_maxpage - tm->tm_npage ||
 
756
            (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL)
 
757
          FEerror("Can't allocate ~D pages for ~A.", 2, type,
 
758
                  make_constant_string(tm->tm_name+1));
 
759
        for (;  tm->tm_npage < tm->tm_maxpage;  pp += LISP_PAGESIZE)
 
760
          add_page_to_freelist(pp, tm);
 
761
        @(return Ct)
 
762
@)
 
763
 
 
764
@(defun si::maximum-allocatable-pages (type)
 
765
@
 
766
        @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_maxpage))
 
767
@)
 
768
 
 
769
@(defun si::allocated-pages (type)
 
770
@
 
771
        @(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_npage))
 
772
@)
 
773
 
 
774
@(defun si::allocate-contiguous-pages (qty &optional (now Cnil))
 
775
        cl_index i, m;
 
776
        cl_ptr p;
 
777
@
 
778
        i = fixnnint(qty);
 
779
        if (ncbpage > i)
 
780
          FEerror("Can't set the limit for contiguous blocks to ~D,~%\
 
781
since ~D pages are already allocated.",
 
782
                        2, qty, MAKE_FIXNUM(ncbpage));
 
783
        maxcbpage = i;
 
784
        if (Null(now))
 
785
          @(return Ct)
 
786
        m = maxcbpage - ncbpage;
 
787
        if (available_pages() < m || (p = alloc_page(m)) == NULL)
 
788
                FEerror("Can't allocate ~D pages for contiguous blocks.",
 
789
                        1, qty);
 
790
        for (i = 0;  i < m;  i++)
 
791
                type_map[page(p + LISP_PAGESIZE*i)] = (char)t_contiguous;
 
792
        ncbpage += m;
 
793
        cl_dealloc(p, LISP_PAGESIZE*m);
 
794
        @(return Ct)
 
795
@)
 
796
 
 
797
@(defun si::allocated-contiguous-pages ()
 
798
@
 
799
        @(return MAKE_FIXNUM(ncbpage))
 
800
@)
 
801
 
 
802
@(defun si::maximum-contiguous-pages ()
 
803
@
 
804
        @(return MAKE_FIXNUM(maxcbpage))
 
805
@)
 
806
 
 
807
@(defun si::get_hole_size ()
 
808
@
 
809
        @(return MAKE_FIXNUM(new_holepage))
 
810
@)
 
811
 
 
812
@(defun si::set_hole_size (size)
 
813
        cl_index i;
 
814
@
 
815
        i = fixnnint(size);
 
816
        if (i == 0 || i > available_pages() + new_holepage)
 
817
          FEerror("Illegal value for the hole size.", 0);
 
818
        new_holepage = i;
 
819
        @(return size)
 
820
@)
 
821
 
 
822
@(defun si::ignore_maximum_pages (&optional (flag OBJNULL))
 
823
@
 
824
        if (flag == OBJNULL)
 
825
                @(return (ignore_maximum_pages? Ct : Cnil))
 
826
        ignore_maximum_pages = Null(flag);
 
827
        @(return flag)
 
828
@)
 
829
 
 
830
#ifdef NEED_MALLOC
 
831
/*
 
832
        UNIX malloc simulator.
 
833
 
 
834
        Used by
 
835
                getwd, popen, etc.
 
836
*/
 
837
 
 
838
#undef malloc
 
839
#undef calloc
 
840
#undef free
 
841
#undef cfree
 
842
#undef realloc
 
843
 
 
844
void *
 
845
malloc(size_t size)
 
846
{
 
847
  cl_object x;
 
848
 
 
849
  if (!GC_enabled() && !alloc_initialized)
 
850
    init_alloc();
 
851
 
 
852
  x = alloc_simple_string(size-1);
 
853
  x->string.self = (char *)cl_alloc(size);
 
854
  malloc_list = make_cons(x, malloc_list);
 
855
  return(x->string.self);
 
856
}
 
857
 
 
858
void
 
859
free(void *ptr)
 
860
{
 
861
  cl_object *p;
 
862
 
 
863
  if (ptr) {
 
864
    for (p = &malloc_list;  !endp(*p);  p = &(CDR((*p))))
 
865
      if ((CAR((*p)))->string.self == ptr) {
 
866
        cl_dealloc(CAR((*p))->string.self, CAR((*p))->string.dim+1);
 
867
        CAR((*p))->string.self = NULL;
 
868
        *p = CDR((*p));
 
869
        return;
 
870
      }
 
871
    FEerror("free(3) error.", 0);
 
872
  }
 
873
}
 
874
 
 
875
void *
 
876
realloc(void *ptr, size_t size)
 
877
{
 
878
  cl_object x;
 
879
  size_t i, j;
 
880
 
 
881
  if (ptr == NULL)
 
882
    return malloc(size);
 
883
  for (x = malloc_list;  !endp(x);  x = CDR(x))
 
884
    if (CAR(x)->string.self == ptr) {
 
885
      x = CAR(x);
 
886
      if (x->string.dim >= size) {
 
887
        x->string.fillp = size;
 
888
        return(ptr);
 
889
      } else {
 
890
        j = x->string.dim;
 
891
        x->string.self = (char *)cl_alloc(size);
 
892
        x->string.fillp = x->string.dim = size;
 
893
        memcpy(x->string.self, ptr, j);
 
894
        cl_dealloc(ptr, j);
 
895
        return(x->string.self);
 
896
      }
 
897
    }
 
898
  FEerror("realloc(3) error.", 0);
 
899
}
 
900
 
 
901
void *
 
902
calloc(size_t nelem, size_t elsize)
 
903
{
 
904
  char *ptr;
 
905
  size_t i = nelem*elsize;
 
906
  ptr = malloc(i);
 
907
  memset(ptr, 0 , i);
 
908
  return(ptr);
 
909
}
 
910
 
 
911
void cfree(void *ptr)
 
912
{
 
913
  free(ptr);
 
914
}
 
915
 
 
916
/* make f allocate enough extra, so that we can round
 
917
   up, the address given to an even multiple.   Special
 
918
   case of size == 0 , in which case we just want an aligned
 
919
   number in the address range
 
920
   */
 
921
 
 
922
#define ALLOC_ALIGNED(f, size, align) \
 
923
        ((align) <= 4 ? (int)(f)(size) : \
 
924
           ((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align))))
 
925
 
 
926
void *
 
927
memalign(size_t align, size_t size)
 
928
{ cl_object x = alloc_simple_string(size);
 
929
  malloc_list = make_cons(x, malloc_list);
 
930
  return x->string.self;
 
931
}
 
932
 
 
933
# ifdef WANT_VALLOC
 
934
char *
 
935
valloc(size_t size)
 
936
{ return memalign(getpagesize(), size);}
 
937
# endif /* WANT_VALLOC */
 
938
#endif /* NEED_MALLOC */