home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / xlisp2tc / xldmem.c < prev    next >
C/C++ Source or Header  |  1988-03-25  |  16KB  |  697 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* node flags */
  9. #define MARK    1
  10. #define LEFT    2
  11.  
  12. /* macro to compute the size of a segment */
  13. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  14.  
  15. /* external variables */
  16. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
  17. extern LVAL xlenv,xlfenv,xldenv;
  18. extern char buf[];
  19.  
  20. /* variables local to xldmem.c and xlimage.c */
  21. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  22. int anodes,nsegs,gccalls;
  23. long nnodes,nfree,total;
  24. LVAL fnodes;
  25.  
  26. /* external procedures */
  27.  
  28. /* forward declarations */
  29. #ifdef PROTOTYPES
  30. LOCAL(LVAL) newnode(int) ;
  31. LOCAL(unsigned char *) stralloc(int) ;
  32. LOCAL(int) addseg(void) ;
  33. LOCAL(void) findmem( void ) ;
  34. LOCAL(void) mark( LVAL ptr ) ;
  35. LOCAL(void) sweep( void ) ;
  36. LOCAL(void) stats( void ) ;
  37. #else
  38. FORWARD LVAL newnode();
  39. FORWARD unsigned char *stralloc();
  40. FORWARD SEGMENT *newsegment();
  41. FORWARD void findmem();
  42. FORWARD void mark();
  43. FORWARD void sweep();
  44. FORWARD void stats();
  45. #endif PROTOTYPES
  46.  
  47. /* cons - construct a new cons node */
  48. LVAL cons(x,y)
  49.   LVAL x,y;
  50. {
  51.     LVAL nnode;
  52.  
  53.     /* get a free node */
  54.     if ((nnode = fnodes) == NIL) {
  55.     xlstkcheck(2);
  56.     xlprotect(x);
  57.     xlprotect(y);
  58.     findmem();
  59.     if ((nnode = fnodes) == NIL)
  60.         xlabort("insufficient node space");
  61.     xlpop();
  62.     xlpop();
  63.     }
  64.  
  65.     /* unlink the node from the free list */
  66.     fnodes = cdr(nnode);
  67.     --nfree;
  68.  
  69.     /* initialize the new node */
  70.     nnode->n_type = CONS;
  71.     rplaca(nnode,x);
  72.     rplacd(nnode,y);
  73.  
  74.     /* return the new node */
  75.     return (nnode);
  76. }
  77.  
  78. /* cvstring - convert a string to a string node */
  79. LVAL cvstring(str)
  80.   char *str;
  81. {
  82.     LVAL val;
  83.     xlsave1(val);
  84.     val = newnode(STRING);
  85.     val->n_strlen = strlen(str) + 1;
  86.     val->n_string = stralloc(getslength(val));
  87.     strcpy(getstring(val),str);
  88.     xlpop();
  89.     return (val);
  90. }
  91.  
  92. /* newstring - allocate and initialize a new string */
  93. LVAL newstring(size)
  94.   int size;
  95. {
  96.     LVAL val;
  97.     xlsave1(val);
  98.     val = newnode(STRING);
  99.     val->n_strlen = size;
  100.     val->n_string = stralloc(getslength(val));
  101.     strcpy(getstring(val),"");
  102.     xlpop();
  103.     return (val);
  104. }
  105.  
  106. /* cvsymbol - convert a string to a symbol */
  107. LVAL cvsymbol(pname)
  108.   char *pname;
  109. {
  110.     LVAL val;
  111.     xlsave1(val);
  112.     val = newvector(SYMSIZE);
  113.     val->n_type = SYMBOL;
  114.     setvalue(val,s_unbound);
  115.     setfunction(val,s_unbound);
  116.     setpname(val,cvstring(pname));
  117.     xlpop();
  118.     return (val);
  119. }
  120.  
  121. /* cvsubr - convert a function to a subr or fsubr */
  122. LVAL cvsubr(fcn,type,offset)
  123.   LVAL (*fcn)(); int type,offset;
  124. {
  125.     LVAL val;
  126.     val = newnode(type);
  127.     val->n_subr = fcn;
  128.     val->n_offset = offset;
  129.     return (val);
  130. }
  131.  
  132. /* cvfile - convert a file pointer to a stream */
  133. LVAL cvfile(fp)
  134.   FILE *fp;
  135. {
  136.     LVAL val;
  137.     val = newnode(STREAM);
  138.     setfile(val,fp);
  139.     setsavech(val,'\0');
  140.     return (val);
  141. }
  142.  
  143. /* cvfixnum - convert an integer to a fixnum node */
  144. LVAL cvfixnum(n)
  145.   FIXTYPE n;
  146. {
  147.     LVAL val;
  148.     if (n >= SFIXMIN && n <= SFIXMAX)
  149.     return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  150.     val = newnode(FIXNUM);
  151.     val->n_fixnum = n;
  152.     return (val);
  153. }
  154.  
  155. /* cvflonum - convert a floating point number to a flonum node */
  156. LVAL cvflonum(n)
  157.   FLOTYPE n;
  158. {
  159.     LVAL val;
  160.     val = newnode(FLONUM);
  161.     val->n_flonum = n;
  162.     return (val);
  163. }
  164.  
  165. /* cvchar - convert an integer to a character node */
  166. LVAL cvchar(n)
  167.   int n;
  168. {
  169.     if (n >= CHARMIN && n <= CHARMAX)
  170.     return (&charseg->sg_nodes[n-CHARMIN]);
  171.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  172.     /* keep LINT happy by returning something */
  173.     return NIL ;
  174. }
  175.  
  176. /* newustream - create a new unnamed stream */
  177. LVAL newustream()
  178. {
  179.     LVAL val;
  180.     val = newnode(USTREAM);
  181.     sethead(val,NIL);
  182.     settail(val,NIL);
  183.     return (val);
  184. }
  185.  
  186. /* newobject - allocate and initialize a new object */
  187. LVAL newobject(cls,size)
  188.   LVAL cls; int size;
  189. {
  190.     LVAL val;
  191.     val = newvector(size+1);
  192.     val->n_type = OBJECT;
  193.     setelement(val,0,cls);
  194.     return (val);
  195. }
  196.  
  197. /* newclosure - allocate and initialize a new closure */
  198. LVAL newclosure(name,type,env,fenv)
  199.   LVAL name,type,env,fenv;
  200. {
  201.     LVAL val;
  202.     val = newvector(CLOSIZE);
  203.     val->n_type = CLOSURE;
  204.     setname(val,name);
  205.     settype(val,type);
  206.     setenv(val,env);
  207.     setfenv(val,fenv);
  208.     return (val);
  209. }
  210.  
  211. /* newvector - allocate and initialize a new vector node */
  212. LVAL newvector(size)
  213.   int size;
  214. {
  215.     LVAL vect;
  216.     int bsize;
  217.     xlsave1(vect);
  218.     vect = newnode(VECTOR);
  219.     vect->n_vsize = 0;
  220.     if (bsize = size * sizeof(LVAL)) {
  221.     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  222.         findmem();
  223.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  224.         xlfail("insufficient vector space");
  225.     }
  226.     vect->n_vsize = size;
  227.     total += (long) bsize;
  228.     }
  229.     xlpop();
  230.     return (vect);
  231. }
  232.  
  233. /* newnode - allocate a new node */
  234. LOCAL(LVAL) newnode(type)
  235.   int type;
  236. {
  237.     LVAL nnode;
  238.  
  239.     /* get a free node */
  240.     if ((nnode = fnodes) == NIL) {
  241.     findmem();
  242.     if ((nnode = fnodes) == NIL)
  243.         xlabort("insufficient node space");
  244.     }
  245.  
  246.     /* unlink the node from the free list */
  247.     fnodes = cdr(nnode);
  248.     nfree -= 1L;
  249.  
  250.     /* initialize the new node */
  251.     nnode->n_type = type;
  252.     rplacd(nnode,NIL);
  253.  
  254.     /* return the new node */
  255.     return (nnode);
  256. }
  257.  
  258. /* stralloc - allocate memory for a string adding a byte for the terminator */
  259. LOCAL(unsigned char *) stralloc(size)
  260.   int size;
  261. {
  262.     unsigned char *sptr;
  263.  
  264.     /* allocate memory for the string copy */
  265.     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
  266.     gc();  
  267.     if ((sptr = (unsigned char *)malloc(size)) == NULL)
  268.         xlfail("insufficient string space");
  269.     }
  270.     total += (long)size;
  271.  
  272.     /* return the new string memory */
  273.     return (sptr);
  274. }
  275.  
  276. /* findmem - find more memory by collecting then expanding */
  277. LOCAL(void) findmem()
  278. {
  279.     gc();
  280.     if (nfree < (long)anodes)
  281.     addseg();
  282. }
  283.  
  284. /* gc - garbage collect (only called here and in xlimage.c) */
  285. void gc()
  286. {
  287.     register LVAL **p,*ap,tmp;
  288.     char buf[STRMAX+1];
  289.     LVAL *newfp,fun;
  290.  
  291.     /* print the start of the gc message */
  292.     if (s_gcflag && getvalue(s_gcflag)) {
  293.     sprintf(buf,"[ gc: total %ld, ",nnodes);
  294.     stdputstr(buf);
  295.     }
  296.  
  297.     /* mark the obarray, the argument list and the current environment */
  298.     if (obarray)
  299.     mark(obarray);
  300.     if (xlenv)
  301.     mark(xlenv);
  302.     if (xlfenv)
  303.     mark(xlfenv);
  304.     if (xldenv)
  305.     mark(xldenv);
  306.  
  307.     /* mark the evaluation stack */
  308.     for (p = xlstack; p < xlstktop; ++p)
  309.     if (tmp = **p)
  310.         mark(tmp);
  311.  
  312.     /* mark the argument stack */
  313.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  314.     if (tmp = *ap)
  315.         mark(tmp);
  316.  
  317.     /* sweep memory collecting all unmarked nodes */
  318.     sweep();
  319.  
  320.     /* count the gc call */
  321.     ++gccalls;
  322.  
  323.     /* call the *gc-hook* if necessary */
  324.     if (s_gchook && (fun = getvalue(s_gchook))) {
  325.     newfp = xlsp;
  326.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  327.     pusharg(fun);
  328.     pusharg(cvfixnum((FIXTYPE)2));
  329.     pusharg(cvfixnum((FIXTYPE)nnodes));
  330.     pusharg(cvfixnum((FIXTYPE)nfree));
  331.     xlfp = newfp;
  332.     xlapply(2);
  333.     }
  334.  
  335.     /* print the end of the gc message */
  336.     if (s_gcflag && getvalue(s_gcflag)) {
  337.     sprintf(buf,"%ld free ]\n",nfree);
  338.     stdputstr(buf);
  339.     }
  340. }
  341.  
  342. /* mark - mark all accessible nodes */
  343. LOCAL(void) mark(ptr)
  344.   LVAL ptr;
  345. {
  346.     register LVAL this,prev,tmp;
  347.     int type,i,n;
  348.  
  349.     /* initialize */
  350.     prev = NIL;
  351.     this = ptr;
  352.  
  353.     /* mark this list */
  354.     for (;;) {
  355.  
  356.     /* descend as far as we can */
  357.     while (!(this->n_flags & MARK))
  358.  
  359.         /* check cons and symbol nodes */
  360.         if ((type = ntype(this)) == CONS) {
  361.         if (tmp = car(this)) {
  362.             this->n_flags |= MARK|LEFT;
  363.             rplaca(this,prev);
  364.         }
  365.         else if (tmp = cdr(this)) {
  366.             this->n_flags |= MARK;
  367.             rplacd(this,prev);
  368.         }
  369.         else {                /* both sides nil */
  370.             this->n_flags |= MARK;
  371.             break;
  372.         }
  373.         prev = this;            /* step down the branch */
  374.         this = tmp;
  375.         }
  376.  
  377.         /* mark other node types */
  378.         else {
  379.         this->n_flags |= MARK;
  380.         switch (type) {
  381.         case SYMBOL:
  382.         case OBJECT:
  383.         case VECTOR:
  384.         case CLOSURE:
  385.             for (i = 0, n = getsize(this); --n >= 0; ++i)
  386.             if (tmp = getelement(this,i))
  387.                 mark(tmp);
  388.             break;
  389.         }
  390.         break;
  391.         }
  392.  
  393.     /* backup to a point where we can continue descending */
  394.     for (;;)
  395.  
  396.         /* make sure there is a previous node */
  397.         if (prev) {
  398.         if (prev->n_flags & LEFT) {    /* came from left side */
  399.             prev->n_flags &= ~LEFT;
  400.             tmp = car(prev);
  401.             rplaca(prev,this);
  402.             if (this = cdr(prev)) {
  403.             rplacd(prev,tmp);            
  404.             break;
  405.             }
  406.         }
  407.         else {                /* came from right side */
  408.             tmp = cdr(prev);
  409.             rplacd(prev,this);
  410.         }
  411.         this = prev;            /* step back up the branch */
  412.         prev = tmp;
  413.         }
  414.  
  415.         /* no previous node, must be done */
  416.         else
  417.         return;
  418.     }
  419. }
  420.  
  421. /* sweep - sweep all unmarked nodes and add them to the free list */
  422. LOCAL(void) sweep()
  423. {
  424.     SEGMENT *seg;
  425.     LVAL p;
  426.     int n;
  427.  
  428.     /* empty the free list */
  429.     fnodes = NIL;
  430.     nfree = 0L;
  431.  
  432.     /* add all unmarked nodes */
  433.     for (seg = segs; seg; seg = seg->sg_next) {
  434.     if (seg == fixseg)     /* don't sweep the fixnum segment */
  435.         continue;
  436.     else if (seg == charseg) /* don't sweep the character segment */
  437.         continue;
  438.     p = &seg->sg_nodes[0];
  439.     for (n = seg->sg_size; --n >= 0; ++p)
  440.         if (!(p->n_flags & MARK)) {
  441.         switch (ntype(p)) {
  442.         case STRING:
  443.             if (getstring(p) != NULL) {
  444.                 total -= (long)getslength(p);
  445.                 free(getstring(p));
  446.             }
  447.             break;
  448.         case STREAM:
  449.             if (getfile(p))
  450.                 osclose(getfile(p));
  451.             break;
  452.         case SYMBOL:
  453.         case OBJECT:
  454.         case VECTOR:
  455.         case CLOSURE:
  456.             if (p->n_vsize) {
  457.                 total -= (long) (p->n_vsize * sizeof(LVAL));
  458.                 free(p->n_vdata);
  459.             }
  460.             break;
  461.         }
  462.         p->n_type = FREE;
  463.         rplaca(p,NIL);
  464.         rplacd(p,fnodes);
  465.         fnodes = p;
  466.         nfree += 1L;
  467.         }
  468.         else
  469.         p->n_flags &= ~MARK;
  470.     }
  471. }
  472.  
  473. /* addseg - add a segment to the available memory */
  474. LOCAL(int) addseg()
  475. {
  476.     SEGMENT *newseg;
  477.     LVAL p;
  478.     int n;
  479.  
  480.     /* allocate the new segment */
  481.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  482.     return (FALSE);
  483.  
  484.     /* add each new node to the free list */
  485.     p = &newseg->sg_nodes[0];
  486.     for (n = anodes; --n >= 0; ++p) {
  487.     rplacd(p,fnodes);
  488.     fnodes = p;
  489.     }
  490.  
  491.     /* return successfully */
  492.     return (TRUE);
  493. }
  494.  
  495. /* newsegment - create a new segment (only called here and in xlimage.c) */
  496. SEGMENT *newsegment(n)
  497.   int n;
  498. {
  499.     SEGMENT *newseg;
  500.  
  501.     /* allocate the new segment */
  502.     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
  503.     return (NULL);
  504.  
  505.     /* initialize the new segment */
  506.     newseg->sg_size = n;
  507.     newseg->sg_next = NULL;
  508.     if (segs)
  509.     lastseg->sg_next = newseg;
  510.     else
  511.     segs = newseg;
  512.     lastseg = newseg;
  513.  
  514.     /* update the statistics */
  515.     total += (long)segsize(n);
  516.     nnodes += (long)n;
  517.     nfree += (long)n;
  518.     ++nsegs;
  519.  
  520.     /* return the new segment */
  521.     return (newseg);
  522. }
  523.  
  524. /* stats - print memory statistics */
  525. LOCAL(void) stats()
  526. {
  527.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  528.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  529.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  530.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  531.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  532.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  533. }
  534.  
  535. /* xgc - xlisp function to force garbage collection */
  536. LVAL xgc()
  537. {
  538.     /* make sure there aren't any arguments */
  539.     xllastarg();
  540.  
  541.     /* garbage collect */
  542.     gc();
  543.  
  544.     /* return nil */
  545.     return (NIL);
  546. }
  547.  
  548. /* xexpand - xlisp function to force memory expansion */
  549. LVAL xexpand()
  550. {
  551.     LVAL num;
  552.     int n,i;
  553.  
  554.     /* get the new number to allocate */
  555.     if (moreargs()) {
  556.     num = xlgafixnum();
  557.     n = (int) getfixnum(num);
  558.     }
  559.     else
  560.     n = 1;
  561.     xllastarg();
  562.  
  563.     /* allocate more segments */
  564.     for (i = 0; i < n; i++)
  565.     if (!addseg())
  566.         break;
  567.  
  568.     /* return the number of segments added */
  569.     return (cvfixnum((FIXTYPE)i));
  570. }
  571.  
  572. /* xalloc - xlisp function to set the number of nodes to allocate */
  573. LVAL xalloc()
  574. {
  575.     int n,oldn;
  576.     LVAL num;
  577.  
  578.     /* get the new number to allocate */
  579.     num = xlgafixnum();
  580.     n = (int) getfixnum(num);
  581.  
  582.     /* make sure there aren't any more arguments */
  583.     xllastarg();
  584.  
  585.     /* set the new number of nodes to allocate */
  586.     oldn = anodes;
  587.     anodes = n;
  588.  
  589.     /* return the old number */
  590.     return (cvfixnum((FIXTYPE)oldn));
  591. }
  592.  
  593. /* xmem - xlisp function to print memory statistics */
  594. LVAL xmem()
  595. {
  596.     /* allow one argument for compatiblity with common lisp */
  597.     if (moreargs()) xlgetarg();
  598.     xllastarg();
  599.  
  600.     /* print the statistics */
  601.     stats();
  602.  
  603.     /* return nil */
  604.     return (NIL);
  605. }
  606.  
  607. #ifdef SAVERESTORE
  608. /* xsave - save the memory image */
  609. LVAL xsave()
  610. {
  611.     unsigned char *name;
  612.  
  613.     /* get the file name, verbose flag and print flag */
  614.     name = getstring(xlgetfname());
  615.     xllastarg();
  616.  
  617.     /* save the memory image */
  618.     return (xlisave(name) ? true : NIL);
  619. }
  620.  
  621. /* xrestore - restore a saved memory image */
  622. LVAL xrestore()
  623. {
  624.     extern jmp_buf top_level;
  625.     unsigned char *name;
  626.  
  627.     /* get the file name, verbose flag and print flag */
  628.     name = getstring(xlgetfname());
  629.     xllastarg();
  630.  
  631.     /* restore the saved memory image */
  632.     if (!xlirestore(name))
  633.     return (NIL);
  634.  
  635.     /* return directly to the top level */
  636.     stdputstr("[ returning to the top level ]\n");
  637.     longjmp(top_level,1);
  638.     /* keep LINT happy by returning something, even though never reached */
  639.     return NIL ;
  640. }
  641. #endif
  642.  
  643. /* xlminit - initialize the dynamic memory module */
  644. void xlminit()
  645. {
  646.     LVAL p;
  647.     int i;
  648.  
  649.     /* initialize our internal variables */
  650.     segs = lastseg = NULL;
  651.     nnodes = nfree = total = 0L;
  652.     nsegs = gccalls = 0;
  653.     anodes = NNODES;
  654.     fnodes = NIL;
  655.  
  656.     /* allocate the fixnum segment */
  657.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  658.     xlfatal("insufficient memory");
  659.  
  660.     /* initialize the fixnum segment */
  661.     p = &fixseg->sg_nodes[0];
  662.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  663.     p->n_type = FIXNUM;
  664.     p->n_fixnum = i;
  665.     ++p;
  666.     }
  667.  
  668.     /* allocate the character segment */
  669.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  670.     xlfatal("insufficient memory");
  671.  
  672.     /* initialize the character segment */
  673.     p = &charseg->sg_nodes[0];
  674.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  675.     p->n_type = CHAR;
  676.     p->n_chcode = i;
  677.     ++p;
  678.     }
  679.  
  680.     /* initialize structures that are marked by the collector */
  681.     obarray = xlenv = xlfenv = xldenv = NIL;
  682.     s_gcflag = s_gchook = NIL;
  683.  
  684.     /* allocate the evaluation stack */
  685.     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
  686.     xlfatal("insufficient memory");
  687.     xlstack = xlstktop = xlstkbase + EDEPTH;
  688.  
  689.     /* allocate the argument stack */
  690.     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
  691.     xlfatal("insufficient memory");
  692.     xlargstktop = xlargstkbase + ADEPTH;
  693.     xlfp = xlsp = xlargstkbase;
  694.     *xlsp++ = NIL;
  695. }
  696.  
  697.