0.7.4.19:
[sbcl.git] / src / runtime / alloc.c
1 /*
2  * allocation routines
3  */
4
5 /*
6  * This software is part of the SBCL system. See the README file for
7  * more information.
8  *
9  * This software is derived from the CMU CL system, which was
10  * written at Carnegie Mellon University and released into the
11  * public domain. The software is in the public domain and is
12  * provided with absolutely no warranty. See the COPYING and CREDITS
13  * files for more information.
14  */
15
16 #include "runtime.h"
17 #include "sbcl.h"
18 #include "alloc.h"
19 #include "globals.h"
20 #include "gc.h"
21 #include <stdio.h>
22 #include <string.h>
23
24 #define GET_FREE_POINTER() dynamic_space_free_pointer
25 #define SET_FREE_POINTER(new_value) \
26     (dynamic_space_free_pointer = (new_value))
27 #define GET_GC_TRIGGER() current_auto_gc_trigger
28 #define SET_GC_TRIGGER(new_value) \
29     clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
30
31 #define ALIGNED_SIZE(n) (n+LOWTAG_MASK) & ~LOWTAG_MASK
32
33 #if defined GENCGC
34 extern lispobj *alloc(int bytes);
35 #else
36 static lispobj *
37 alloc(int bytes)
38 {
39     char *result;
40
41     /* Round to dual word boundary. */
42     bytes = (bytes + LOWTAG_MASK) & ~LOWTAG_MASK;
43
44     result = (char *)GET_FREE_POINTER();
45
46     SET_FREE_POINTER((lispobj *)(result + bytes));
47
48     if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
49         SET_GC_TRIGGER((char *)GET_FREE_POINTER()
50                        - (char *)current_dynamic_space);
51     }
52     return (lispobj *) result;
53 }
54 #endif
55
56 lispobj *
57 alloc_unboxed(int type, int words)
58 {
59     lispobj *result;
60
61     result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
62     *result = (lispobj) (words << N_WIDETAG_BITS) | type;
63     return result;
64 }
65
66 static lispobj
67 alloc_vector(int type, int length, int size)
68 {
69     struct vector *result;
70
71     result = (struct vector *)
72       alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj)));
73
74     result->header = type;
75     result->length = make_fixnum(length);
76
77     return ((lispobj)result)|OTHER_POINTER_LOWTAG;
78 }
79
80 lispobj
81 alloc_cons(lispobj car, lispobj cdr)
82 {
83     struct cons *ptr = (struct cons *)alloc(ALIGNED_SIZE(sizeof(struct cons)));
84
85     ptr->car = car;
86     ptr->cdr = cdr;
87
88     return (lispobj)ptr | LIST_POINTER_LOWTAG;
89 }
90
91 lispobj
92 alloc_number(long n)
93 {
94     struct bignum *ptr;
95
96     if (-0x20000000 < n && n < 0x20000000)
97         return make_fixnum(n);
98     else {
99         ptr = (struct bignum *)alloc_unboxed(BIGNUM_WIDETAG, 1);
100
101         ptr->digits[0] = n;
102
103         return (lispobj) ptr | OTHER_POINTER_LOWTAG;
104     }
105 }
106
107 lispobj
108 alloc_string(char *str)
109 {
110     int len = strlen(str);
111     lispobj result = alloc_vector(SIMPLE_STRING_WIDETAG, len+1, 8);
112     struct vector *vec = (struct vector *)native_pointer(result);
113
114     vec->length = make_fixnum(len);
115     strcpy((char *)vec->data, str);
116
117     return result;
118 }
119
120 lispobj
121 alloc_sap(void *ptr)
122 {
123     struct sap *sap;
124     sap=(struct sap *)
125         alloc_unboxed((int)SAP_WIDETAG, sizeof(struct sap)/sizeof(lispobj) -1);
126     sap->pointer = ptr;
127     return (lispobj) sap | OTHER_POINTER_LOWTAG;
128 }