src/lisp/alloc.c

   1 /*
   2
   3  This code was written as part of the CMU Common Lisp project at
   4  Carnegie Mellon University, and has been placed in the public domain.
   5
   6 */
   7
   8 #include <stdio.h>
   9 #include <string.h>
  10
  11 #include "lisp.h"
  12 #include "internals.h"
  13 #include "alloc.h"
  14 #include "globals.h"
  15 #include "gc.h"
  16
  17 #ifdef ibmrt
  18 #define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
  19 #define SET_FREE_POINTER(new_value) \
  20     (SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
  21 #define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
  22 #define SET_GC_TRIGGER(new_value) \
  23     (SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
  24 #else
  25 #define GET_FREE_POINTER() current_dynamic_space_free_pointer
  26 #define SET_FREE_POINTER(new_value) \
  27     (current_dynamic_space_free_pointer = (new_value))
  28 #define GET_GC_TRIGGER() current_auto_gc_trigger
  29 #define SET_GC_TRIGGER(new_value) \
  30     clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
  31 #endif
  32
  33 #define ALIGNED_SIZE(n) (n+lowtag_Mask) & ~lowtag_Mask
  34
  35 /****************************************************************
  36 Allocation Routines.
  37 ****************************************************************/
  38
  39 #if defined GENCGC
  40 #define alloc(nbytes) alloc_pseudo_atomic(nbytes)
  41 #include "gencgc.h"
  42 #elif defined(WANT_CGC)
  43 extern lispobj *alloc(int bytes);
  44 #else
  45 static lispobj *
  46 alloc(int bytes)
  47 {
  48     lispobj *result;
  49
  50     /* Round to dual word boundry. */
  51     bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
  52
  53     result = GET_FREE_POINTER();
  54     SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
  55
  56     if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
  57         SET_GC_TRIGGER((char *) GET_FREE_POINTER()
  58                        - (char *) current_dynamic_space);
  59     }
  60
  61     return result;
  62 }
  63 #endif
  64
  65 static lispobj *
  66 alloc_unboxed(int type, int words)
  67 {
  68     lispobj *result;
  69
  70     result = (lispobj *) alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
  71
  72     *result = (lispobj) (words << type_Bits) | type;
  73
  74     return result;
  75 }
  76
  77 static lispobj
  78 alloc_vector(int type, int length, int size)
  79 {
  80     struct vector *result;
  81
  82     result = (struct vector *)
  83         alloc(ALIGNED_SIZE((2 + (length * size + 31) / 32) * sizeof(lispobj)));
  84
  85     result->header = type;
  86     result->length = make_fixnum(length);
  87
  88     return ((lispobj) result) | type_OtherPointer;
  89 }
  90
  91 lispobj
  92 alloc_cons(lispobj car, lispobj cdr)
  93 {
  94     struct cons *ptr = (struct cons *) alloc(ALIGNED_SIZE(sizeof(struct cons)));
  95
  96     ptr->car = car;
  97     ptr->cdr = cdr;
  98
  99     return (lispobj) ptr | type_ListPointer;
 100 }
 101
 102 lispobj
 103 alloc_number(long n)
 104 {
 105     struct bignum *ptr;
 106
 107 #ifdef __x86_64
 108     if (-0x2000000000000000 < n && n < 0x2000000000000000)      /* -2^61 to 2^61 */
 109 #else
 110     if (-0x20000000 < n && n < 0x20000000)
 111 #endif
 112         return make_fixnum(n);
 113     else {
 114         ptr = (struct bignum *) alloc_unboxed(type_Bignum, 1);
 115
 116         ptr->digits[0] = n;
 117
 118         return (lispobj) ptr | type_OtherPointer;
 119     }
 120 }
 121
 122 #ifndef UNICODE
 123 lispobj
 124 alloc_string(const char *str)
 125 {
 126     int len = strlen(str);
 127     lispobj result = alloc_vector(type_SimpleString, len + 1, 8);
 128     struct vector *vec = (struct vector *) PTR(result);
 129
 130     vec->length = make_fixnum(len);
 131     strcpy((char *) vec->data, str);
 132     return result;
 133 }
 134 #else
 135 lispobj
 136 alloc_string(const char *str)
 137 {
 138     int k;
 139     int len = strlen(str);
 140     lispobj result = alloc_vector(type_SimpleString, len + 1, 16);
 141     struct vector *vec = (struct vector *) PTR(result);
 142     unsigned short int *wide_char_data;
 143
 144     vec->length = make_fixnum(len);
 145     wide_char_data = (unsigned short int*) vec->data;
 146     for (k = 0; k < len; ++k) {
 147         wide_char_data[k] = str[k] & 0xff;
 148     }
 149
 150 #if 0
 151     fprintf(stderr, "alloc-string: 0x%lx %d -> `%s'\n",
 152             result, len, str);
 153 #endif
 154
 155     return result;
 156 }
 157 #endif
 158
 159 lispobj
 160 alloc_sap(void *ptr)
 161 {
 162 #ifndef alpha
 163     struct sap *sap_ptr = (struct sap *) alloc_unboxed(type_Sap, 1);
 164 #else
 165     struct sap *sap_ptr = (struct sap *) alloc_unboxed(type_Sap, 3);
 166 #endif
 167     sap_ptr->pointer = ptr;
 168
 169     return (lispobj) sap_ptr | type_OtherPointer;
 170 }