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