| 1 | /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, |
| 2 | * 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, |
| 3 | * 2014 Free Software Foundation, Inc. |
| 4 | * |
| 5 | * This library is free software; you can redistribute it and/or |
| 6 | * modify it under the terms of the GNU Lesser General Public License |
| 7 | * as published by the Free Software Foundation; either version 3 of |
| 8 | * the License, or (at your option) any later version. |
| 9 | * |
| 10 | * This library is distributed in the hope that it will be useful, but |
| 11 | * WITHOUT ANY WARRANTY; without even the implied warranty of |
| 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 13 | * Lesser General Public License for more details. |
| 14 | * |
| 15 | * You should have received a copy of the GNU Lesser General Public |
| 16 | * License along with this library; if not, write to the Free Software |
| 17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
| 18 | * 02110-1301 USA |
| 19 | */ |
| 20 | |
| 21 | |
| 22 | \f |
| 23 | #ifdef HAVE_CONFIG_H |
| 24 | # include <config.h> |
| 25 | #endif |
| 26 | |
| 27 | #include <stdio.h> |
| 28 | #include <errno.h> |
| 29 | #include <string.h> |
| 30 | #include <stdlib.h> |
| 31 | |
| 32 | #ifdef __ia64__ |
| 33 | #include <ucontext.h> |
| 34 | extern unsigned long * __libc_ia64_register_backing_store_base; |
| 35 | #endif |
| 36 | |
| 37 | #include "libguile/_scm.h" |
| 38 | #include "libguile/eval.h" |
| 39 | #include "libguile/stime.h" |
| 40 | #include "libguile/stackchk.h" |
| 41 | #include "libguile/struct.h" |
| 42 | #include "libguile/smob.h" |
| 43 | #include "libguile/arrays.h" |
| 44 | #include "libguile/async.h" |
| 45 | #include "libguile/ports.h" |
| 46 | #include "libguile/root.h" |
| 47 | #include "libguile/strings.h" |
| 48 | #include "libguile/vectors.h" |
| 49 | #include "libguile/hashtab.h" |
| 50 | #include "libguile/tags.h" |
| 51 | |
| 52 | #include "libguile/validate.h" |
| 53 | #include "libguile/deprecation.h" |
| 54 | #include "libguile/gc.h" |
| 55 | |
| 56 | #ifdef GUILE_DEBUG_MALLOC |
| 57 | #include "libguile/debug-malloc.h" |
| 58 | #endif |
| 59 | |
| 60 | #include <unistd.h> |
| 61 | |
| 62 | /* |
| 63 | INIT_MALLOC_LIMIT is the initial amount of malloc usage which will |
| 64 | trigger a GC. |
| 65 | |
| 66 | After startup (at the guile> prompt), we have approximately 100k of |
| 67 | alloced memory, which won't go away on GC. Let's set the init such |
| 68 | that we get a nice yield on the next allocation: |
| 69 | */ |
| 70 | #define SCM_DEFAULT_INIT_MALLOC_LIMIT 200*1024 |
| 71 | #define SCM_DEFAULT_MALLOC_MINYIELD 40 |
| 72 | |
| 73 | /* #define DEBUGINFO */ |
| 74 | |
| 75 | |
| 76 | \f |
| 77 | |
| 78 | static void* |
| 79 | do_realloc (void *from, size_t new_size) |
| 80 | { |
| 81 | scm_gc_register_allocation (new_size); |
| 82 | return realloc (from, new_size); |
| 83 | } |
| 84 | |
| 85 | static void* |
| 86 | do_calloc (size_t n, size_t size) |
| 87 | { |
| 88 | scm_gc_register_allocation (size); |
| 89 | return calloc (n, size); |
| 90 | } |
| 91 | |
| 92 | static void* |
| 93 | do_gc_malloc (size_t size, const char *what) |
| 94 | { |
| 95 | /* Ensure nonzero size to be compatible with always-nonzero return of |
| 96 | glibc malloc. */ |
| 97 | return GC_MALLOC (size ? size : sizeof (void *)); |
| 98 | } |
| 99 | |
| 100 | static void* |
| 101 | do_gc_malloc_atomic (size_t size, const char *what) |
| 102 | { |
| 103 | return GC_MALLOC_ATOMIC (size ? size : sizeof (void *)); |
| 104 | } |
| 105 | |
| 106 | static void* |
| 107 | do_gc_realloc (void *from, size_t size, const char *what) |
| 108 | { |
| 109 | return GC_REALLOC (from, size ? size : sizeof (void *)); |
| 110 | } |
| 111 | |
| 112 | static void |
| 113 | do_gc_free (void *ptr) |
| 114 | { |
| 115 | GC_FREE (ptr); |
| 116 | } |
| 117 | |
| 118 | |
| 119 | \f |
| 120 | /* Function for non-cell memory management. |
| 121 | */ |
| 122 | |
| 123 | void * |
| 124 | scm_realloc (void *mem, size_t size) |
| 125 | { |
| 126 | void *ptr; |
| 127 | |
| 128 | ptr = do_realloc (mem, size); |
| 129 | |
| 130 | if (ptr || size == 0) |
| 131 | return ptr; |
| 132 | |
| 133 | /* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */ |
| 134 | GC_gcollect_and_unmap (); |
| 135 | |
| 136 | ptr = do_realloc (mem, size); |
| 137 | if (ptr) |
| 138 | return ptr; |
| 139 | |
| 140 | scm_report_out_of_memory (); |
| 141 | |
| 142 | /* Not reached. */ |
| 143 | return NULL; |
| 144 | } |
| 145 | |
| 146 | void * |
| 147 | scm_malloc (size_t sz) |
| 148 | { |
| 149 | return scm_realloc (NULL, sz); |
| 150 | } |
| 151 | |
| 152 | /* |
| 153 | Hmm. Should we use the C convention for arguments (i.e. N_ELTS, |
| 154 | SIZEOF_ELT)? --hwn |
| 155 | */ |
| 156 | void * |
| 157 | scm_calloc (size_t sz) |
| 158 | { |
| 159 | void * ptr; |
| 160 | |
| 161 | /* |
| 162 | By default, try to use calloc, as it is likely more efficient than |
| 163 | calling memset by hand. |
| 164 | */ |
| 165 | ptr = do_calloc (sz, 1); |
| 166 | if (ptr || sz == 0) |
| 167 | return ptr; |
| 168 | |
| 169 | ptr = scm_realloc (NULL, sz); |
| 170 | memset (ptr, 0x0, sz); |
| 171 | return ptr; |
| 172 | } |
| 173 | |
| 174 | |
| 175 | char * |
| 176 | scm_strndup (const char *str, size_t n) |
| 177 | { |
| 178 | char *dst = scm_malloc (n + 1); |
| 179 | memcpy (dst, str, n); |
| 180 | dst[n] = 0; |
| 181 | return dst; |
| 182 | } |
| 183 | |
| 184 | char * |
| 185 | scm_strdup (const char *str) |
| 186 | { |
| 187 | return scm_strndup (str, strlen (str)); |
| 188 | } |
| 189 | |
| 190 | |
| 191 | |
| 192 | void |
| 193 | scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) |
| 194 | { |
| 195 | scm_gc_register_allocation (size); |
| 196 | |
| 197 | #ifdef GUILE_DEBUG_MALLOC |
| 198 | if (mem) |
| 199 | scm_malloc_register (mem, what); |
| 200 | #endif |
| 201 | } |
| 202 | |
| 203 | |
| 204 | void |
| 205 | scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what) |
| 206 | { |
| 207 | /* Nothing to do. */ |
| 208 | #ifdef GUILE_DEBUG_MALLOC |
| 209 | if (mem) |
| 210 | scm_malloc_unregister (mem); |
| 211 | #endif |
| 212 | } |
| 213 | |
| 214 | /* Allocate SIZE bytes of memory whose contents should not be scanned |
| 215 | for pointers (useful, e.g., for strings). Note though that this |
| 216 | memory is *not* cleared; be sure to initialize it to prevent |
| 217 | information leaks. */ |
| 218 | void * |
| 219 | scm_gc_malloc_pointerless (size_t size, const char *what) |
| 220 | { |
| 221 | return do_gc_malloc_atomic (size, what); |
| 222 | } |
| 223 | |
| 224 | void * |
| 225 | scm_gc_malloc (size_t size, const char *what) |
| 226 | { |
| 227 | return do_gc_malloc (size, what); |
| 228 | } |
| 229 | |
| 230 | void * |
| 231 | scm_gc_calloc (size_t size, const char *what) |
| 232 | { |
| 233 | /* `GC_MALLOC ()' always returns a zeroed buffer. */ |
| 234 | return do_gc_malloc (size, what); |
| 235 | } |
| 236 | |
| 237 | void * |
| 238 | scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what) |
| 239 | { |
| 240 | return do_gc_realloc (mem, new_size, what); |
| 241 | } |
| 242 | |
| 243 | void |
| 244 | scm_gc_free (void *mem, size_t size, const char *what) |
| 245 | { |
| 246 | do_gc_free (mem); |
| 247 | } |
| 248 | |
| 249 | char * |
| 250 | scm_gc_strndup (const char *str, size_t n, const char *what) |
| 251 | { |
| 252 | char *dst = do_gc_malloc_atomic (n + 1, what); |
| 253 | memcpy (dst, str, n); |
| 254 | dst[n] = 0; |
| 255 | return dst; |
| 256 | } |
| 257 | |
| 258 | char * |
| 259 | scm_gc_strdup (const char *str, const char *what) |
| 260 | { |
| 261 | return scm_gc_strndup (str, strlen (str), what); |
| 262 | } |