/*
 *  fxmemmon.c -- mmout, mmpause, mmshow, and internal functions.
 *
 *   This file contains memory monitoring code.  It is compiled by inclusion
 *   in fxtra.c if MemMon is defined.  When MemMon is undefined, most of the
 *   "MMxxxx" entry points are defined as null macros in rt.h.
 */

#include "..\h\config.h"
#include "..\h\rt.h"
#include "rproto.h"



#ifdef MemMon
/*
 * Prototypes.
 */

hidden	novalue mmcmd		Params((word addr, word len, int c));
hidden	novalue mmdec		Params((uword n));
hidden	novalue mmforget	Params((noargs));
hidden	novalue mmlen		Params((word n, int c));
hidden	novalue mmnewline	Params((noargs));
hidden	novalue mmrefresh	Params((noargs));
hidden	novalue mmsizes		Params((int c));
hidden	novalue mmstatic	Params((noargs));
hidden	novalue MMOut		Params((char *prefix, char *msg));

static FILE *monfile = NULL;	/* output file pointer */
static char *monname = NULL;	/* output file name */

static word llen = 0;		/* current output line length */

static char typech[MaxType+1];	/* output character for each type */

/* Define size of curlength table, and bias needed to access it. */
/* Assumes all type codes are printable characters (or space).   */
/* Smaller table is used if not EBCDIC.                          */
#if !EBCDIC
#define CurSize (127 - ' ')
#define CurBias ' '
#else					/* !EBCDIC */
#define CurSize 256
#define CurBias 0
#endif					/* !EBCDIC */

static word curlength[CurSize];	/* current length for each output character */

/* line limit: start a new line when a command goes beyond this column */
#define LLIM 70

/* mmchar(c): output character c and update the column counter */
#define mmchar(c) (llen++,putc((c),monfile))

/* mmspace(): output unneeded whitespace whitespace following a command */
/*  define as "mmchar(' ')" for readable files, or as "0" for compact ones */
#define mmspace() 0

/*
 * mmout(s) - write the given string to the MemMon file.
 */

FncDcl(mmout,1)
   {
   char sbuf[MaxCvtLen];
   int t;

   if ((t = defstr(&Arg1, sbuf, &emptystr)) == Error) 
      RunErr(0, NULL);
   /*
    * Make sure Arg1 is a C-style string.
    */
   if (t == NoCvt)
      qtos(&Arg1, sbuf);
   MMOut("", StrLoc(Arg1));
   Arg0 = nulldesc;
   Return;
   }

/*
 * mmpause(s) - pause MemMon displaying string s.
 */

FncDcl(mmpause,1)
   {
   char sbuf[MaxCvtLen];
   int t;

   if ((t = defstr(&Arg1, sbuf, &emptystr)) == Error) 
      RunErr(0, NULL);
   if (StrLen(Arg1) == 0)
      MMOut("; ", "programmed pause");
   else {
      /*
       * Make sure Arg1 is a C-style string.
       */
      if (t == NoCvt)
         qtos(&Arg1, sbuf);
      MMOut("; ", StrLoc(Arg1));
      }
   Arg0 = nulldesc;
   Return;
   }

/*
 * mmshow(x, s) - alter MemMon display of x depending on s.
 */

FncDcl(mmshow,2)
   {
   char sbuf[MaxCvtLen];

   /*
    * Default Arg2 to the empty string and make sure it is a C-style string.
    */
   switch (defstr(&Arg2, sbuf, &emptystr)) {

      case Cvt:   /* Already converted to a C-style string */
         break;

      case Defaulted:
      case NoCvt:
         qtos(&Arg2, sbuf);
         break;

      case Error:
         RunErr(0, NULL);
      }

   MMShow(&Arg1, StrLoc(Arg2));
   Arg0 = nulldesc;
   Return;
   }

/*
 * MMInit(filename) - initialization.
 *
 *  Memory monitoring is activated if the environment variable MEMMON is
 *  non-null.  Its value names the output file;  or, under Unix, a value
 *  beginning with "|" specifies a command to which the output is piped.
 *
 *  If MemMon is defined on a system lacking environment variables,
 *  monitoring is always activated and output is to the file "memmon.out".
 */

novalue MMInit(filename)
char *filename;
   {
   int i;
   FILE *f;
   char time_buf[26];

#ifdef EnvVars
   monname = getenv("MEMMON");
   if (monname == NULL || strlen(monname) == 0)
      return;
#else					/* EnvVars */
   monname = "memmon.out";
#endif					/* EnvVars */

#if UNIX
   if (monname[0] == '|')
      f = popen(monname+1, WriteText);
   else
#endif					/* UNIX */

      f = fopen(monname, WriteText);

   if (f == NULL) {
      fprintf(stderr, "MEMMON: cannot open %s\n", monname);
      fflush(stderr);
      exit(ErrorExit);
      }


   getctime(time_buf);
   fprintf(f, "##  Icon MemMon output\n");
   fprintf(f, "#\n");
   fprintf(f, "#   program: %s\n", filename);
   fprintf(f, "#   date:    %s\n", time_buf);

   for (i = 0; i <= MaxType; i++)
      typech[i] = '?';	/* initialize with error character */

#ifdef LargeInts
   typech[T_Bignum]  = 'i';	/* long integer */
#endif					/* LargeInts */

   typech[T_Real]    = 'r';	/* real number */
   typech[T_Cset]    = 'c';	/* cset */
   typech[T_File]    = 'f';	/* file block */
   typech[T_Record]  = 'R';	/* record block */
   typech[T_Tvsubs]  = 'u';	/* substring trapped variable */
   typech[T_External]= 'E';	/* external block */

   typech[T_List]    = 'L';	/* list header block */
   typech[T_Lelem]   = 'l';	/* list element block */

   typech[T_Table]   = 'T';	/* table header block */
   typech[T_Telem]   = 't';	/* table element block */
   typech[T_Tvtbl]   = 'e';	/* table elem trapped variable*/

   typech[T_Set]     = 'S';	/* set header block */
   typech[T_Selem]   = 's';	/* set element block */

   typech[T_Slots]   = 'h';	/* set/table hash slots */

   typech[T_Coexpr]  = 'X';	/* co-expression block (static region) */
   typech[T_Refresh] = 'x';	/* co-expression refresh block */

   /*
    * codes used elsewhere but not shown here:
    *    in the static region: 'A' = alien (malloc block), 'F' = free
    *    in the string region: '"' = string
    */

   /*
    * Set monfile to indicate that memmon is active.  Don't set it earlier
    * than this, or we'll loop trying to trace the garbage collection that
    * creates the buffer space.
    */
   monfile = f;
   mmrefresh();			/* show current state */
   fflush(monfile);		/* force it out */
   }

/*
 * MMTerm(part1, part2) - terminate memory monitoring.
 *  part1 and part2 are concatentated to form an explanatory message.
 */

novalue MMTerm(part1, part2)
char *part1, *part2;
   {
   FILE *f;

   if (monfile == NULL)
      return;
   mmnewline();
   mmsizes('=');		/* make a final check on region sizes */

   if (*part1 || *part2)	/* if any reason given, write it as comment */
      fprintf(monfile, "# %s%s\n", part1, part2);

   f = monfile;
   monfile = NULL;	/* so we don't try to show the freeing of the buffer */

#if UNIX
   if (monname[0] == '|')
      pclose(f);
   else
#endif					/* UNIX */
      fclose(f);
   }

/*
 * MMStat(a, n, c) - note static block at a, length n, represented by char 'c'.
 * Output values are in basic units (typically words).
 */
novalue MMStat(a, n, c)
char *a;
word n;
int c;
   {
#ifndef FixedRegions
   if (monfile == NULL)
      return;
   mmcmd(DiffPtrs(a, statbase) / MMUnits, n / MMUnits, c);
#endif					/* FixedRegions */
   }

/*
 * MMAlc(len, type) - note an allocation at the end of the block region.
 */

novalue MMAlc(len, type)
word len;
int type;
   {
   if (monfile == NULL)
      return;
   mmcmd((word)(-1), len / MMUnits, typech[type]);
   }

/*
 * MMStr(len) - note a string allocation at the end of the string region.
 */

novalue MMStr(slen)
word slen;
   {
   if (monfile == NULL)
      return;
   mmcmd((word)(-1), slen, '"');
   }

/*
 * MMBGC() - begin garbage collection.
 */

novalue MMBGC(region)
int region;
   {
   if (monfile == NULL)
      return;
   mmsizes('=');			/* write current sizes */
   fprintf(monfile, "%d{\n", region);	/* indicate start of g.c. */
   fflush(monfile);
   mmforget();				/* clear memory of block sizes */
   }

/*
 * MMEGC() - end garbage collection.
 */

novalue MMEGC()
   {
   if (monfile == NULL)
      return;
   mmnewline();
   fprintf(monfile, "}\n");	/* indicate end of marking */
   mmrefresh();			/* redraw regions after compaction */
   fprintf(monfile, "!\n");	/* indicate end of g.c. */
   fflush(monfile);
   }

/*
 * MMMark(block, type) - mark indicated block during garbage collection.
 */

novalue MMMark(block, type)
char *block;
int type;
   {
   if (monfile == NULL)
      return;
   mmcmd(DiffPtrs(block, blkbase) / MMUnits, (word)BlkSize(block) / MMUnits,
      typech[type]);
   }

/*
 * MMSMark - Mark String.
 */

novalue MMSMark(saddr, slen)
char *saddr;
word slen;
   {
   if (monfile == NULL)
      return;
   mmcmd(DiffPtrs(saddr, strbase), slen, '"');
   }

/*
 * MMOut(prefix, msg) - write the prefix and message to the MemMon output file.
 */

static novalue MMOut(prefix, msg)
char *prefix, *msg;
   {
   if (monfile == NULL)
      return;
   mmnewline();
   fprintf(monfile, "%s%s\n", prefix, msg);
   }

/*
 * MMShow(d, s) - redraw block indicated by descriptor d according to flags
 *  in s.
 */

novalue MMShow(d, s)
dptr d;
char *s;
   {
   char *block;
   uword addr;
   word len;
   char cmd, tch;

   if (monfile == NULL)
      return;
   if (Qual(*d)) {
      /*
       *  Show a string.
       */
/*
      if ((uword)StrLoc(*d)<(uword)strbase || (uword)StrLoc(*d)>=(uword)strend)
*/
      if (!InRange(strbase,StrLoc(*d),strend))
         return;	/* ignore if outside string region */
      addr = DiffPtrs(StrLoc(*d), strbase);
      len = StrLen(*d);
      cmd = '$';
      tch = '"';
      }
   else if (Type(*d)==T_Coexpr) {
      /*
       *  Show a coexpression block, which will be in the static region.
       */
      block = (char *)BlkLoc(*d);
      addr = DiffPtrs(block, statbase) / MMUnits;
      len = BlkSize(block) / MMUnits;
      cmd = 'Y';
      tch = typech[T_Coexpr];
      }
   else if (Pointer(*d)) {
      /*
       *  Show something in the block region.
       */
      block = (char *)BlkLoc(*d);
/*
      if ((uword)block < (uword)blkbase || (uword)block >= (uword)blkfree)
*/
      if (!InRange(blkbase,block,blkfree))
         return;	/* ignore if outside block region */
      addr = DiffPtrs(block, blkbase) / MMUnits;
      len = BlkSize(block) / MMUnits;
      cmd = '%';
      tch = typech[Type(*d)];
      }

   mmdec(addr);			/* address */
   mmchar('+');
   mmlen(len, cmd);		/* length, and $ Y or % command */
   if (s && *s)
      mmchar(*s);		/* color flag from mmshow call */
   else 
      mmchar('r');		/* default color is 'r' (redraw) */
   mmchar(tch);			/* block type character */
   if (llen >= LLIM)
      mmnewline();
   else
      mmspace();
   }

/*
 * mmrefresh() - redraw screen, initially or after garbage collection.
 */

static novalue mmrefresh()
   {
   char *p;
   word n;

   mmnewline();
   mmsizes('<');			/* signal start of screen refresh */
   mmnewline();
   mmforget();				/* clear memory of past sizes */
   mmstatic();				/* show the static region */
   mmnewline();
   for (p = blkbase; p < blkfree; p += n)
      MMAlc(n = BlkSize(p), (int)BlkType(p));/* block region */
   mmnewline();
   MMStr(DiffPtrs(strfree, strbase));	/* string region */
   mmnewline();
   fprintf(monfile, ">\n");		/* signal end of refresh */
   mmsizes('=');			/* confirm region sizes */
   mmforget();				/* clear memory of past sizes */
   }

/*
 *  mmstatic() - recap the static region (stack, coexprs, aliens, free)
 *   (this function is empty under FixedRegions)
 */
static novalue mmstatic()
   {
#ifndef FixedRegions
   HEADER *p;
   char *a;
   int h;
   word n;

   for (p = (HEADER *)statbase; (uword)p < (uword)(HEADER *)statfree;
      p += p->s.bsize) {
         a = (char *)(p + 1);
         n = (p->s.bsize - 1) * sizeof(HEADER);
         h = *(int *)a;
         if (h == T_Coexpr || a == (char *)stack)
            MMStat(a, n, 'X');		/* coexpression block */
         else if (h == FREEMAGIC)
            MMStat(a, n, 'F');		/* free block */
         else
            MMStat(a, n, 'A');		/* alien block */
         }
   a = (char *)p;
   if (a < statend)
      MMStat(a, (word)(statend-a), 'F');/* rest of static region is free */
#endif					/* FixedRegions */
   }

/*
 * mmsizes(c) - output current region sizes, with initial character c.
 * If c is '<', the unit size is written ahead of it.
 */
static novalue mmsizes(c)
int c;
   {
   mmnewline();
   if (c == '<')
      fprintf(monfile, "%d", MMUnits);
   fprintf(monfile, "%c %lu:%lu/%lu %lu:%lu/%lu %lu:%lu/%lu\n", c,
      /* static region; show as full, actual amount is unknown */
      (unsigned long)statbase,
      (unsigned long)DiffPtrs(statend, statbase),
      (unsigned long)DiffPtrs(statend, statbase),
      /* string region */
      (unsigned long)strbase,
      (unsigned long)DiffPtrs(strfree, strbase),
      (unsigned long)DiffPtrs(strend, strbase),
      /* block region */
      (unsigned long)blkbase,
      (unsigned long)DiffPtrs(blkfree, blkbase),
      (unsigned long)DiffPtrs(blkend, blkbase));
   }

/*
 * mmcmd(addr, len, c) - output a memmon command.
 *  If addr is < 0, it is omitted.
 *  If len matches the previous value for command c, it is also omitted.
 *  If the output fills the line, a following newline is written.
 */

static novalue mmcmd(addr, len, c)
word addr, len;
int c;
   {
   if (addr >= 0) {
      mmdec((uword)addr);
      mmchar('+');
      }
   mmlen(len, c);
   if (llen >= LLIM)
      mmnewline();
   else
      mmspace();
   }

/*
 * mmlen(n, c) - output length n with character c.
 * Omit the length if it matches the previous value for c.
 */
static novalue mmlen(n, c)
word n;
int c;
   {
   if (n != curlength[c-CurBias])
      mmdec((uword)(curlength[c-CurBias] = n));
   mmchar(c); 
   }

/*
 * mmdec(n) - output a decimal value, updating the line length.
 */
static novalue mmdec (n)
uword n;
   {
   if (n > 9)
      mmdec(n / 10);
   n %= 10;
   mmchar('0'+(int)n);
   }

/*
 * mmnewline() - output a newline and reset the line length.
 */
static novalue mmnewline()
   {
   if (llen > 0)  {
      putc('\n', monfile);
      llen = 0;
      }
   }

/*
 * mmforget() - clear the history of remembered lengths.
 */
static novalue mmforget()
   {
   int c;

   for (c = 0; c < CurSize; c++)
      curlength[c] = -1;
   }
#else					/* MemMon */
static char x;			/* avoid empty module */
#endif					/* MemMon */