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