1/* malloc.c -- Implementation File (module.c template V1.0)
2   Copyright (C) 1995 Free Software Foundation, Inc.
3   Contributed by James Craig Burley.
4
5This file is part of GNU Fortran.
6
7GNU Fortran is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU Fortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Fortran; see the file COPYING.  If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA.
21
22   Related Modules:
23      None
24
25   Description:
26      Fast pool-based memory allocation.
27
28   Modifications:
29*/
30
31/* Include files. */
32
33#include "proj.h"
34#include "malloc.h"
35
36/* Externals defined here.  */
37
38struct _malloc_root_ malloc_root_
39=
40{
41  {
42    &malloc_root_.malloc_pool_image_,
43    &malloc_root_.malloc_pool_image_,
44    (mallocPool) &malloc_root_.malloc_pool_image_.eldest,
45    (mallocPool) &malloc_root_.malloc_pool_image_.eldest,
46    (mallocArea_) &malloc_root_.malloc_pool_image_.first,
47    (mallocArea_) &malloc_root_.malloc_pool_image_.first,
48    0,
49#if MALLOC_DEBUG
50    0, 0, 0, 0, 0, 0, 0, { '/' }
51#else
52    { 0 }
53#endif
54  },
55};
56
57/* Simple definitions and enumerations. */
58
59
60/* Internal typedefs. */
61
62
63/* Private include files. */
64
65
66/* Internal structure definitions. */
67
68
69/* Static objects accessed by functions in this module. */
70
71static void *malloc_reserve_ = NULL;	/* For crashes. */
72#if MALLOC_DEBUG
73static const char *malloc_types_[] =
74{"KS", "KSR", "NF", "NFR", "US", "USR"};
75#endif
76
77/* Static functions (internal). */
78
79static void malloc_kill_area_ (mallocPool pool, mallocArea_ a);
80#if MALLOC_DEBUG
81static void malloc_verify_area_ (mallocPool pool, mallocArea_ a);
82#endif
83
84/* Internal macros. */
85
86#if MALLOC_DEBUG
87#define malloc_kill_(ptr,s) do {memset((ptr),127,(s));free((ptr));} while(0)
88#else
89#define malloc_kill_(ptr,s) free((ptr))
90#endif
91
92/* malloc_kill_area_ -- Kill storage area and its object
93
94   malloc_kill_area_(mallocPool pool,mallocArea_ area);
95
96   Does the actual killing of a storage area.  */
97
98static void
99malloc_kill_area_ (mallocPool pool UNUSED, mallocArea_ a)
100{
101#if MALLOC_DEBUG
102  assert (strcmp (a->name, ((char *) (a->where)) + a->size) == 0);
103#endif
104  malloc_kill_ (a->where, a->size);
105  a->next->previous = a->previous;
106  a->previous->next = a->next;
107#if MALLOC_DEBUG
108  pool->freed += a->size;
109  pool->frees++;
110#endif
111  malloc_kill_ (a,
112		offsetof (struct _malloc_area_, name)
113		+ strlen (a->name) + 1);
114}
115
116/* malloc_verify_area_ -- Verify storage area and its object
117
118   malloc_verify_area_(mallocPool pool,mallocArea_ area);
119
120   Does the actual verifying of a storage area.  */
121
122#if MALLOC_DEBUG
123static void
124malloc_verify_area_ (mallocPool pool UNUSED, mallocArea_ a UNUSED)
125{
126  mallocSize s = a->size;
127
128  assert (strcmp (a->name, ((char *) (a->where)) + s) == 0);
129}
130#endif
131
132/* malloc_init -- Initialize malloc cluster
133
134   malloc_init();
135
136   Call malloc_init before you do anything else.  */
137
138void
139malloc_init ()
140{
141  if (malloc_reserve_ != NULL)
142    return;
143  malloc_reserve_ = malloc (20 * 1024);	/* In case of crash, free this first. */
144  assert (malloc_reserve_ != NULL);
145}
146
147/* malloc_pool_display -- Display a pool
148
149   mallocPool p;
150   malloc_pool_display(p);
151
152   Displays information associated with the pool and its subpools.  */
153
154void
155malloc_pool_display (mallocPool p UNUSED)
156{
157#if MALLOC_DEBUG
158  mallocPool q;
159  mallocArea_ a;
160
161  fprintf (dmpout, "Pool \"%s\": bytes allocated=%lu, freed=%lu, old sizes=%lu, new sizes\
162=%lu,\n   allocations=%lu, frees=%lu, resizes=%lu, uses=%lu\n   Subpools:\n",
163	   p->name, p->allocated, p->freed, p->old_sizes, p->new_sizes, p->allocations,
164	   p->frees, p->resizes, p->uses);
165
166  for (q = p->eldest; q != (mallocPool) & p->eldest; q = q->next)
167    fprintf (dmpout, "      \"%s\"\n", q->name);
168
169  fprintf (dmpout, "   Storage areas:\n");
170
171  for (a = p->first; a != (mallocArea_) & p->first; a = a->next)
172    {
173      fprintf (dmpout, "      ");
174      malloc_display_ (a);
175    }
176#endif
177}
178
179/* malloc_pool_kill -- Destroy a pool
180
181   mallocPool p;
182   malloc_pool_kill(p);
183
184   Releases all storage associated with the pool and its subpools.  */
185
186void
187malloc_pool_kill (mallocPool p)
188{
189  mallocPool q;
190  mallocArea_ a;
191
192  if (--p->uses != 0)
193    return;
194
195#if 0
196  malloc_pool_display (p);
197#endif
198
199  assert (p->next->previous == p);
200  assert (p->previous->next == p);
201
202  /* Kill off all the subpools. */
203
204  while ((q = p->eldest) != (mallocPool) &p->eldest)
205    {
206      q->uses = 1;		/* Force the kill. */
207      malloc_pool_kill (q);
208    }
209
210  /* Now free all the storage areas. */
211
212  while ((a = p->first) != (mallocArea_) & p->first)
213    {
214      malloc_kill_area_ (p, a);
215    }
216
217  /* Now remove from list of sibling pools. */
218
219  p->next->previous = p->previous;
220  p->previous->next = p->next;
221
222  /* Finally, free the pool itself. */
223
224  malloc_kill_ (p,
225		offsetof (struct _malloc_pool_, name)
226		+ strlen (p->name) + 1);
227}
228
229/* malloc_pool_new -- Make a new pool
230
231   mallocPool p;
232   p = malloc_pool_new("My new pool",malloc_pool_image(),1024);
233
234   Makes a new pool with the given name and default new-chunk allocation.  */
235
236mallocPool
237malloc_pool_new (const char *name, mallocPool parent,
238		 unsigned long chunks UNUSED)
239{
240  mallocPool p;
241
242  if (parent == NULL)
243    parent = malloc_pool_image ();
244
245  p = malloc_new_ (offsetof (struct _malloc_pool_, name)
246		   + (MALLOC_DEBUG ? strlen (name) + 1 : 0));
247  p->next = (mallocPool) &(parent->eldest);
248  p->previous = parent->youngest;
249  parent->youngest->next = p;
250  parent->youngest = p;
251  p->eldest = (mallocPool) &(p->eldest);
252  p->youngest = (mallocPool) &(p->eldest);
253  p->first = (mallocArea_) &(p->first);
254  p->last = (mallocArea_) &(p->first);
255  p->uses = 1;
256#if MALLOC_DEBUG
257  p->allocated = p->freed = p->old_sizes = p->new_sizes = p->allocations
258    = p->frees = p->resizes = 0;
259  strcpy (p->name, name);
260#endif
261  return p;
262}
263
264/* malloc_pool_use -- Use an existing pool
265
266   mallocPool p;
267   p = malloc_pool_new(pool);
268
269   Increments use count for pool; means a matching malloc_pool_kill must
270   be performed before a subsequent one will actually kill the pool.  */
271
272mallocPool
273malloc_pool_use (mallocPool pool)
274{
275  ++pool->uses;
276  return pool;
277}
278
279/* malloc_display_ -- Display info on a mallocArea_
280
281   mallocArea_ a;
282   malloc_display_(a);
283
284   Simple.  */
285
286void
287malloc_display_ (mallocArea_ a UNUSED)
288{
289#if MALLOC_DEBUG
290  fprintf (dmpout, "At %08lX, size=%" mallocSize_f "u, type=%s, \"%s\"\n",
291	(unsigned long) a->where, a->size, malloc_types_[a->type], a->name);
292#endif
293}
294
295/* malloc_find_inpool_ -- Find mallocArea_ for object in pool
296
297   mallocPool pool;
298   void *ptr;
299   mallocArea_ a;
300   a = malloc_find_inpool_(pool,ptr);
301
302   Search for object in list of mallocArea_s, die if not found.	 */
303
304mallocArea_
305malloc_find_inpool_ (mallocPool pool, void *ptr)
306{
307  mallocArea_ a;
308  mallocArea_ b = (mallocArea_) &pool->first;
309  int n = 0;
310
311  for (a = pool->first; a != (mallocArea_) &pool->first; a = a->next)
312    {
313      assert (("Infinite loop detected" != NULL) && (a != b));
314      if (a->where == ptr)
315	return a;
316      ++n;
317      if (n & 1)
318	b = b->next;
319    }
320  assert ("Couldn't find object in pool!" == NULL);
321  return NULL;
322}
323
324/* malloc_kill_inpool_ -- Kill object
325
326   malloc_kill_inpool_(NULL,MALLOC_typeUS_,ptr,size_in_bytes);
327
328   Find the mallocArea_ for the pointer, make sure the type is proper, and
329   kill both of them.  */
330
331void
332malloc_kill_inpool_ (mallocPool pool, mallocType_ type UNUSED,
333		     void *ptr, mallocSize s UNUSED)
334{
335  mallocArea_ a;
336
337  if (pool == NULL)
338    pool = malloc_pool_image ();
339
340#if MALLOC_DEBUG
341  assert ((pool == malloc_pool_image ())
342	  || malloc_pool_find_ (pool, malloc_pool_image ()));
343#endif
344
345  a = malloc_find_inpool_ (pool, ptr);
346#if MALLOC_DEBUG
347  assert (a->type == type);
348  if ((type != MALLOC_typeUS_) && (type != MALLOC_typeUSR_))
349    assert (a->size == s);
350#endif
351  malloc_kill_area_ (pool, a);
352}
353
354/* malloc_new_ -- Allocate new object, die if unable
355
356   ptr = malloc_new_(size_in_bytes);
357
358   Call malloc, bomb if it returns NULL.  */
359
360void *
361malloc_new_ (mallocSize s)
362{
363  void *ptr;
364  unsigned ss = s;
365
366#if MALLOC_DEBUG && 0
367  assert (s == (mallocSize) ss);/* Else alloc is too big for this
368				   library/sys. */
369#endif
370
371  ptr = xmalloc (ss);
372#if MALLOC_DEBUG
373  memset (ptr, 126, ss);	/* Catch some kinds of errors more
374				   quickly/reliably. */
375#endif
376  return ptr;
377}
378
379/* malloc_new_inpool_ -- Allocate new object, die if unable
380
381   ptr = malloc_new_inpool_(NULL,MALLOC_typeUS_,"object",size_in_bytes);
382
383   Allocate the structure and allocate a mallocArea_ to describe it, then
384   add it to the list of mallocArea_s for the pool.  */
385
386void *
387malloc_new_inpool_ (mallocPool pool, mallocType_ type, const char *name, mallocSize s)
388{
389  void *ptr;
390  mallocArea_ a;
391  unsigned short i;
392
393  if (pool == NULL)
394    pool = malloc_pool_image ();
395
396#if MALLOC_DEBUG
397  assert ((pool == malloc_pool_image ())
398	  || malloc_pool_find_ (pool, malloc_pool_image ()));
399#endif
400
401  ptr = malloc_new_ (s + (i = (MALLOC_DEBUG ? strlen (name) + 1 : 0)));
402#if MALLOC_DEBUG
403  strcpy (((char *) (ptr)) + s, name);
404#endif
405  a = malloc_new_ (offsetof (struct _malloc_area_, name) + i);
406  switch (type)
407    {				/* A little optimization to speed up killing
408				   of non-permanent stuff. */
409    case MALLOC_typeKP_:
410    case MALLOC_typeKPR_:
411      a->next = (mallocArea_) &pool->first;
412      break;
413
414    default:
415      a->next = pool->first;
416      break;
417    }
418  a->previous = a->next->previous;
419  a->next->previous = a;
420  a->previous->next = a;
421  a->where = ptr;
422#if MALLOC_DEBUG
423  a->size = s;
424  a->type = type;
425  strcpy (a->name, name);
426  pool->allocated += s;
427  pool->allocations++;
428#endif
429  return ptr;
430}
431
432/* malloc_new_zinpool_ -- Allocate new zeroed object, die if unable
433
434   ptr = malloc_new_zinpool_(NULL,MALLOC_typeUS_,"object",size_in_bytes,0);
435
436   Like malloc_new_inpool_, but zeros out all the bytes in the area (assuming
437   you pass it a 0).  */
438
439void *
440malloc_new_zinpool_ (mallocPool pool, mallocType_ type, const char *name, mallocSize s,
441		     int z)
442{
443  void *ptr;
444
445  ptr = malloc_new_inpool_ (pool, type, name, s);
446  memset (ptr, z, s);
447  return ptr;
448}
449
450/* malloc_pool_find_ -- See if pool is a descendant of another pool
451
452   if (malloc_pool_find_(target_pool,parent_pool)) ...;
453
454   Recursive descent on each of the children of the parent pool, after
455   first checking the children themselves.  */
456
457char
458malloc_pool_find_ (mallocPool pool, mallocPool parent)
459{
460  mallocPool p;
461
462  for (p = parent->eldest; p != (mallocPool) & parent->eldest; p = p->next)
463    {
464      if ((p == pool) || malloc_pool_find_ (pool, p))
465	return 1;
466    }
467  return 0;
468}
469
470/* malloc_resize_inpool_ -- Resize existing object in pool
471
472   ptr = malloc_resize_inpool_(NULL,MALLOC_typeUSR_,ptr,new_size,old_size);
473
474   Find the object's mallocArea_, check it out, then do the resizing.  */
475
476void *
477malloc_resize_inpool_ (mallocPool pool, mallocType_ type UNUSED,
478		       void *ptr, mallocSize ns, mallocSize os UNUSED)
479{
480  mallocArea_ a;
481
482  if (pool == NULL)
483    pool = malloc_pool_image ();
484
485#if MALLOC_DEBUG
486  assert ((pool == malloc_pool_image ())
487	  || malloc_pool_find_ (pool, malloc_pool_image ()));
488#endif
489
490  a = malloc_find_inpool_ (pool, ptr);
491#if MALLOC_DEBUG
492  assert (a->type == type);
493  if ((type == MALLOC_typeKSR_) || (type == MALLOC_typeKPR_))
494    assert (a->size == os);
495  assert (strcmp (a->name, ((char *) (ptr)) + os) == 0);
496#endif
497  ptr = malloc_resize_ (ptr, ns + (MALLOC_DEBUG ? strlen (a->name) + 1: 0));
498  a->where = ptr;
499#if MALLOC_DEBUG
500  a->size = ns;
501  strcpy (((char *) (ptr)) + ns, a->name);
502  pool->old_sizes += os;
503  pool->new_sizes += ns;
504  pool->resizes++;
505#endif
506  return ptr;
507}
508
509/* malloc_resize_ -- Reallocate object, die if unable
510
511   ptr = malloc_resize_(ptr,size_in_bytes);
512
513   Call realloc, bomb if it returns NULL.  */
514
515void *
516malloc_resize_ (void *ptr, mallocSize s)
517{
518  int ss = s;
519
520#if MALLOC_DEBUG && 0
521  assert (s == (mallocSize) ss);/* Too big if failure here. */
522#endif
523
524  ptr = xrealloc (ptr, ss);
525  return ptr;
526}
527
528/* malloc_verify_inpool_ -- Verify object
529
530   Find the mallocArea_ for the pointer, make sure the type is proper, and
531   verify both of them.  */
532
533void
534malloc_verify_inpool_ (mallocPool pool UNUSED, mallocType_ type UNUSED,
535		       void *ptr UNUSED, mallocSize s UNUSED)
536{
537#if MALLOC_DEBUG
538  mallocArea_ a;
539
540  if (pool == NULL)
541    pool = malloc_pool_image ();
542
543  assert ((pool == malloc_pool_image ())
544	  || malloc_pool_find_ (pool, malloc_pool_image ()));
545
546  a = malloc_find_inpool_ (pool, ptr);
547  assert (a->type == type);
548  if ((type != MALLOC_typeUS_) && (type != MALLOC_typeUSR_))
549    assert (a->size == s);
550  malloc_verify_area_ (pool, a);
551#endif
552}
553