home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xscheme / xsdmem.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-01-29  |  14.3 KB  |  680 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;        /* current function */
  10. LVAL xlenv;        /* current environment */
  11. LVAL xlval;        /* value of most recent instruction */
  12. LVAL *xlsp;        /* value stack pointer */
  13.  
  14. /* stack limits */
  15. LVAL *xlstkbase;    /* base of value stack */
  16. LVAL *xlstktop;        /* top of value stack (actually, one beyond) */
  17.  
  18. /* variables shared with xsimage.c */
  19. FIXTYPE total;        /* total number of bytes of memory in use */
  20. FIXTYPE gccalls;    /* number of calls to the garbage collector */
  21.  
  22. /* node space */
  23. NSEGMENT *nsegments;    /* list of node segments */
  24. NSEGMENT *nslast;    /* last node segment */
  25. int nscount;        /* number of node segments */
  26. FIXTYPE nnodes;        /* total number of nodes */
  27. FIXTYPE nfree;        /* number of nodes in free list */
  28. LVAL fnodes;        /* list of free nodes */
  29.  
  30. /* vector (and string) space */
  31. VSEGMENT *vsegments;    /* list of vector segments */
  32. VSEGMENT *vscurrent;    /* current vector segment */
  33. int vscount;        /* number of vector segments */
  34. LVAL *vfree;        /* next free location in vector space */
  35. LVAL *vtop;        /* 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 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 newframe;
  86.     newframe = cons(newvector(size),parent);
  87.     newframe->n_type = ENV;
  88.     return (newframe);
  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+1); /* 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.     NSEGMENT *newnsegment(),*newseg;
  269.     LVAL p;
  270.     int n;
  271.  
  272.     /* first try garbage collecting */
  273.     gc();
  274.  
  275.     /* expand memory only if less than one segment is free */
  276.     if (nfree >= (long)NSSIZE)
  277.     return;
  278.  
  279.     /* allocate the new segment */
  280.     if ((newseg = newnsegment(NSSIZE)) == NULL)
  281.     return;
  282.  
  283.     /* add each new node to the free list */
  284.     p = &newseg->ns_data[0];
  285.     for (n = NSSIZE; --n >= 0; ++p) {
  286.     p->n_type = FREE;
  287.     p->n_flags = 0;
  288.     rplacd(p,fnodes);
  289.     fnodes = p;
  290.     }
  291. }
  292.  
  293. /* allocvector - allocate and initialize a new vector node */
  294. LOCAL LVAL allocvector(type,size)
  295.   int type,size;
  296. {
  297.     register LVAL val,*p;
  298.     register int i;
  299.  
  300.     /* get a free node */
  301.     if ((val = fnodes) == NIL) {
  302.     findmemory();
  303.     if ((val = fnodes) == NIL)
  304.         xlabort("insufficient node space");
  305.     }
  306.  
  307.     /* unlink the node from the free list */
  308.     fnodes = cdr(fnodes);
  309.     --nfree;
  310.  
  311.     /* initialize the vector node */
  312.     val->n_type = type;
  313.     val->n_vsize = size;
  314.     val->n_vdata = NULL;
  315.     cpush(val);
  316.  
  317.     /* add space for the backpointer */
  318.     ++size;
  319.     
  320.     /* make sure there's enough space */
  321.     if (vfree + size >= vtop) {
  322.     findvmemory(size);
  323.     if (vfree + size >= vtop)
  324.         xlabort("insufficient vector space");
  325.     }
  326.  
  327.     /* allocate the next available block */
  328.     p = vfree;
  329.     vfree += size;
  330.     
  331.     /* store the backpointer */
  332.     *p++ = top();
  333.     val->n_vdata = p;
  334.  
  335.     /* set all the elements to NIL */
  336.     for (i = size; i > 1; --i)
  337.     *p++ = NIL;
  338.  
  339.     /* return the new vector */
  340.     return (pop());
  341. }
  342.  
  343. /* findvmemory - find vector memory (used by 'xsimage.c') */
  344. findvmemory(size)
  345.   int size;
  346. {
  347.     VSEGMENT *newvsegment(),*vseg;
  348.     
  349.     /* first try garbage collecting */
  350.     gc();
  351.  
  352.     /* look for a vector segment with enough space */
  353.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
  354.     if (vseg->vs_free + size < vseg->vs_top) {
  355.         if (vscurrent != NULL)
  356.         vscurrent->vs_free = vfree;
  357.         vfree = vseg->vs_free;
  358.         vtop = vseg->vs_top;
  359.         vscurrent = vseg;
  360.         return;
  361.     }
  362.     
  363.     /* allocate a new vector segment and make it current */
  364.     if (vseg = newvsegment(VSSIZE)) {
  365.     if (vscurrent != NULL)
  366.         vscurrent->vs_free = vfree;
  367.     vfree = vseg->vs_free;
  368.     vtop = vseg->vs_top;
  369.     vscurrent = vseg;
  370.     }
  371. }
  372.  
  373. /* newnsegment - create a new node segment */
  374. NSEGMENT *newnsegment(n)
  375.   unsigned int n;
  376. {
  377.     NSEGMENT *newseg;
  378.  
  379.     /* allocate the new segment */
  380.     if ((newseg = (NSEGMENT *)calloc(1,nsegsize(n))) == NULL)
  381.     return (NULL);
  382.  
  383.     /* initialize the new segment */
  384.     newseg->ns_size = n;
  385.     newseg->ns_next = NULL;
  386.     if (nsegments)
  387.     nslast->ns_next = newseg;
  388.     else
  389.     nsegments = newseg;
  390.     nslast = newseg;
  391.  
  392.     /* update the statistics */
  393.     total += (long)nsegsize(n);
  394.     nnodes += (long)n;
  395.     nfree += (long)n;
  396.     ++nscount;
  397.  
  398.     /* return the new segment */
  399.     return (newseg);
  400. }
  401.  
  402. /* newvsegment - create a new vector segment */
  403. VSEGMENT *newvsegment(n)
  404.   unsigned int n;
  405. {
  406.     VSEGMENT *newseg;
  407.  
  408.     /* allocate the new segment */
  409.     if ((newseg = (VSEGMENT *)calloc(1,vsegsize(n))) == NULL)
  410.     return (NULL);
  411.  
  412.     /* initialize the new segment */
  413.     newseg->vs_free = &newseg->vs_data[0];
  414.     newseg->vs_top = newseg->vs_free + n;
  415.     newseg->vs_next = vsegments;
  416.     vsegments = newseg;
  417.  
  418.     /* update the statistics */
  419.     total += (long)vsegsize(n);
  420.     ++vscount;
  421.  
  422.     /* return the new segment */
  423.     return (newseg);
  424. }
  425.  
  426. /* gc - garbage collect */
  427. gc()
  428. {
  429.     register LVAL *p,tmp;
  430.     int compact();
  431.  
  432.     /* mark the obarray and the current environment */
  433.     if (obarray && ispointer(obarray))
  434.     mark(obarray);
  435.     if (xlfun && ispointer(xlfun))
  436.     mark(xlfun);
  437.     if (xlenv && ispointer(xlenv))
  438.     mark(xlenv);
  439.     if (xlval && ispointer(xlval))
  440.     mark(xlval);
  441.     if (default_object && ispointer(default_object))
  442.     mark(default_object);
  443.     if (eof_object && ispointer(eof_object))
  444.     mark(eof_object);
  445.     if (true && ispointer(true))
  446.     mark(true);
  447.  
  448.     /* mark the stack */
  449.     for (p = xlsp; p < xlstktop; ++p)
  450.     if ((tmp = *p) && ispointer(tmp))
  451.         mark(tmp);
  452.  
  453.     /* compact vector space */
  454.     gc_protect(compact);
  455.  
  456.     /* sweep memory collecting all unmarked nodes */
  457.     sweep();
  458.  
  459.     /* count the gc call */
  460.     ++gccalls;
  461. }
  462.  
  463. /* mark - mark all accessible nodes */
  464. LOCAL mark(ptr)
  465.   LVAL ptr;
  466. {
  467.     register LVAL this,prev,tmp;
  468.  
  469.     /* initialize */
  470.     prev = NIL;
  471.     this = ptr;
  472.  
  473.     /* mark this node */
  474.     for (;;) {
  475.  
  476.     /* descend as far as we can */
  477.     while (!(this->n_flags & MARK))
  478.  
  479.         /* mark this node and trace its children */
  480.         switch (this->n_type) {
  481.         case CONS:        /* mark cons-like nodes */
  482.         case CLOSURE:
  483.         case METHOD:
  484.         case PROMISE:
  485.         case ENV:
  486.         this->n_flags |= MARK;
  487.         if ((tmp = car(this)) && ispointer(tmp)) {
  488.             this->n_flags |= LEFT;
  489.             rplaca(this,prev);
  490.             prev = this;
  491.             this = tmp;
  492.         }
  493.         else if ((tmp = cdr(this)) && ispointer(tmp)) {
  494.             rplacd(this,prev);
  495.             prev = this;
  496.             this = tmp;
  497.         }
  498.         break;
  499.         case SYMBOL:    /* mark vector-like nodes */
  500.         case OBJECT:
  501.         case VECTOR:
  502.         case CODE:
  503.         case CONTINUATION:
  504.         this->n_flags |= MARK;
  505.         markvector(this);
  506.         break;
  507.         default:        /* mark all other types of nodes */
  508.         this->n_flags |= MARK;
  509.         break;
  510.         }
  511.  
  512.     /* backup to a point where we can continue descending */
  513.     for (;;)
  514.  
  515.         /* make sure there is a previous node */
  516.         if (prev) {
  517.         if (prev->n_flags & LEFT) {    /* came from left side */
  518.             prev->n_flags &= ~LEFT;
  519.             tmp = car(prev);
  520.             rplaca(prev,this);
  521.             if ((this = cdr(prev)) && ispointer(this)) {
  522.             rplacd(prev,tmp);            
  523.             break;
  524.             }
  525.         }
  526.         else {                /* came from right side */
  527.             tmp = cdr(prev);
  528.             rplacd(prev,this);
  529.         }
  530.         this = prev;            /* step back up the branch */
  531.         prev = tmp;
  532.         }
  533.  
  534.         /* no previous node, must be done */
  535.         else
  536.         return;
  537.     }
  538. }
  539.  
  540. /* markvector - mark a vector-like node */
  541. LOCAL markvector(vect)
  542.   LVAL vect;
  543. {
  544.     register LVAL tmp,*p;
  545.     register int n;
  546.     if (p = vect->n_vdata) {
  547.     n = getsize(vect);
  548.     while (--n >= 0)
  549.         if ((tmp = *p++) != NULL && ispointer(tmp))
  550.         mark(tmp);
  551.     }
  552. }
  553.  
  554. /* compact - compact vector space */
  555. LOCAL compact()
  556. {
  557.     VSEGMENT *vseg;
  558.  
  559.     /* store the current segment information */
  560.     if (vscurrent)
  561.     vscurrent->vs_free = vfree;
  562.  
  563.     /* compact each vector segment */
  564.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
  565.     compact_vector(vseg);
  566.  
  567.     /* make the first vector segment current */
  568.     if (vscurrent = vsegments) {
  569.     vfree = vscurrent->vs_free;
  570.     vtop = vscurrent->vs_top;
  571.     }
  572. }
  573.  
  574. /* compact_vector - compact a vector segment */
  575. LOCAL compact_vector(vseg)
  576.   VSEGMENT *vseg;
  577. {
  578.     register LVAL *vdata,*vnext,*vfree,vector;
  579.     register int vsize;
  580.  
  581.     vdata = vnext = &vseg->vs_data[0];
  582.     vfree = vseg->vs_free;
  583.     while (vdata < vfree) {
  584.     vector = *vdata;
  585.     if (vector->n_type == STRING)
  586.         vsize = btow_size(vector->n_vsize) + 1;
  587.     else
  588.         vsize = vector->n_vsize + 1;
  589.     if (vector->n_flags & MARK) {
  590.         if (vdata == vnext) {
  591.         vdata += vsize;
  592.         vnext += vsize;
  593.         }
  594.         else {
  595.         vector->n_vdata = vnext + 1;
  596.         while (vsize > 0) {
  597.             *vnext++ = *vdata++;
  598.             --vsize;
  599.         }
  600.         }
  601.     }
  602.     else
  603.         vdata += vsize;
  604.     }
  605.     vseg->vs_free = vnext;
  606. }
  607.  
  608. /* sweep - sweep all unmarked nodes and add them to the free list */
  609. LOCAL sweep()
  610. {
  611.     NSEGMENT *nseg;
  612.  
  613.     /* empty the free list */
  614.     fnodes = NIL;
  615.     nfree = 0L;
  616.  
  617.     /* sweep each node segment */
  618.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next)
  619.     sweep_segment(nseg);
  620. }
  621.  
  622. /* sweep_segment - sweep a node segment */
  623. LOCAL sweep_segment(nseg)
  624.   NSEGMENT *nseg;
  625. {
  626.     register FIXTYPE n;
  627.     register LVAL p;
  628.  
  629.     /* add all unmarked nodes */
  630.     for (p = &nseg->ns_data[0], n = nseg->ns_size; --n >= 0L; ++p)
  631.     if (!(p->n_flags & MARK)) {
  632.         switch (p->n_type) {
  633.         case PORT:
  634.         if (getfile(p))
  635.             osclose(getfile(p));
  636.         break;
  637.         }
  638.         p->n_type = FREE;
  639.         rplacd(p,fnodes);
  640.         fnodes = p;
  641.         ++nfree;
  642.     }
  643.     else
  644.         p->n_flags &= ~MARK;
  645. }
  646.  
  647. /* xlminit - initialize the dynamic memory module */
  648. xlminit(ssize)
  649.   unsigned int ssize;
  650. {
  651.     unsigned int n;
  652.     
  653.     /* initialize our internal variables */
  654.     gccalls = 0;
  655.     total = 0L;
  656.  
  657.     /* initialize node space */
  658.     nsegments = nslast = NULL;
  659.     nscount = 0;
  660.     nnodes = nfree = 0L;
  661.     fnodes = NIL;
  662.  
  663.     /* initialize vector space */
  664.     vsegments = vscurrent = NULL;
  665.     vscount = 0;
  666.     vfree = vtop = NULL;
  667.     
  668.     /* allocate the value stack */
  669.     n = ssize * sizeof(LVAL);
  670.     if ((xlstkbase = (LVAL *)calloc(1,n)) == NULL)
  671.     xlfatal("insufficient memory");
  672.     total += (long)n;
  673.  
  674.     /* initialize structures that are marked by the collector */
  675.     obarray = xlfun = xlenv = xlval = NIL;
  676.  
  677.     /* initialize the stack */
  678.     xlsp = xlstktop = xlstkbase + ssize;
  679. }
  680.