home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-alloc.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  10KB  |  412 lines
  1. /*  pl-alloc.c,v 1.3 1993/02/23 13:16:23 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: memory allocation
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  13. This module defines memory allocation for the heap (the  program  space)
  14. and  the  various  stacks.   Memory  allocation below ALLOCFAST bytes is
  15. based entirely on a perfect fit algorithm.  Above ALLOCFAST  the  system
  16. memory  allocation  function  (typically malloc() is used to optimise on
  17. space.  Perfect fit memory allocation is fast and because  most  of  the
  18. memory  is allocated in small segments and these segments normally occur
  19. in similar relative frequencies it does not waste much memory.
  20.  
  21. The prolog machinery using these memory allocation functions always know
  22. how  much  memory  is  allocated  and  provides  this  argument  to  the
  23. corresponding  unalloc()  call if memory need to be freed.  This saves a
  24. word to store the size of the memory segment.
  25. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  26.  
  27. typedef struct chunk *    Chunk;
  28. typedef long        align_type;
  29.  
  30. struct chunk
  31. { Chunk        next;        /* next of chain */
  32. };
  33.  
  34. forwards Chunk    allocate P((alloc_t size));
  35.  
  36. #define ALLOCSIZE    10240    /* size of allocation chunks */
  37. #define ALLOCFAST    512    /* big enough for all structures */
  38.  
  39. static char   *spaceptr;    /* alloc: pointer to first free byte */
  40. static alloc_t spacefree;    /* number of free bytes left */
  41.  
  42. static Chunk  freeChains[ALLOCFAST/sizeof(Chunk)+1];
  43.  
  44. #define ALLOCROUND(n) ( (n) < sizeof(struct chunk) ? sizeof(struct chunk) \
  45.                            : ROUND(n, sizeof(align_type)) )
  46.                
  47. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  48. Allocate n bytes from the heap.  The amount returned is n rounded up to
  49. a multiple of words.  Allocated memory always starts at a word boundary.
  50.  
  51. below ALLOCFAST we use a special purpose fast allocation scheme.  Above
  52. (which is very rare) we use Unix malloc()/free() mechanism.
  53.  
  54. The rest of the code uses the macro allocHeap() to access this function
  55. to avoid problems with 16-bit machines not supporting an ANSI compiler.
  56. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  57.  
  58. Void
  59. alloc_heap(n)
  60. register alloc_t n;
  61. { register Chunk f;
  62.   register alloc_t m;
  63.   
  64.   DEBUG(9, printf("allocated %ld bytes at ", n));
  65.   n = ALLOCROUND(n);
  66.   statistics.heap += n;
  67.  
  68.   if (n <= ALLOCFAST)
  69.   { m = n / (int) sizeof(align_type);
  70.     if ((f = freeChains[m]) != NULL)
  71.     { freeChains[m] = f->next;
  72.       f->next = (Chunk) NULL;
  73.       DEBUG(9, printf("(r) %ld (0x%lx)\n", f, f));
  74.       return (Word) f;            /* perfect fit */
  75.     }
  76.     f = allocate(n);            /* allocate from core */
  77.  
  78.     if ((char *)f < hBase) hBase = (char *)f;
  79.     if ((char *)f > hTop)  hTop  = (char *)f;
  80.  
  81.     DEBUG(9, printf("(n) %ld (0x%lx)\n", f, f));
  82.     return f;
  83.   }
  84.  
  85.   f = (Chunk) Malloc(n);
  86.   DEBUG(9, printf("(b) %ld\n", f));
  87.   return f;
  88. }
  89.  
  90. void
  91. free_heap(mem, n)
  92. register Void mem;
  93. register alloc_t n;
  94. { Chunk p = (Chunk) mem;
  95.  
  96.   n = ALLOCROUND(n);
  97.   statistics.heap -= n;
  98.   DEBUG(9, printf("freed %d bytes at %ld\n", n, p));
  99.  
  100.   if (n <= ALLOCFAST)
  101.   { n /= sizeof(align_type);
  102.     p->next = freeChains[n];
  103.     freeChains[n] = p;
  104.   } else
  105.   { Free(p);
  106.   }
  107. }
  108.  
  109. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  110. No perfect fit is available.  We pick memory from the big chunk  we  are
  111. working  on.   If this is not big enough we will free the remaining part
  112. of it.  Next we check whether any areas are  assigned  to  be  used  for
  113. allocation.   If  all  this fails we allocate new core using Allocate(),
  114. which normally calls Malloc(). Early  versions  of  this  module  called
  115. sbrk(),  but  many systems get very upset by using sbrk() in combination
  116. with other memory allocation functions.
  117. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  118.  
  119. static
  120. Chunk
  121. allocate(n)
  122. register alloc_t n;
  123. { char *p;
  124.  
  125.   if (n <= spacefree)
  126.   { p = spaceptr;
  127.     spaceptr += n;
  128.     spacefree -= n;
  129.     return (Chunk) p;
  130.   }
  131.  
  132.   if ( spacefree >= sizeof(struct chunk) )
  133.     freeHeap(spaceptr, (alloc_t) (spacefree/sizeof(align_type))*sizeof(align_type));
  134.  
  135.   if ((p = (char *) Allocate(ALLOCSIZE)) <= (char *)NULL)
  136.     fatalError("Not enough core");
  137.  
  138.   spacefree = ALLOCSIZE;
  139.   spaceptr = p + n;
  140.   spacefree -= n;
  141.  
  142.   return (Chunk) p;
  143. }
  144.  
  145.         /********************************
  146.         *             STACKS            *
  147.         *********************************/
  148.  
  149. volatile void
  150. outOf(s)
  151. Stack s;
  152. { warning("Out of %s stack", s->name);
  153.  
  154.   pl_abort();
  155. }
  156.  
  157.         /********************************
  158.         *        GLOBAL STACK           *
  159.         *********************************/
  160.  
  161. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  162. alloc_global() allocates on the global stack.  Many  functions  do  this
  163. inline  as  it is simple and usualy very time critical.  The rest of the
  164. system should call the macro allocGlobal() to ensure the type  is  right
  165. on 16-bit machines not supporting ANSI.
  166. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  167.  
  168. Void
  169. alloc_global(n)
  170. register alloc_t n;
  171. { register Word result = gTop;
  172.  
  173.   gTop += (n + sizeof(word)-1) / sizeof(word);
  174.   verifyStack(global);
  175.  
  176.   return result;
  177. }
  178.  
  179. word
  180. globalFunctor(def)
  181. register FunctorDef def;
  182. { register Functor f = (Functor) gTop;
  183.   register int arity = def->arity;
  184.   register Word a;
  185.  
  186.   gTop = (Word)((char *)gTop + sizeof(FunctorDef) + sizeof(word) * arity);
  187.   verifyStack(global);
  188.   f->definition = def;
  189.   for(a = argTermP(f, 0); arity > 0; a++, arity--)
  190.     setVar(*a);
  191.  
  192.   return (word) f;
  193. }
  194.  
  195. #if O_STRING
  196. word
  197. globalString(s)
  198. register char *s;
  199. { register ulong l = strlen(s) + 1;
  200.   register Word gt = gTop;
  201.   register long chars = ROUND(l, sizeof(word));
  202.  
  203.   gTop = (Word) addPointer(gTop, 2*sizeof(word) + chars);
  204.   verifyStack(global);
  205.   gt[0] = gt[1+chars/sizeof(word)] = (((l-1)<<LMASK_BITS) | STRING_MASK);
  206.   strcpy((char *)(gt+1), s);
  207.  
  208.   return ((word)gt | INDIRECT_MASK);
  209. }
  210.  
  211. word
  212. heapString(s)
  213. char *s;
  214. { ulong l = strlen(s) + 1;
  215.   register long chars = ROUND(l, sizeof(word));
  216.   Word gt = (Word)allocHeap(2*sizeof(word) + chars);
  217.  
  218.   gt[0] = gt[1+chars/sizeof(word)] = (((l-1)<<LMASK_BITS) | STRING_MASK);
  219.   strcpy((char *)(gt+1), s);
  220.  
  221.   return (word)gt | INDIRECT_MASK;
  222. }
  223.  
  224. #endif /* O_STRING */
  225.  
  226. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  227. To allow for garbage collection,  reals  are  packed  into  two  tagged
  228. words.   The  4  top  bits  are  REAL_MASK  and the two bottom bits are
  229. reserved for garbage collection.  This leaves us with 52 bits  to  store
  230. the  real.   As  a  consequence,  SWI-Prolog  now uses a kind of `small
  231. doubles', increasing arithmetic accuracy.
  232.  
  233. This code is very hacky and needs to be rewritten for  systems  that  do
  234. not  have  IEEE  floating  point format.  Luckily almost all systems use
  235. IEEE these days.
  236.  
  237. Fixed for GCC 2.2 with the help of Giovanni Malnati.
  238. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  239.  
  240. typedef union
  241. { real f;
  242.   struct
  243.   { ulong e;
  244.     ulong f;
  245.   } bits;
  246. } fconvert;
  247.  
  248. forwards void    pack_real P((real f, fconvert *r));
  249.  
  250. #define IEEE 1
  251.  
  252. #if IEEE
  253. static void
  254. pack_real(f, r)
  255. real f;
  256. register fconvert *r;
  257. { fconvert b;
  258.  
  259.   b.f = f;
  260.   b.bits.f >>= 10;
  261.   b.bits.f &= ~0xffc00003L;
  262.   b.bits.f |= (b.bits.e & 0x3f) << 22;
  263.   b.bits.e >>= 4;
  264.   b.bits.e &= ~0xf0000003L;
  265. #if O_16_BITS
  266.   b.bits.e >>= 1;
  267.   b.bits.f >>= 1;
  268. #endif
  269.   b.bits.f |= REAL_MASK;
  270.   b.bits.e |= REAL_MASK;
  271.  
  272.   (*r).bits = b.bits;
  273. }
  274.  
  275. double
  276. unpack_real(p)
  277. Word p;
  278. { fconvert b;
  279.  
  280.   b.bits = ((fconvert *)p)->bits;
  281.  
  282. #if O_16_BITS
  283.   b.bits.e <<= 1;
  284.   b.bits.f <<= 1;
  285. #endif
  286.   b.bits.e <<= 4;
  287.   b.bits.e &= ~0x0000003fL;
  288.   b.bits.e |= (b.bits.f & 0x0fc00000L) >> 22;
  289.   b.bits.f <<= 10;
  290.   b.bits.f &= ~0x000003ffL;
  291.  
  292.   return b.f;
  293. }
  294. #endif /* IEEE */
  295.  
  296. void
  297. setReal(w, f)
  298. word w;
  299. real f;
  300. { fconvert *b = (fconvert *)unMask(w);
  301.   pack_real(f, b);
  302. }
  303.  
  304. word
  305. globalReal(f)
  306. real f;
  307. { fconvert *b = (fconvert *)gTop;
  308.  
  309.   gTop += sizeof(fconvert) / sizeof(word);
  310.   verifyStack(global);
  311.   pack_real(f, b);
  312.  
  313.   DEBUG(4, printf("Put REAL on global stack at 0x%x\n", b));
  314.   return (word)b | INDIRECT_MASK;
  315. }
  316.  
  317. word
  318. heapReal(f)
  319. real f;
  320. { fconvert *b = (fconvert *)allocHeap(sizeof(fconvert));
  321.  
  322.   pack_real(f, b);
  323.   return (word)b | INDIRECT_MASK;
  324. }
  325.  
  326.  
  327.         /********************************
  328.         *         LOCAL STACK           *
  329.         *********************************/
  330.  
  331. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  332. Allocation on the local stack is used by many foreign language functions
  333. that needs scratch memory.  The area normally is large and it  need  not
  334. be  deallocated  as  it  vanishes  after  quiting  the  foreign language
  335. function anyway.
  336. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  337.  
  338. static char *scratchBase;            /* base for scratching */
  339. #if !O_DYNAMIC_STACKS
  340. static char *scratchTop;
  341. #endif
  342.  
  343. void
  344. initAllocLocal()
  345. { if (scratchBase == (char *)NULL)
  346.   { scratchBase = (char *) lTop;
  347. #if !O_DYNAMIC_STACKS
  348.     scratchTop  = (char *) lMax;
  349. #endif
  350.   }
  351. }
  352.  
  353. Void
  354. alloc_local(n)
  355. register alloc_t n;
  356. { register char *mem = scratchBase;
  357.  
  358.   scratchBase += ROUND(n, sizeof(word));
  359. #if !O_DYNAMIC_STACKS
  360.   STACKVERIFY( if ( scratchBase >= scratchTop )
  361.          outOf((Stack) &stacks.local) );
  362. #endif
  363.  
  364.   return mem;
  365. }
  366.  
  367. void
  368. stopAllocLocal()
  369. { scratchBase = (char *)NULL;
  370. }
  371.  
  372. char *
  373. store_string_local(s)
  374. register char *s;
  375. { register char *copy = (char *)allocLocal(strlen(s)+1);
  376.  
  377.   strcpy(copy, s);
  378.   return copy;
  379. }
  380.  
  381.         /********************************
  382.         *            STRINGS            *
  383.         *********************************/
  384.  
  385. char *
  386. store_string(s)
  387. char *s;
  388. { char *copy = (char *)allocHeap(strlen(s)+1);
  389.  
  390.   strcpy(copy, s);
  391.   return copy;
  392. }
  393.  
  394. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  395. Hash function for strings.  This function has been evaluated on Shelley,
  396. which defines about 5000 Prolog atoms.  It produces a very nice  uniform
  397. distribution over these atoms.  Note that size equals 2^n.
  398. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  399.  
  400. int
  401. stringHashValue(s, size)
  402. register char *s;
  403. register int size;
  404. { register int value = 0;
  405.   register int shift = 0;
  406.  
  407.   while(*s)
  408.     value += (((int)(*s++)) << ((++shift) & 0x7));
  409.  
  410.   return value & (size-1);
  411. }
  412.