home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Fmemmon < prev    next >
Encoding:
Text File  |  1990-07-19  |  13.8 KB  |  590 lines
  1. /*
  2.  *  fxmemmon.c -- mmout, mmpause, mmshow, and internal functions.
  3.  *
  4.  *   This file contains memory monitoring code.  It is compiled by inclusion
  5.  *   in fxtra.c if MemMon is defined.  When MemMon is undefined, most of the
  6.  *   "MMxxxx" entry points are defined as null macros in rt.h.
  7.  */
  8.  
  9. #include "../h/config.h"
  10. #include "../h/rt.h"
  11. #include "rproto.h"
  12.  
  13.  
  14.  
  15. #ifdef MemMon
  16. /*
  17.  * Prototypes.
  18.  */
  19.  
  20. hidden    novalue mmcmd        Params((word addr, word len, int c));
  21. hidden    novalue mmdec        Params((uword n));
  22. hidden    novalue mmforget    Params((noargs));
  23. hidden    novalue mmlen        Params((word n, int c));
  24. hidden    novalue mmnewline    Params((noargs));
  25. hidden    novalue mmrefresh    Params((noargs));
  26. hidden    novalue mmsizes        Params((int c));
  27. hidden    novalue mmstatic    Params((noargs));
  28. hidden    novalue MMOut        Params((char *prefix, char *msg));
  29.  
  30. static FILE *monfile = NULL;    /* output file pointer */
  31. static char *monname = NULL;    /* output file name */
  32.  
  33. static word llen = 0;        /* current output line length */
  34.  
  35. static char typech[MaxType+1];    /* output character for each type */
  36.  
  37. /* Define size of curlength table, and bias needed to access it. */
  38. /* Assumes all type codes are printable characters (or space).   */
  39. /* Smaller table is used if not EBCDIC.                          */
  40. #if !EBCDIC
  41. #define CurSize (127 - ' ')
  42. #define CurBias ' '
  43. #else                    /* !EBCDIC */
  44. #define CurSize 256
  45. #define CurBias 0
  46. #endif                    /* !EBCDIC */
  47.  
  48. static word curlength[CurSize];    /* current length for each output character */
  49.  
  50. /* line limit: start a new line when a command goes beyond this column */
  51. #define LLIM 70
  52.  
  53. /* mmchar(c): output character c and update the column counter */
  54. #define mmchar(c) (llen++,putc((c),monfile))
  55.  
  56. /* mmspace(): output unneeded whitespace whitespace following a command */
  57. /*  define as "mmchar(' ')" for readable files, or as "0" for compact ones */
  58. #define mmspace() 0
  59.  
  60. /*
  61.  * mmout(s) - write the given string to the MemMon file.
  62.  */
  63.  
  64. FncDcl(mmout,1)
  65.    {
  66.    char sbuf[MaxCvtLen];
  67.    int t;
  68.  
  69.    if ((t = defstr(&Arg1, sbuf, &emptystr)) == Error) 
  70.       RunErr(0, NULL);
  71.    /*
  72.     * Make sure Arg1 is a C-style string.
  73.     */
  74.    if (t == NoCvt)
  75.       qtos(&Arg1, sbuf);
  76.    MMOut("", StrLoc(Arg1));
  77.    Arg0 = nulldesc;
  78.    Return;
  79.    }
  80.  
  81. /*
  82.  * mmpause(s) - pause MemMon displaying string s.
  83.  */
  84.  
  85. FncDcl(mmpause,1)
  86.    {
  87.    char sbuf[MaxCvtLen];
  88.    int t;
  89.  
  90.    if ((t = defstr(&Arg1, sbuf, &emptystr)) == Error) 
  91.       RunErr(0, NULL);
  92.    if (StrLen(Arg1) == 0)
  93.       MMOut("; ", "programmed pause");
  94.    else {
  95.       /*
  96.        * Make sure Arg1 is a C-style string.
  97.        */
  98.       if (t == NoCvt)
  99.          qtos(&Arg1, sbuf);
  100.       MMOut("; ", StrLoc(Arg1));
  101.       }
  102.    Arg0 = nulldesc;
  103.    Return;
  104.    }
  105.  
  106. /*
  107.  * mmshow(x, s) - alter MemMon display of x depending on s.
  108.  */
  109.  
  110. FncDcl(mmshow,2)
  111.    {
  112.    char sbuf[MaxCvtLen];
  113.  
  114.    /*
  115.     * Default Arg2 to the empty string and make sure it is a C-style string.
  116.     */
  117.    switch (defstr(&Arg2, sbuf, &emptystr)) {
  118.  
  119.       case Cvt:   /* Already converted to a C-style string */
  120.          break;
  121.  
  122.       case Defaulted:
  123.       case NoCvt:
  124.          qtos(&Arg2, sbuf);
  125.          break;
  126.  
  127.       case Error:
  128.          RunErr(0, NULL);
  129.       }
  130.  
  131.    MMShow(&Arg1, StrLoc(Arg2));
  132.    Arg0 = nulldesc;
  133.    Return;
  134.    }
  135.  
  136. /*
  137.  * MMInit(filename) - initialization.
  138.  *
  139.  *  Memory monitoring is activated if the environment variable MEMMON is
  140.  *  non-null.  Its value names the output file;  or, under Unix and on the
  141.  *  Archimedes, a value beginning with "|" specifies a command to which the
  142.  *  output is piped.
  143.  *
  144.  *  If MemMon is defined on a system lacking environment variables,
  145.  *  monitoring is always activated and output is to the file "memmon.out".
  146.  */
  147.  
  148. novalue MMInit(filename)
  149. char *filename;
  150.    {
  151.    int i;
  152.    FILE *f;
  153.    char time_buf[26];
  154.  
  155. #ifdef EnvVars
  156.    monname = getenv(MEMMON);
  157.    if (monname == NULL || strlen(monname) == 0)
  158.       return;
  159. #else                    /* EnvVars */
  160.    monname = "memmon.out";
  161. #endif                    /* EnvVars */
  162.  
  163. #if ARM || UNIX
  164.    if (monname[0] == '|')
  165.       f = popen(monname+1, WriteText);
  166.    else
  167. #endif                    /* ARM || UNIX */
  168.  
  169.       f = fopen(monname, WriteText);
  170.  
  171.    if (f == NULL) {
  172.       fprintf(stderr, "MEMMON: cannot open %s\n", monname);
  173.       fflush(stderr);
  174.       exit(ErrorExit);
  175.       }
  176.  
  177.  
  178.    getctime(time_buf);
  179.    fprintf(f, "##  Icon MemMon output\n");
  180.    fprintf(f, "#\n");
  181.    fprintf(f, "#   program: %s\n", filename);
  182.    fprintf(f, "#   date:    %s\n", time_buf);
  183.  
  184.    for (i = 0; i <= MaxType; i++)
  185.       typech[i] = '?';    /* initialize with error character */
  186.  
  187. #ifdef LargeInts
  188.    typech[T_Bignum]  = 'i';    /* long integer */
  189. #endif                    /* LargeInts */
  190.  
  191.    typech[T_Real]    = 'r';    /* real number */
  192.    typech[T_Cset]    = 'c';    /* cset */
  193.    typech[T_File]    = 'f';    /* file block */
  194.    typech[T_Record]  = 'R';    /* record block */
  195.    typech[T_Tvsubs]  = 'u';    /* substring trapped variable */
  196.    typech[T_External]= 'E';    /* external block */
  197.  
  198.    typech[T_List]    = 'L';    /* list header block */
  199.    typech[T_Lelem]   = 'l';    /* list element block */
  200.  
  201.    typech[T_Table]   = 'T';    /* table header block */
  202.    typech[T_Telem]   = 't';    /* table element block */
  203.    typech[T_Tvtbl]   = 'e';    /* table elem trapped variable*/
  204.  
  205.    typech[T_Set]     = 'S';    /* set header block */
  206.    typech[T_Selem]   = 's';    /* set element block */
  207.  
  208.    typech[T_Slots]   = 'h';    /* set/table hash slots */
  209.  
  210.    typech[T_Coexpr]  = 'X';    /* co-expression block (static region) */
  211.    typech[T_Refresh] = 'x';    /* co-expression refresh block */
  212.  
  213.    /*
  214.     * codes used elsewhere but not shown here:
  215.     *    in the static region: 'A' = alien (malloc block), 'F' = free
  216.     *    in the string region: '"' = string
  217.     */
  218.  
  219.    /*
  220.     * Set monfile to indicate that memmon is active.  Don't set it earlier
  221.     * than this, or we'll loop trying to trace the garbage collection that
  222.     * creates the buffer space.
  223.     */
  224.    monfile = f;
  225.    mmrefresh();            /* show current state */
  226.    fflush(monfile);        /* force it out */
  227.    }
  228.  
  229. /*
  230.  * MMTerm(part1, part2) - terminate memory monitoring.
  231.  *  part1 and part2 are concatentated to form an explanatory message.
  232.  */
  233.  
  234. novalue MMTerm(part1, part2)
  235. char *part1, *part2;
  236.    {
  237.    FILE *f;
  238.  
  239.    if (monfile == NULL)
  240.       return;
  241.    mmnewline();
  242.    mmsizes('=');        /* make a final check on region sizes */
  243.  
  244.    if (*part1 || *part2)    /* if any reason given, write it as comment */
  245.       fprintf(monfile, "# %s%s\n", part1, part2);
  246.  
  247.    f = monfile;
  248.    monfile = NULL;    /* so we don't try to show the freeing of the buffer */
  249.  
  250. #if ARM || UNIX
  251.    if (monname[0] == '|')
  252.       pclose(f);
  253.    else
  254. #endif                    /* ARM || UNIX */
  255.       fclose(f);
  256.    }
  257.  
  258. /*
  259.  * MMStat(a, n, c) - note static block at a, length n, represented by char 'c'.
  260.  * Output values are in basic units (typically words).
  261.  */
  262. novalue MMStat(a, n, c)
  263. char *a;
  264. word n;
  265. int c;
  266.    {
  267. #ifndef FixedRegions
  268.    if (monfile == NULL)
  269.       return;
  270.    mmcmd(DiffPtrs(a, statbase) / MMUnits, n / MMUnits, c);
  271. #endif                    /* FixedRegions */
  272.    }
  273.  
  274. /*
  275.  * MMAlc(len, type) - note an allocation at the end of the block region.
  276.  */
  277.  
  278. novalue MMAlc(len, type)
  279. word len;
  280. int type;
  281.    {
  282.    if (monfile == NULL)
  283.       return;
  284.    mmcmd((word)(-1), len / MMUnits, typech[type]);
  285.    }
  286.  
  287. /*
  288.  * MMStr(len) - note a string allocation at the end of the string region.
  289.  */
  290.  
  291. novalue MMStr(slen)
  292. word slen;
  293.    {
  294.    if (monfile == NULL)
  295.       return;
  296.    mmcmd((word)(-1), slen, '"');
  297.    }
  298.  
  299. /*
  300.  * MMBGC() - begin garbage collection.
  301.  */
  302.  
  303. novalue MMBGC(region)
  304. int region;
  305.    {
  306.    if (monfile == NULL)
  307.       return;
  308.    mmsizes('=');            /* write current sizes */
  309.    fprintf(monfile, "%d{\n", region);    /* indicate start of g.c. */
  310.    fflush(monfile);
  311.    mmforget();                /* clear memory of block sizes */
  312.    }
  313.  
  314. /*
  315.  * MMEGC() - end garbage collection.
  316.  */
  317.  
  318. novalue MMEGC()
  319.    {
  320.    if (monfile == NULL)
  321.       return;
  322.    mmnewline();
  323.    fprintf(monfile, "}\n");    /* indicate end of marking */
  324.    mmrefresh();            /* redraw regions after compaction */
  325.    fprintf(monfile, "!\n");    /* indicate end of g.c. */
  326.    fflush(monfile);
  327.    }
  328.  
  329. /*
  330.  * MMMark(block, type) - mark indicated block during garbage collection.
  331.  */
  332.  
  333. novalue MMMark(block, type)
  334. char *block;
  335. int type;
  336.    {
  337.    if (monfile == NULL)
  338.       return;
  339.    mmcmd(DiffPtrs(block, blkbase) / MMUnits, (word)BlkSize(block) / MMUnits,
  340.       typech[type]);
  341.    }
  342.  
  343. /*
  344.  * MMSMark - Mark String.
  345.  */
  346.  
  347. novalue MMSMark(saddr, slen)
  348. char *saddr;
  349. word slen;
  350.    {
  351.    if (monfile == NULL)
  352.       return;
  353.    mmcmd(DiffPtrs(saddr, strbase), slen, '"');
  354.    }
  355.  
  356. /*
  357.  * MMOut(prefix, msg) - write the prefix and message to the MemMon output file.
  358.  */
  359.  
  360. static novalue MMOut(prefix, msg)
  361. char *prefix, *msg;
  362.    {
  363.    if (monfile == NULL)
  364.       return;
  365.    mmnewline();
  366.    fprintf(monfile, "%s%s\n", prefix, msg);
  367.    }
  368.  
  369. /*
  370.  * MMShow(d, s) - redraw block indicated by descriptor d according to flags
  371.  *  in s.
  372.  */
  373.  
  374. novalue MMShow(d, s)
  375. dptr d;
  376. char *s;
  377.    {
  378.    char *block;
  379.    uword addr;
  380.    word len;
  381.    char cmd, tch;
  382.  
  383.    if (monfile == NULL)
  384.       return;
  385.    if (Qual(*d)) {
  386.       /*
  387.        *  Show a string.
  388.        */
  389. /*
  390.       if ((uword)StrLoc(*d)<(uword)strbase || (uword)StrLoc(*d)>=(uword)strend)
  391. */
  392.       if (!InRange(strbase,StrLoc(*d),strend))
  393.          return;    /* ignore if outside string region */
  394.       addr = DiffPtrs(StrLoc(*d), strbase);
  395.       len = StrLen(*d);
  396.       cmd = '$';
  397.       tch = '"';
  398.       }
  399.    else if (Type(*d)==T_Coexpr) {
  400.       /*
  401.        *  Show a coexpression block, which will be in the static region.
  402.        */
  403.       block = (char *)BlkLoc(*d);
  404.       addr = DiffPtrs(block, statbase) / MMUnits;
  405.       len = BlkSize(block) / MMUnits;
  406.       cmd = 'Y';
  407.       tch = typech[T_Coexpr];
  408.       }
  409.    else if (Pointer(*d)) {
  410.       /*
  411.        *  Show something in the block region.
  412.        */
  413.       block = (char *)BlkLoc(*d);
  414. /*
  415.       if ((uword)block < (uword)blkbase || (uword)block >= (uword)blkfree)
  416. */
  417.       if (!InRange(blkbase,block,blkfree))
  418.          return;    /* ignore if outside block region */
  419.       addr = DiffPtrs(block, blkbase) / MMUnits;
  420.       len = BlkSize(block) / MMUnits;
  421.       cmd = '%';
  422.       tch = typech[Type(*d)];
  423.       }
  424.  
  425.    mmdec(addr);            /* address */
  426.    mmchar('+');
  427.    mmlen(len, cmd);        /* length, and $ Y or % command */
  428.    if (s && *s)
  429.       mmchar(*s);        /* color flag from mmshow call */
  430.    else 
  431.       mmchar('r');        /* default color is 'r' (redraw) */
  432.    mmchar(tch);            /* block type character */
  433.    if (llen >= LLIM)
  434.       mmnewline();
  435.    else
  436.       mmspace();
  437.    }
  438.  
  439. /*
  440.  * mmrefresh() - redraw screen, initially or after garbage collection.
  441.  */
  442.  
  443. static novalue mmrefresh()
  444.    {
  445.    char *p;
  446.    word n;
  447.  
  448.    mmnewline();
  449.    mmsizes('<');            /* signal start of screen refresh */
  450.    mmnewline();
  451.    mmforget();                /* clear memory of past sizes */
  452.    mmstatic();                /* show the static region */
  453.    mmnewline();
  454.    for (p = blkbase; p < blkfree; p += n)
  455.       MMAlc(n = BlkSize(p), (int)BlkType(p));/* block region */
  456.    mmnewline();
  457.    MMStr(DiffPtrs(strfree, strbase));    /* string region */
  458.    mmnewline();
  459.    fprintf(monfile, ">\n");        /* signal end of refresh */
  460.    mmsizes('=');            /* confirm region sizes */
  461.    mmforget();                /* clear memory of past sizes */
  462.    }
  463.  
  464. /*
  465.  *  mmstatic() - recap the static region (stack, coexprs, aliens, free)
  466.  *   (this function is empty under FixedRegions)
  467.  */
  468. static novalue mmstatic()
  469.    {
  470. #ifndef FixedRegions
  471.    HEADER *p;
  472.    char *a;
  473.    int h;
  474.    word n;
  475.  
  476.    for (p = (HEADER *)statbase; (uword)p < (uword)(HEADER *)statfree;
  477.       p += p->s.bsize) {
  478.          a = (char *)(p + 1);
  479.          n = (p->s.bsize - 1) * sizeof(HEADER);
  480.          h = *(int *)a;
  481.          if (h == T_Coexpr || a == (char *)stack)
  482.             MMStat(a, n, 'X');        /* coexpression block */
  483.          else if (h == FREEMAGIC)
  484.             MMStat(a, n, 'F');        /* free block */
  485.          else
  486.             MMStat(a, n, 'A');        /* alien block */
  487.          }
  488.    a = (char *)p;
  489.    if (a < statend)
  490.       MMStat(a, (word)(statend-a), 'F');/* rest of static region is free */
  491. #endif                    /* FixedRegions */
  492.    }
  493.  
  494. /*
  495.  * mmsizes(c) - output current region sizes, with initial character c.
  496.  * If c is '<', the unit size is written ahead of it.
  497.  */
  498. static novalue mmsizes(c)
  499. int c;
  500.    {
  501.    mmnewline();
  502.    if (c == '<')
  503.       fprintf(monfile, "%d", MMUnits);
  504.    fprintf(monfile, "%c %lu:%lu/%lu %lu:%lu/%lu %lu:%lu/%lu\n", c,
  505.       /* static region; show as full, actual amount is unknown */
  506.       (unsigned long)statbase,
  507.       (unsigned long)DiffPtrs(statend, statbase),
  508.       (unsigned long)DiffPtrs(statend, statbase),
  509.       /* string region */
  510.       (unsigned long)strbase,
  511.       (unsigned long)DiffPtrs(strfree, strbase),
  512.       (unsigned long)DiffPtrs(strend, strbase),
  513.       /* block region */
  514.       (unsigned long)blkbase,
  515.       (unsigned long)DiffPtrs(blkfree, blkbase),
  516.       (unsigned long)DiffPtrs(blkend, blkbase));
  517.    }
  518.  
  519. /*
  520.  * mmcmd(addr, len, c) - output a memmon command.
  521.  *  If addr is < 0, it is omitted.
  522.  *  If len matches the previous value for command c, it is also omitted.
  523.  *  If the output fills the line, a following newline is written.
  524.  */
  525.  
  526. static novalue mmcmd(addr, len, c)
  527. word addr, len;
  528. int c;
  529.    {
  530.    if (addr >= 0) {
  531.       mmdec((uword)addr);
  532.       mmchar('+');
  533.       }
  534.    mmlen(len, c);
  535.    if (llen >= LLIM)
  536.       mmnewline();
  537.    else
  538.       mmspace();
  539.    }
  540.  
  541. /*
  542.  * mmlen(n, c) - output length n with character c.
  543.  * Omit the length if it matches the previous value for c.
  544.  */
  545. static novalue mmlen(n, c)
  546. word n;
  547. int c;
  548.    {
  549.    if (n != curlength[c-CurBias])
  550.       mmdec((uword)(curlength[c-CurBias] = n));
  551.    mmchar(c); 
  552.    }
  553.  
  554. /*
  555.  * mmdec(n) - output a decimal value, updating the line length.
  556.  */
  557. static novalue mmdec (n)
  558. uword n;
  559.    {
  560.    if (n > 9)
  561.       mmdec(n / 10);
  562.    n %= 10;
  563.    mmchar('0'+(int)n);
  564.    }
  565.  
  566. /*
  567.  * mmnewline() - output a newline and reset the line length.
  568.  */
  569. static novalue mmnewline()
  570.    {
  571.    if (llen > 0)  {
  572.       putc('\n', monfile);
  573.       llen = 0;
  574.       }
  575.    }
  576.  
  577. /*
  578.  * mmforget() - clear the history of remembered lengths.
  579.  */
  580. static novalue mmforget()
  581.    {
  582.    int c;
  583.  
  584.    for (c = 0; c < CurSize; c++)
  585.       curlength[c] = -1;
  586.    }
  587. #else                    /* MemMon */
  588. static char x;            /* avoid empty module */
  589. #endif                    /* MemMon */
  590.