home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 08 / xscheme / xsdmem.c < prev    next >
Text File  |  1991-06-04  |  17KB  |  743 lines
  1. /* xsdmem.c - xscheme dynamic memory management routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* virtual machine registers */
  9. LVAL xlfun=NIL;        /* current function */
  10. LVAL xlenv=NIL;        /* current environment */
  11. LVAL xlval=NIL;        /* value of most recent instruction */
  12. LVAL *xlsp=NULL;    /* value stack pointer */
  13.  
  14. /* stack limits */
  15. LVAL *xlstkbase=NULL;    /* base of value stack */
  16. LVAL *xlstktop=NULL;    /* top of value stack (actually, one beyond) */
  17.  
  18. /* variables shared with xsimage.c */
  19. FIXTYPE total=0;    /* total number of bytes of memory in use */
  20. FIXTYPE gccalls=0;    /* number of calls to the garbage collector */
  21.  
  22. /* node space */
  23. NSEGMENT *nsegments=NULL;    /* list of node segments */
  24. NSEGMENT *nslast=NULL;        /* last node segment */
  25. int nscount=0;            /* number of node segments */
  26. FIXTYPE nnodes=0;        /* total number of nodes */
  27. FIXTYPE nfree=0;        /* number of nodes in free list */
  28. LVAL fnodes=NIL;        /* list of free nodes */
  29.  
  30. /* vector (and string) space */
  31. VSEGMENT *vsegments=NULL;    /* list of vector segments */
  32. VSEGMENT *vscurrent=NULL;    /* current vector segment */
  33. int vscount=0;            /* number of vector segments */
  34. LVAL *vfree=NULL;        /* next free location in vector space */
  35. LVAL *vtop=NULL;        /* top of vector space */
  36.  
  37. /* external variables */
  38. extern LVAL s_unbound;        /* *UNBOUND* symbol */
  39. extern LVAL obarray;        /* *OBARRAY* symbol */
  40. extern LVAL default_object;    /* default object */
  41. extern LVAL eof_object;        /* eof object */
  42. extern LVAL true;        /* truth value */
  43.  
  44. /* external routines */
  45. extern char *calloc();
  46.  
  47. /* forward declarations */
  48. #ifdef __STDC__
  49. static LVAL allocnode(int type);
  50. static void findmemory(void);
  51. static LVAL allocvector(int type,int size);
  52. static int findvmemory(int size);
  53. static void mark(LVAL ptr);
  54. static void markvector(LVAL vect);
  55. static void compact(void);
  56. static void compact_vector(VSEGMENT *vseg);
  57. static void sweep(void);
  58. static void sweep_segment(NSEGMENT *nseg);
  59. static void badobjtype(int type);
  60. #else
  61. static LVAL allocnode();
  62. static LVAL allocvector();
  63. static LVAL compact();
  64. #endif
  65.  
  66. /* cons - construct a new cons node */
  67. LVAL cons(x,y)
  68.   LVAL x,y;
  69. {
  70.     LVAL nnode;
  71.  
  72.     /* get a free node */
  73.     if ((nnode = fnodes) == NIL) {
  74.     check(2);
  75.     push(x);
  76.     push(y);
  77.     findmemory();
  78.     if ((nnode = fnodes) == NIL)
  79.         xlabort("insufficient node space");
  80.     drop(2);
  81.     }
  82.  
  83.     /* unlink the node from the free list */
  84.     fnodes = cdr(nnode);
  85.     --nfree;
  86.  
  87.     /* initialize the new node */
  88.     nnode->n_type = CONS;
  89.     rplaca(nnode,x);
  90.     rplacd(nnode,y);
  91.  
  92.     /* return the new node */
  93.     return (nnode);
  94. }
  95.  
  96. /* newframe - create a new environment frame */
  97. LVAL newframe(parent,size)
  98.   LVAL parent; int size;
  99. {
  100.     LVAL frame;
  101.     frame = cons(newvector(size),parent);
  102.     frame->n_type = ENV;
  103.     return (frame);
  104. }
  105.  
  106. /* cvstring - convert a string to a string node */
  107. LVAL cvstring(str)
  108.   char *str;
  109. {
  110.     LVAL val;
  111.     val = newstring(strlen(str)+1);
  112.     strcpy(getstring(val),str);
  113.     return (val);
  114. }
  115.  
  116. /* cvsymbol - convert a string to a symbol */
  117. LVAL cvsymbol(pname)
  118.   char *pname;
  119. {
  120.     LVAL val;
  121.     val = allocvector(SYMBOL,SYMSIZE);
  122.     cpush(val);
  123.     setvalue(val,s_unbound);
  124.     setpname(val,cvstring(pname));
  125.     setplist(val,NIL);
  126.     return (pop());
  127. }
  128.  
  129. /* cvfixnum - convert an integer to a fixnum node */
  130. LVAL cvfixnum(n)
  131.   FIXTYPE n;
  132. {
  133.     LVAL val;
  134.     if (n >= SFIXMIN && n <= SFIXMAX)
  135.     return (cvsfixnum(n));
  136.     val = allocnode(FIXNUM);
  137.     val->n_int = n;
  138.     return (val);
  139. }
  140.  
  141. /* cvflonum - convert a floating point number to a flonum node */
  142. LVAL cvflonum(n)
  143.   FLOTYPE n;
  144. {
  145.     LVAL val;
  146.     val = allocnode(FLONUM);
  147.     val->n_flonum = n;
  148.     return (val);
  149. }
  150.  
  151. /* cvchar - convert an integer to a character node */
  152. LVAL cvchar(ch)
  153.   int ch;
  154. {
  155.     LVAL val;
  156.     val = allocnode(CHAR);
  157.     val->n_chcode = ch;
  158.     return (val);
  159. }
  160.  
  161. /* cvclosure - convert code and an environment to a closure */
  162. LVAL cvclosure(code,env)
  163.   LVAL code,env;
  164. {
  165.     LVAL val;
  166.     val = cons(code,env);
  167.     val->n_type = CLOSURE;
  168.     return (val);
  169. }
  170.  
  171. /* cvpromise - convert a procedure to a promise */
  172. LVAL cvpromise(code,env)
  173.   LVAL code,env;
  174. {
  175.     LVAL val;
  176.     val = cons(cvclosure(code,env),NIL);
  177.     val->n_type = PROMISE;
  178.     return (val);
  179. }
  180.  
  181. /* cvmethod - convert code and an environment to a method */
  182. LVAL cvmethod(code,class)
  183.   LVAL code,class;
  184. {
  185.     LVAL val;
  186.     val = cons(code,class);
  187.     val->n_type = METHOD;
  188.     return (val);
  189. }
  190.  
  191. /* cvsubr - convert a function to a subr/xsubr */
  192. LVAL cvsubr(type,fcn,offset)
  193.   int type; LVAL (*fcn)(); int offset;
  194. {
  195.     LVAL val;
  196.     val = allocnode(type);
  197.     val->n_subr = fcn;
  198.     val->n_offset = offset;
  199.     return (val);
  200. }
  201.  
  202. /* cvport - convert a file pointer to an port */
  203. LVAL cvport(fp,flags)
  204.   FILE *fp; int flags;
  205. {
  206.     LVAL val;
  207.     val = allocnode(PORT);
  208.     setfile(val,fp);
  209.     setsavech(val,'\0');
  210.     setpflags(val,flags);
  211.     return (val);
  212. }
  213.  
  214. /* newvector - allocate and initialize a new vector */
  215. LVAL newvector(size)
  216.   int size;
  217. {
  218.     return (allocvector(VECTOR,size));
  219. }
  220.  
  221. /* newstring - allocate and initialize a new string */
  222. LVAL newstring(size)
  223.   int size;
  224. {
  225.     LVAL val;
  226.     val = allocvector(STRING,btow_size(size));
  227.     val->n_vsize = size;
  228.     return (val);
  229. }
  230.  
  231. /* newcode - create a new code object */
  232. LVAL newcode(nlits)
  233.   int nlits;
  234. {
  235.     return (allocvector(CODE,nlits));
  236. }
  237.  
  238. /* newcontinuation - create a new continuation object */
  239. LVAL newcontinuation(size)
  240.   int size;
  241. {
  242.     return (allocvector(CONTINUATION,size));
  243. }
  244.  
  245. /* newobject - allocate and initialize a new object */
  246. LVAL newobject(cls,size)
  247.   LVAL cls; int size;
  248. {
  249.     LVAL val;
  250.     val = allocvector(OBJECT,size+2); /* class, ivars */
  251.     setclass(val,cls);
  252.     return (val);
  253. }
  254.  
  255. /* allocnode - allocate a new node */
  256. static LVAL allocnode(type)
  257.   int type;
  258. {
  259.     LVAL nnode;
  260.  
  261.     /* get a free node */
  262.     if ((nnode = fnodes) == NIL) {
  263.     findmemory();
  264.     if ((nnode = fnodes) == NIL)
  265.         xlabort("insufficient node space");
  266.     }
  267.  
  268.     /* unlink the node from the free list */
  269.     fnodes = cdr(nnode);
  270.     --nfree;
  271.  
  272.     /* initialize the new node */
  273.     nnode->n_type = type;
  274.     rplacd(nnode,NIL);
  275.  
  276.     /* return the new node */
  277.     return (nnode);
  278. }
  279.  
  280. /* findmemory - garbage collect, then add more node space if necessary */
  281. static void findmemory()
  282. {
  283.     /* first try garbage collecting */
  284.     gc();
  285.  
  286.     /* expand memory only if less than one segment is free */
  287.     if (nfree < (long)NSSIZE)
  288.     nexpand(NSSIZE);
  289. }
  290.  
  291. /* nexpand - expand node space */
  292. int nexpand(size)
  293.   int size;
  294. {
  295.     NSEGMENT *newnsegment(),*newseg;
  296.     LVAL p;
  297.     int i;
  298.  
  299.     /* allocate the new segment */
  300.     if ((newseg = newnsegment(size)) != NULL) {
  301.  
  302.     /* add each new node to the free list */
  303.     p = &newseg->ns_data[0];
  304.     for (i = NSSIZE; --i >= 0; ++p) {
  305.         p->n_type = FREE;
  306.         p->n_flags = 0;
  307.         rplacd(p,fnodes);
  308.         fnodes = p;
  309.     }
  310.     }
  311.     return (newseg != NULL);
  312. }
  313.  
  314. /* allocvector - allocate and initialize a new vector node */
  315. static LVAL allocvector(type,size)
  316.   int type,size;
  317. {
  318.     register LVAL val,*p;
  319.     register int i;
  320.  
  321.     /* get a free node */
  322.     if ((val = fnodes) == NIL) {
  323.     findmemory();
  324.     if ((val = fnodes) == NIL)
  325.         xlabort("insufficient node space");
  326.     }
  327.  
  328.     /* unlink the node from the free list */
  329.     fnodes = cdr(fnodes);
  330.     --nfree;
  331.  
  332.     /* initialize the vector node */
  333.     val->n_type = type;
  334.     val->n_vsize = size;
  335.     val->n_vdata = NULL;
  336.     cpush(val);
  337.  
  338.     /* add space for the backpointer */
  339.     ++size;
  340.     
  341.     /* make sure there's enough space */
  342.     if (!VCOMPARE(vfree,size,vtop)
  343.     &&  !checkvmemory(size)
  344.     &&  !findvmemory(size))
  345.     xlabort("insufficient vector space");
  346.  
  347.     /* allocate the next available block */
  348.     p = vfree;
  349.     vfree += size;
  350.     
  351.     /* store the backpointer */
  352.     *p++ = top();
  353.     val->n_vdata = p;
  354.  
  355.     /* set all the elements to NIL */
  356.     for (i = size; i > 1; --i)
  357.     *p++ = NIL;
  358.  
  359.     /* return the new vector */
  360.     return (pop());
  361. }
  362.  
  363. /* findvmemory - find vector memory */
  364. static int findvmemory(size)
  365.   int size;
  366. {
  367.     /* try garbage collecting */
  368.     gc();
  369.  
  370.     /* check to see if we found enough memory */
  371.     if (VCOMPARE(vfree,size,vtop) || checkvmemory(size))
  372.     return (TRUE);
  373.  
  374.     /* expand vector space */
  375.     return (makevmemory(size));
  376. }
  377.  
  378. /* checkvmemory - check for vector memory (used by 'xsimage.c') */
  379. int checkvmemory(size)
  380.   int size;
  381. {
  382.     VSEGMENT *vseg;
  383.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
  384.     if (vseg != vscurrent && VCOMPARE(vseg->vs_free,size,vseg->vs_top)) {
  385.         if (vscurrent != NULL)
  386.         vscurrent->vs_free = vfree;
  387.         vfree = vseg->vs_free;
  388.         vtop = vseg->vs_top;
  389.         vscurrent = vseg;
  390.         return (TRUE);
  391.     }    
  392.     return (FALSE);
  393. }
  394.     
  395. /* makevmemory - make vector memory (used by 'xsimage.c') */
  396. int makevmemory(size)
  397.   int size;
  398. {
  399.     return (vexpand(size < VSSIZE ? VSSIZE : size));
  400. }
  401.  
  402. /* vexpand - expand vector space */
  403. int vexpand(size)
  404.   int size;
  405. {
  406.     VSEGMENT *newvsegment(),*vseg;
  407.  
  408.     /* allocate the new segment */
  409.     if ((vseg = newvsegment(size)) != NULL) {
  410.  
  411.     /* initialize the new segment and make it current */
  412.     if (vscurrent != NULL)
  413.         vscurrent->vs_free = vfree;
  414.     vfree = vseg->vs_free;
  415.     vtop = vseg->vs_top;
  416.     vscurrent = vseg;
  417.     }
  418.     return (vseg != NULL);
  419. }
  420.  
  421. /* newnsegment - create a new node segment */
  422. NSEGMENT *newnsegment(n)
  423.   unsigned int n;
  424. {
  425.     NSEGMENT *newseg;
  426.  
  427.     /* allocate the new segment */
  428.     if ((newseg = (NSEGMENT *)calloc(1,nsegsize(n))) == NULL)
  429.     return (NULL);
  430.  
  431.     /* initialize the new segment */
  432.     newseg->ns_size = n;
  433.     newseg->ns_next = NULL;
  434.     if (nsegments)
  435.     nslast->ns_next = newseg;
  436.     else
  437.     nsegments = newseg;
  438.     nslast = newseg;
  439.  
  440.     /* update the statistics */
  441.     total += (long)nsegsize(n);
  442.     nnodes += (long)n;
  443.     nfree += (long)n;
  444.     ++nscount;
  445.  
  446.     /* return the new segment */
  447.     return (newseg);
  448. }
  449.  
  450. /* newvsegment - create a new vector segment */
  451. VSEGMENT *newvsegment(n)
  452.   unsigned int n;
  453. {
  454.     VSEGMENT *newseg;
  455.  
  456.     /* allocate the new segment */
  457.     if ((newseg = (VSEGMENT *)calloc(1,vsegsize(n))) == NULL)
  458.     return (NULL);
  459.  
  460.     /* initialize the new segment */
  461.     newseg->vs_free = &newseg->vs_data[0];
  462.     newseg->vs_top = newseg->vs_free + n;
  463.     newseg->vs_next = vsegments;
  464.     vsegments = newseg;
  465.  
  466.     /* update the statistics */
  467.     total += (long)vsegsize(n);
  468.     ++vscount;
  469.  
  470.     /* return the new segment */
  471.     return (newseg);
  472. }
  473.  
  474. /* gc - garbage collect */
  475. void gc()
  476. {
  477.     register LVAL *p,tmp;
  478.  
  479.     /* mark the obarray and the current environment */
  480.     if (obarray && ispointer(obarray))
  481.     mark(obarray);
  482.     if (xlfun && ispointer(xlfun))
  483.     mark(xlfun);
  484.     if (xlenv && ispointer(xlenv))
  485.     mark(xlenv);
  486.     if (xlval && ispointer(xlval))
  487.     mark(xlval);
  488.     if (default_object && ispointer(default_object))
  489.     mark(default_object);
  490.     if (eof_object && ispointer(eof_object))
  491.     mark(eof_object);
  492.     if (true && ispointer(true))
  493.     mark(true);
  494.  
  495.     /* mark the stack */
  496.     for (p = xlsp; p < xlstktop; ++p)
  497.     if ((tmp = *p) != NIL && ispointer(tmp))
  498.         mark(tmp);
  499.  
  500.     /* compact vector space */
  501.     gc_protect(compact);
  502.  
  503.     /* sweep memory collecting all unmarked nodes */
  504.     sweep();
  505.  
  506.     /* count the gc call */
  507.     ++gccalls;
  508. }
  509.  
  510. /* mark - mark all accessible nodes */
  511. static void mark(ptr)
  512.   LVAL ptr;
  513. {
  514.     register LVAL this,prev,tmp;
  515.  
  516.     /* initialize */
  517.     prev = NIL;
  518.     this = ptr;
  519.  
  520.     /* mark this node */
  521.     for (;;) {
  522.  
  523.     /* descend as far as we can */
  524.     while (!(this->n_flags & MARK))
  525.  
  526.         /* mark this node and trace its children */
  527.         switch (this->n_type) {
  528.         case CONS:        /* mark cons-like nodes */
  529.         case CLOSURE:
  530.         case METHOD:
  531.         case PROMISE:
  532.         case ENV:
  533.         this->n_flags |= MARK;
  534.         if ((tmp = car(this)) != NIL && ispointer(tmp)) {
  535.             this->n_flags |= LEFT;
  536.             rplaca(this,prev);
  537.             prev = this;
  538.             this = tmp;
  539.         }
  540.         else if ((tmp = cdr(this)) != NIL && ispointer(tmp)) {
  541.             rplacd(this,prev);
  542.             prev = this;
  543.             this = tmp;
  544.         }
  545.         break;
  546.         case SYMBOL:    /* mark vector-like nodes */
  547.         case OBJECT:
  548.         case VECTOR:
  549.         case CODE:
  550.         case CONTINUATION:
  551.         this->n_flags |= MARK;
  552.         markvector(this);
  553.         break;
  554.         case FIXNUM:    /* mark objects that don't contain pointers */
  555.         case FLONUM:
  556.         case STRING:
  557.         case PORT:
  558.         case SUBR:
  559.         case XSUBR:
  560.         case CSUBR:
  561.         case CHAR:
  562.         this->n_flags |= MARK;
  563.         break;
  564.         default:        /* bad object type */
  565.         badobjtype(this->n_type);
  566.         break;
  567.         }
  568.  
  569.     /* backup to a point where we can continue descending */
  570.     for (;;)
  571.  
  572.         /* make sure there is a previous node */
  573.         if (prev) {
  574.         if (prev->n_flags & LEFT) {    /* came from left side */
  575.             prev->n_flags &= ~LEFT;
  576.             tmp = car(prev);
  577.             rplaca(prev,this);
  578.             if ((this = cdr(prev)) != NIL && ispointer(this)) {
  579.             rplacd(prev,tmp);            
  580.             break;
  581.             }
  582.         }
  583.         else {                /* came from right side */
  584.             tmp = cdr(prev);
  585.             rplacd(prev,this);
  586.         }
  587.         this = prev;            /* step back up the branch */
  588.         prev = tmp;
  589.         }
  590.  
  591.         /* no previous node, must be done */
  592.         else
  593.         return;
  594.     }
  595. }
  596.  
  597. /* markvector - mark a vector-like node */
  598. static void markvector(vect)
  599.   LVAL vect;
  600. {
  601.     register LVAL tmp,*p;
  602.     register int n;
  603.     if ((p = vect->n_vdata) != NULL) {
  604.     n = getsize(vect);
  605.     while (--n >= 0)
  606.         if ((tmp = *p++) != NIL && ispointer(tmp))
  607.         mark(tmp);
  608.     }
  609. }
  610.  
  611. /* compact - compact vector space */
  612. static void compact()
  613. {
  614.     VSEGMENT *vseg;
  615.  
  616.     /* store the current segment information */
  617.     if (vscurrent)
  618.     vscurrent->vs_free = vfree;
  619.  
  620.     /* compact each vector segment */
  621.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
  622.     compact_vector(vseg);
  623.  
  624.     /* make the first vector segment current */
  625.     if ((vscurrent = vsegments) != NULL) {
  626.     vfree = vscurrent->vs_free;
  627.     vtop = vscurrent->vs_top;
  628.     }
  629. }
  630.  
  631. /* compact_vector - compact a vector segment */
  632. static void compact_vector(vseg)
  633.   VSEGMENT *vseg;
  634. {
  635.     register LVAL *vdata,*vnext,*vfree,vector;
  636.     register int vsize;
  637.  
  638.     vdata = vnext = &vseg->vs_data[0];
  639.     vfree = vseg->vs_free;
  640.     while (vdata < vfree) {
  641.     vector = *vdata;
  642.     vsize = (vector->n_type == STRING ? btow_size(vector->n_vsize)
  643.                       : vector->n_vsize) + 1;
  644.     if (vector->n_flags & MARK) {
  645.         if (vdata == vnext) {
  646.         vdata += vsize;
  647.         vnext += vsize;
  648.         }
  649.         else {
  650.         vector->n_vdata = vnext + 1;
  651.         while (--vsize >= 0)
  652.             *vnext++ = *vdata++;
  653.         }
  654.     }
  655.     else
  656.         vdata += vsize;
  657.     }
  658.     vseg->vs_free = vnext;
  659. }
  660.  
  661. /* sweep - sweep all unmarked nodes and add them to the free list */
  662. static void sweep()
  663. {
  664.     NSEGMENT *nseg;
  665.  
  666.     /* empty the free list */
  667.     fnodes = NIL;
  668.     nfree = 0L;
  669.  
  670.     /* sweep each node segment */
  671.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next)
  672.     sweep_segment(nseg);
  673. }
  674.  
  675. /* sweep_segment - sweep a node segment */
  676. static void sweep_segment(nseg)
  677.   NSEGMENT *nseg;
  678. {
  679.     register FIXTYPE n;
  680.     register LVAL p;
  681.  
  682.     /* add all unmarked nodes */
  683.     for (p = &nseg->ns_data[0], n = nseg->ns_size; --n >= 0L; ++p)
  684.     if (!(p->n_flags & MARK)) {
  685.         switch (p->n_type) {
  686.         case PORT:
  687.         if (getfile(p))
  688.             osclose(getfile(p));
  689.         break;
  690.         }
  691.         p->n_type = FREE;
  692.         rplacd(p,fnodes);
  693.         fnodes = p;
  694.         ++nfree;
  695.     }
  696.     else
  697.         p->n_flags &= ~MARK;
  698. }
  699.  
  700. /* xlminit - initialize the dynamic memory module */
  701. void xlminit(ssize)
  702.   unsigned int ssize;
  703. {
  704.     unsigned int n;
  705.  
  706.     /* initialize our internal variables */
  707.     gccalls = 0;
  708.     total = 0L;
  709.  
  710.     /* initialize node space */
  711.     nsegments = nslast = NULL;
  712.     nscount = 0;
  713.     nnodes = nfree = 0L;
  714.     fnodes = NIL;
  715.  
  716.     /* initialize vector space */
  717.     vsegments = vscurrent = NULL;
  718.     vscount = 0;
  719.     vfree = vtop = NULL;
  720.     
  721.     /* allocate the value stack */
  722.     n = ssize * sizeof(LVAL);
  723.     if ((xlstkbase = (LVAL *)calloc(1,n)) == NULL)
  724.     xlfatal("insufficient memory");
  725.     total += (long)n;
  726.  
  727.     /* initialize structures that are marked by the collector */
  728.     obarray = default_object = eof_object = true = NIL;
  729.     xlfun = xlenv = xlval = NIL;
  730.  
  731.     /* initialize the stack */
  732.     xlsp = xlstktop = xlstkbase + ssize;
  733. }
  734.  
  735. /* badobjtype - report a bad object type error */
  736. static void badobjtype(type)
  737.   int type;
  738. {
  739.     char buf[100];
  740.     sprintf(buf,"bad object type - %d",type);
  741.     xlfatal(buf);
  742. }
  743.