diff options
Diffstat (limited to 'ghc/utils')
79 files changed, 7296 insertions, 0 deletions
diff --git a/ghc/utils/Jmakefile b/ghc/utils/Jmakefile new file mode 100644 index 0000000000..4b0b693195 --- /dev/null +++ b/ghc/utils/Jmakefile @@ -0,0 +1,10 @@ +#define IHaveSubdirs + +SUBDIRS = hp2ps \ + hscpp \ + unlit \ + hstags \ + mkdependHS \ + parallel \ + ugen \ + stat2resid diff --git a/ghc/utils/hp2ps/AreaBelow.c b/ghc/utils/hp2ps/AreaBelow.c new file mode 100644 index 0000000000..741380723e --- /dev/null +++ b/ghc/utils/hp2ps/AreaBelow.c @@ -0,0 +1,63 @@ +#include <stdio.h> +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "AreaBelow.h" + +extern void free(); + +/* + * Return the area enclosed by all of the curves. The algorithm + * used is the same as the trapizoidal rule for integration. + */ + +floatish +AreaBelow() +{ + intish i; + intish j; + intish bucket; + floatish value; + struct chunk *ch; + floatish area; + floatish trap; + floatish base; + floatish *maxima; + + maxima = (floatish *) xmalloc(nsamples * sizeof(floatish)); + for (i = 0; i < nsamples; i++) { + maxima[i] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + bucket = ch->d[j].bucket; + value = ch->d[j].value; + if (bucket >= nsamples) + Disaster("bucket out of range"); + maxima[ bucket ] += value; + } + } + } + + area = 0.0; + + for (i = 1; i < nsamples; i++) { + base = samplemap[i] - samplemap[i-1]; + if (maxima[i] > maxima[i-1]) { + trap = base * maxima[i-1] + ((base * (maxima[i] - maxima[i-1]))/ 2.0); + } else { + trap = base * maxima[i] + ((base * (maxima[i-1] - maxima[i]))/ 2.0); + } + + area += trap; + } + + free(maxima); + return area; +} diff --git a/ghc/utils/hp2ps/AreaBelow.h b/ghc/utils/hp2ps/AreaBelow.h new file mode 100644 index 0000000000..3bd9c9277b --- /dev/null +++ b/ghc/utils/hp2ps/AreaBelow.h @@ -0,0 +1,6 @@ +#ifndef AREA_BELOW_H +#define AREA_BELOW_H + +extern floatish AreaBelow PROTO((void)); + +#endif /* AREA_BELOW_H */ diff --git a/ghc/utils/hp2ps/AuxFile.c b/ghc/utils/hp2ps/AuxFile.c new file mode 100644 index 0000000000..a6088ebfb8 --- /dev/null +++ b/ghc/utils/hp2ps/AuxFile.c @@ -0,0 +1,168 @@ +#include <ctype.h> +#include <stdio.h> +#include <string.h> +#include "Main.h" +#include "Defines.h" +#include "Shade.h" +#include "Error.h" +#include "HpFile.h" +#include "Reorder.h" + +/* own stuff */ +#include "AuxFile.h" + +static void GetAuxLine PROTO((FILE *)); /* forward */ +static void GetAuxTok PROTO((FILE *)); /* forward */ + +void +GetAuxFile(auxfp) + FILE* auxfp; +{ + ch = ' '; + endfile = 0; + linenum = 1; + + GetAuxTok(auxfp); + + while (endfile == 0) { + GetAuxLine(auxfp); + } + + fclose(auxfp); +} + + + +/* + * Read the next line from the aux file, check the syntax, and + * perform the appropriate action. + */ + +static void +GetAuxLine(auxfp) + FILE* auxfp; +{ + switch (thetok) { + case X_RANGE_TOK: + GetAuxTok(auxfp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow X_RANGE", + auxfile, linenum); + } + auxxrange = thefloatish; + GetAuxTok(auxfp); + break; + case Y_RANGE_TOK: + GetAuxTok(auxfp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow Y_RANGE", + auxfile, linenum); + } + auxyrange = thefloatish; + GetAuxTok(auxfp); + break; + case ORDER_TOK: + GetAuxTok(auxfp); + if (thetok != IDENTIFIER_TOK) { + Error("%s, line %d: identifier must follow ORDER", + auxfile, linenum); + } + GetAuxTok(auxfp); + if (thetok != INTEGER_TOK) { + Error("%s, line %d: identifier and integer must follow ORDER", + auxfile, linenum); + } + OrderFor(theident, theinteger); + GetAuxTok(auxfp); + break; + case SHADE_TOK: + GetAuxTok(auxfp); + if (thetok != IDENTIFIER_TOK) { + Error("%s, line %d: identifier must follow SHADE", + auxfile, linenum); + } + GetAuxTok(auxfp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d: identifier and floating point number must follow SHADE", + auxfile, linenum); + } + ShadeFor(theident, thefloatish); + GetAuxTok(auxfp); + break; + case EOF_TOK: + endfile = 1; + break; + default: + Error("%s, line %d: %s unexpected", auxfile, linenum, + TokenToString(thetok)); + break; + } +} + + + +/* + * Read the next token from the input and assign its value + * to the global variable "thetok". In the case of numbers, + * the corresponding value is also assigned to "thefloatish"; + * in the case of identifiers it is assigned to "theident". + */ + +static void GetAuxTok(auxfp) +FILE* auxfp; +{ + + while (isspace(ch)) { /* skip whitespace */ + if (ch == '\n') linenum++; + ch = getc(auxfp); + } + + if (ch == EOF) { + thetok = EOF_TOK; + return; + } + + if (isdigit(ch)) { + thetok = GetNumber(auxfp); + return; + } else if (IsIdChar(ch)) { /* ch can't be a digit here */ + GetIdent(auxfp); + if (!isupper(theident[0])) { + thetok = IDENTIFIER_TOK; + } else if (strcmp(theident, "X_RANGE") == 0) { + thetok = X_RANGE_TOK; + } else if (strcmp(theident, "Y_RANGE") == 0) { + thetok = Y_RANGE_TOK; + } else if (strcmp(theident, "ORDER") == 0) { + thetok = ORDER_TOK; + } else if (strcmp(theident, "SHADE") == 0) { + thetok = SHADE_TOK; + } else { + thetok = IDENTIFIER_TOK; + } + return; + } else { + Error("%s, line %d: strange character (%c)", auxfile, linenum, ch); + } +} + +void +PutAuxFile(auxfp) + FILE* auxfp; +{ + intish i; + + fprintf(auxfp, "X_RANGE %.2f\n", xrange); + fprintf(auxfp, "Y_RANGE %.2f\n", yrange); + + for (i = 0; i < nidents; i++) { + fprintf(auxfp, "ORDER %s %d\n", identtable[i]->name, i+1); + } + + for (i = 0; i < nidents; i++) { + fprintf(auxfp, "SHADE %s %.2f\n", identtable[i]->name, + ShadeOf(identtable[i]->name)); + } + + fclose(auxfp); +} diff --git a/ghc/utils/hp2ps/AuxFile.h b/ghc/utils/hp2ps/AuxFile.h new file mode 100644 index 0000000000..1118bc8cd1 --- /dev/null +++ b/ghc/utils/hp2ps/AuxFile.h @@ -0,0 +1,7 @@ +#ifndef AUX_FILE_H +#define AUX_FILE_H + +extern void PutAuxFile PROTO((FILE *)); +extern void GetAuxFile PROTO((FILE *)); + +#endif /* AUX_FILE_H */ diff --git a/ghc/utils/hp2ps/Axes.c b/ghc/utils/hp2ps/Axes.c new file mode 100644 index 0000000000..ddd2bbfa43 --- /dev/null +++ b/ghc/utils/hp2ps/Axes.c @@ -0,0 +1,241 @@ +#include <stdio.h> +#include <string.h> +#include "Main.h" +#include "Curves.h" +#include "Defines.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "Axes.h" + +typedef enum {MEGABYTE, KILOBYTE, BYTE} mkb; + +static void XAxis PROTO((void)); /* forward */ +static void YAxis PROTO((void)); /* forward */ + +static void XAxisMark PROTO((floatish, floatish)); /* forward */ +static void YAxisMark PROTO((floatish, floatish, mkb)); /* forward */ + +static floatish Round PROTO((floatish)); /* forward */ + +void +Axes() +{ + XAxis(); + YAxis(); +} + +static void +XAxisMark(x, num) + floatish x; floatish num; +{ + /* calibration mark */ + fprintf(psfp, "%f %f moveto\n", xpage(x), ypage(0.0)); + fprintf(psfp, "0 -4 rlineto\n"); + fprintf(psfp, "stroke\n"); + + /* number */ + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "(%.1f)\n", num); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "2 div\n"); + fprintf(psfp, "%f exch sub\n", xpage(x)); + fprintf(psfp, "%f moveto\n", borderspace); + fprintf(psfp, "show\n"); +} + + +#define N_X_MARKS 7 +#define XFUDGE 15 + +extern floatish xrange; +extern char *sampleunitstring; + +static void +XAxis() +{ + floatish increment, i; + floatish t, x; + floatish legendlen; + + /* draw the x axis line */ + fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(0.0)); + fprintf(psfp, "%f 0 rlineto\n", graphwidth); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); + + /* draw x axis legend */ + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "(%s)\n", sampleunitstring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", xpage(0.0) + graphwidth); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", borderspace); + fprintf(psfp, "show\n"); + + + /* draw x axis scaling */ + + increment = Round(xrange / (floatish) N_X_MARKS); + + t = graphwidth / xrange; + legendlen = StringSize(sampleunitstring) + (floatish) XFUDGE; + + for (i = samplemap[0]; i < samplemap[nsamples - 1]; i += increment) { + x = (i - samplemap[0]) * t; + + if (x < (graphwidth - legendlen)) { + XAxisMark(x,i); + } + } +} + +static void +YAxisMark(y, num, unit) + floatish y; floatish num; mkb unit; +{ + /* calibration mark */ + fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(y)); + fprintf(psfp, "-4 0 rlineto\n"); + fprintf(psfp, "stroke\n"); + + /* number */ + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + + switch (unit) { + case MEGABYTE : + fprintf(psfp, "("); + CommaPrint(psfp, (int) (num / 1e6 + 0.5)); + fprintf(psfp, "M)\n"); + break; + case KILOBYTE : + fprintf(psfp, "("); + CommaPrint(psfp, (int) (num / 1e3 + 0.5)); + fprintf(psfp, "k)\n"); + break; + case BYTE: + fprintf(psfp, "("); + CommaPrint(psfp, (int) (num + 0.5)); + fprintf(psfp, ")\n"); + break; + } + + fprintf(psfp, "dup stringwidth\n"); + fprintf(psfp, "2 div\n"); + fprintf(psfp, "%f exch sub\n", ypage(y)); + + fprintf(psfp, "exch\n"); + fprintf(psfp, "%f exch sub\n", graphx0 - borderspace); + + fprintf(psfp, "exch\n"); + fprintf(psfp, "moveto\n"); + fprintf(psfp, "show\n"); +} + +#define N_Y_MARKS 7 +#define YFUDGE 15 + +extern floatish yrange; +extern char *valueunitstring; + +static void +YAxis() +{ + floatish increment, i; + floatish t, y; + floatish legendlen; + mkb unit; + + /* draw the y axis line */ + fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(0.0)); + fprintf(psfp, "0 %f rlineto\n", graphheight); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); + + /* draw y axis legend */ + fprintf(psfp, "gsave\n"); + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "(%s)\n", valueunitstring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", ypage(0.0) + graphheight); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f exch\n", xpage(0.0) - borderspace); + fprintf(psfp, "translate\n"); + fprintf(psfp, "90 rotate\n"); + fprintf(psfp, "0 0 moveto\n"); + fprintf(psfp, "show\n"); + fprintf(psfp, "grestore\n"); + + /* draw y axis scaling */ + increment = max( yrange / (floatish) N_Y_MARKS, 1.0); + increment = Round(increment); + + if (increment >= 1e6) { + unit = MEGABYTE; + } else if (increment >= 1e3) { + unit = KILOBYTE; + } else { + unit = BYTE; + } + + t = graphheight / yrange; + legendlen = StringSize(valueunitstring) + (floatish) YFUDGE; + + for (i = 0.0; i <= yrange; i += increment) { + y = i * t; + + if (y < (graphheight - legendlen)) { + YAxisMark(y, i, unit); + } + } +} + + +/* + * Find a "nice round" value to use on the axis. + */ + +static floatish OneTwoFive PROTO((floatish)); /* forward */ + +static floatish +Round(y) + floatish y; +{ + int i; + + if (y > 10.0) { + for (i = 0; y > 10.0; y /= 10.0, i++) ; + y = OneTwoFive(y); + for ( ; i > 0; y = y * 10.0, i--) ; + + } else if (y < 1.0) { + for (i = 0; y < 1.0; y *= 10.0, i++) ; + y = OneTwoFive(y); + for ( ; i > 0; y = y / 10.0, i--) ; + + } else { + y = OneTwoFive(y); + } + + return (y); +} + + +/* + * OneTwoFive() -- Runciman's 1,2,5 scaling rule. Argument 1.0 <= y <= 10.0. + */ + +static floatish +OneTwoFive(y) + floatish y; +{ + if (y > 4.0) { + return (5.0); + } else if (y > 1.0) { + return (2.0); + } else { + return (1.0); + } +} diff --git a/ghc/utils/hp2ps/Axes.h b/ghc/utils/hp2ps/Axes.h new file mode 100644 index 0000000000..f41b9ef537 --- /dev/null +++ b/ghc/utils/hp2ps/Axes.h @@ -0,0 +1,6 @@ +#ifndef AXES_H +#define AXES_H + +extern void Axes PROTO((void)); + +#endif /* AXES_H */ diff --git a/ghc/utils/hp2ps/CHANGES b/ghc/utils/hp2ps/CHANGES new file mode 100644 index 0000000000..db3b52e6d6 --- /dev/null +++ b/ghc/utils/hp2ps/CHANGES @@ -0,0 +1,37 @@ +1. + +When generating PostScript to show strings, '(' and ')' may need to be escaped. +These characters are now escaped when the JOB string is shown. + +2. + +Manually deleting samples from a .hp file now does what you would expect. + +3. + +The -t flag for setting the threshold percentage has been scrapped. No one +ever used it. + +4. + +Long JOB strings cause hp2ps to use a big title box. Big and small boxes +can be forced with -b and -s flag. + +5. + +MARKS now print as small triangles which remain below the x axis. + +6. + +There is an updated manual page. + +7. + +-m flag for setting maximum no of bands (default 20, cant be more than 20). +-t flag for setting threshold (between 0% and 5%, default 1%). + +8. + +Axes scaling rounding errors removed. + + diff --git a/ghc/utils/hp2ps/Curves.c b/ghc/utils/hp2ps/Curves.c new file mode 100644 index 0000000000..b7de061a84 --- /dev/null +++ b/ghc/utils/hp2ps/Curves.c @@ -0,0 +1,164 @@ +#include <stdio.h> +#include <math.h> +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "Shade.h" +#include "Utilities.h" + +/* own stuff */ +#include "Curves.h" + +static floatish *x; /* x and y values */ +static floatish *y; + +static floatish *py; /* previous y values */ + +static void Curve PROTO((struct entry *)); /* forward */ +static void ShadeCurve(); /* forward */ + +void +Curves() +{ + intish i; + + for (i = 0; i < nidents; i++) { + Curve(identtable[i]); + } +} + +/* + * Draw a curve, and fill the area that is below it and above + * the previous curve. + */ + +static void +Curve(e) + struct entry* e; +{ + struct chunk* ch; + int j; + + for (ch = e->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + y[ ch->d[j].bucket ] += ch->d[j].value; + } + } + + ShadeCurve(x, y, py, ShadeOf(e->name)); +} + + +static void PlotCurveLeftToRight PROTO((floatish *, floatish *)); /* forward */ +static void PlotCurveRightToLeft PROTO((floatish *, floatish *)); /* forward */ + +static void SaveCurve PROTO((floatish *, floatish *)); /* forward */ + +/* + * Map virtual x coord to physical x coord + */ + +floatish +xpage(x) + floatish x; +{ + return (x + graphx0); +} + + + +/* + * Map virtual y coord to physical y coord + */ + +floatish +ypage(y) + floatish y; +{ + return (y + graphy0); +} + + +/* + * Fill the region bounded by two splines, using the given + * shade. + */ + +static void +ShadeCurve(x, y, py, shade) + floatish *x; floatish *y; floatish *py; floatish shade; +{ + fprintf(psfp, "%f %f moveto\n", xpage(x[0]), ypage(py[0])); + PlotCurveLeftToRight(x, py); + + fprintf(psfp, "%f %f lineto\n", xpage(x[nsamples - 1]), + ypage(y[nsamples - 1])); + PlotCurveRightToLeft(x, y); + + fprintf(psfp, "closepath\n"); + + fprintf(psfp, "gsave\n"); + + fprintf(psfp, "%f setgray\n", shade); + fprintf(psfp, "fill\n"); + + fprintf(psfp, "grestore\n"); + fprintf(psfp, "stroke\n"); + + SaveCurve(y, py); +} + +static void +PlotCurveLeftToRight(x,y) + floatish *x; floatish *y; +{ + intish i; + + for (i = 0; i < nsamples; i++) { + fprintf(psfp, "%f %f lineto\n", xpage(x[i]), ypage(y[i])); + } +} + +static void +PlotCurveRightToLeft(x,y) + floatish *x; floatish *y; +{ + intish i; + + for (i = nsamples - 1; i >= 0; i-- ) { + fprintf(psfp, "%f %f lineto\n", xpage(x[i]), ypage(y[i])); + } +} + +/* + * Save the curve coordinates stored in y[] in py[]. + */ + +static void +SaveCurve(y, py) + floatish *y; floatish* py; +{ + intish i; + + for (i = 0; i < nsamples; i++) { + py[i] = y[i]; + } +} + +extern floatish xrange; + +void +CurvesInit() +{ + intish i; + + x = (floatish*) xmalloc(nsamples * sizeof(floatish)); + y = (floatish*) xmalloc(nsamples * sizeof(floatish)); + py = (floatish*) xmalloc(nsamples * sizeof(floatish)); + + for (i = 0; i < nsamples; i++) { + x[i] = ((samplemap[i] - samplemap[0])/ xrange) * graphwidth; + y[i] = py[i] = 0.0; + } +} diff --git a/ghc/utils/hp2ps/Curves.h b/ghc/utils/hp2ps/Curves.h new file mode 100644 index 0000000000..4493f2d3ed --- /dev/null +++ b/ghc/utils/hp2ps/Curves.h @@ -0,0 +1,10 @@ +#ifndef CURVES_H +#define CURVES_H + +extern void Curves PROTO((void)); +extern void CurvesInit PROTO((void)); + +extern floatish xpage PROTO((floatish)); +extern floatish ypage PROTO((floatish)); + +#endif /* CURVES_H */ diff --git a/ghc/utils/hp2ps/Defines.h b/ghc/utils/hp2ps/Defines.h new file mode 100644 index 0000000000..8d38546fec --- /dev/null +++ b/ghc/utils/hp2ps/Defines.h @@ -0,0 +1,61 @@ +#ifndef DEFINES_H +#define DEFINES_H + +/* + * Things that can be altered. + */ + +#define THRESHOLD_PERCENT _thresh_ /* all values below 1% insignificant */ +#define DEFAULT_THRESHOLD 1.0 +extern floatish _thresh_; + +#define TWENTY _twenty_ /* show top 20 bands, grouping excess */ +#define DEFAULT_TWENTY 20 /* this is default and absolute maximum */ +extern int _twenty_; + +#define LARGE_FONT 12 /* Helvetica 12pt */ +#define NORMAL_FONT 10 /* Helvetica 10pt */ + +#define BORDER_HEIGHT 432.0 /* page border box 432pt (6 inches high) */ +#define BORDER_WIDTH 648.0 /* page border box 648pt (9 inches wide) */ +#define BORDER_SPACE 5.0 /* page border space */ +#define BORDER_THICK 0.5 /* page border line thickness 0.5pt */ + + +#define TITLE_HEIGHT 20.0 /* title box is 20pt high */ +#define TITLE_TEXT_FONT LARGE_FONT /* title in large font */ +#define TITLE_TEXT_SPACE 6.0 /* space between title text and box */ + + +#define AXIS_THICK 0.5 /* axis thickness 0.5pt */ +#define AXIS_TEXT_SPACE 6 /* space between axis legends and axis */ +#define AXIS_TEXT_FONT NORMAL_FONT /* axis legends in normal font */ +#define AXIS_Y_TEXT_SPACE 35 /* space for y axis text */ + +#define KEY_BOX_WIDTH 14 /* key boxes are 14pt high */ + +#define SMALL_JOB_STRING_WIDTH 35 /* small title for 35 characters or less */ +#define BIG_JOB_STRING_WIDTH 80 /* big title for everything else */ + +#define GRAPH_X0 (AXIS_Y_TEXT_SPACE + (2 * BORDER_SPACE)) +#define GRAPH_Y0 (AXIS_TEXT_FONT + (2 * BORDER_SPACE)) + + +/* + * Things that should be left well alone. + */ + + + +#define START_X 72 /* start 72pt (1 inch) from left (portrait) */ +#define START_Y 108 /* start 108pt (1.5 inch) from bottom (portrait) */ + +#define NUMBER_LENGTH 32 + +#define N_CHUNK 24 + +#define VERSION "0.25" /* as of 95/03/21 */ + +#define max(x,y) ((x) > (y) ? (x) : (y)) /* not everyone has this */ + +#endif /* DEFINES_H */ diff --git a/ghc/utils/hp2ps/Deviation.c b/ghc/utils/hp2ps/Deviation.c new file mode 100644 index 0000000000..49e8d21d17 --- /dev/null +++ b/ghc/utils/hp2ps/Deviation.c @@ -0,0 +1,140 @@ +#include <stdio.h> +#include <string.h> +#include <math.h> +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +extern void free(); + +/* own stuff */ +#include "Deviation.h" + +/* + * Reorder the identifiers in the identifier table so that the + * ones whose data points exhibit the mininal standard deviation + * come first. + */ + +void +Deviation() +{ + intish i; + intish j; + floatish dev; + struct chunk* ch; + int min; + floatish t; + struct entry* e; + floatish *averages; + floatish *deviations; + + averages = (floatish*) xmalloc(nidents * sizeof(floatish)); + deviations = (floatish*) xmalloc(nidents * sizeof(floatish)); + + /* find averages */ + + for (i = 0; i < nidents; i++) { + averages[i] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + averages[i] += ch->d[j].value; + } + } + } + + for (i = 0; i < nidents; i++) { + averages[i] /= (floatish) nsamples; + } + + /* calculate standard deviation */ + + for (i = 0; i < nidents; i++) { + deviations[i] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + dev = ch->d[j].value - averages[i]; + deviations[i] += dev * dev; + } + } + } + + for (i = 0; i < nidents; i++) { + deviations[i] = (floatish) sqrt ((doublish) (deviations[i] / + (floatish) (nsamples - 1))); + } + + + /* sort on basis of standard deviation */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (deviations[ j ] < deviations[min]) { + min = j; + } + } + + t = deviations[min]; + deviations[min] = deviations[i]; + deviations[i] = t; + + e = identtable[min]; + identtable[min] = identtable[i]; + identtable[i] = e; + } + + free(averages); + free(deviations); +} + +void +Identorder(iflag) + int iflag; /* a funny three-way flag ? WDP 95/03 */ +{ + int i; + int j; + int min; + struct entry* e; + + /* sort on basis of ident string */ + if (iflag > 0) { + /* greatest at top i.e. smallest at start */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (strcmp(identtable[j]->name, identtable[min]->name) < 0) { + min = j; + } + } + + e = identtable[min]; + identtable[min] = identtable[i]; + identtable[i] = e; + } + } else { + /* smallest at top i.e. greatest at start */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (strcmp(identtable[j]->name, identtable[min]->name) > 0) { + min = j; + } + } + + e = identtable[min]; + identtable[min] = identtable[i]; + identtable[i] = e; + } + } +} diff --git a/ghc/utils/hp2ps/Deviation.h b/ghc/utils/hp2ps/Deviation.h new file mode 100644 index 0000000000..08bed6ea5c --- /dev/null +++ b/ghc/utils/hp2ps/Deviation.h @@ -0,0 +1,7 @@ +#ifndef DEVIATION_H +#define DEVIATION_H + +extern void Deviation PROTO((void)); +extern void Identorder PROTO((int)); + +#endif /* DEVIATION_H */ diff --git a/ghc/utils/hp2ps/Dimensions.c b/ghc/utils/hp2ps/Dimensions.c new file mode 100644 index 0000000000..b0d1bd53e0 --- /dev/null +++ b/ghc/utils/hp2ps/Dimensions.c @@ -0,0 +1,203 @@ +#include <ctype.h> +#include <string.h> +#include <stdio.h> +#include "Main.h" +#include "Defines.h" +#include "HpFile.h" +#include "Scale.h" + +/* own stuff */ +#include "Dimensions.h" + +/* + * Get page and other dimensions before printing. + */ + +floatish borderheight = BORDER_HEIGHT; +floatish borderwidth = BORDER_WIDTH; +floatish borderspace = BORDER_SPACE; +floatish borderthick = BORDER_THICK; + +floatish titlewidth = (BORDER_WIDTH - (2 * BORDER_SPACE)); +floatish titletextspace = TITLE_TEXT_SPACE; +floatish titleheight; + +floatish graphx0 = GRAPH_X0; +floatish graphy0 = GRAPH_Y0; + +floatish graphheight; +floatish graphwidth; + +static floatish KeyWidth PROTO((void)); /* forward */ + +void +Dimensions() +{ + xrange = samplemap[nsamples - 1] - samplemap[0]; + xrange = max(xrange, auxxrange); + if (xrange == 0.0) xrange = 1.0; /* avoid division by 0.0 */ + + yrange = MaxCombinedHeight(); + yrange = max(yrange, auxyrange); + if (yrange == 0.0) yrange = 1.0; /* avoid division by 0.0 */ + + if (!bflag && !sflag) { + bflag = strlen(jobstring) > SMALL_JOB_STRING_WIDTH; + } + + if (bflag) { + titleheight = 2 * TITLE_HEIGHT; + } else { + titleheight = TITLE_HEIGHT; + } + + graphwidth = titlewidth - graphx0 - (TWENTY ? KeyWidth() : 0); + graphheight = borderheight - titleheight - (2 * borderspace) - graphy0; +} + +/* + * Calculate the width of the key. + */ + +static floatish +KeyWidth() +{ + intish i; + floatish c; + + c = 0.0; + + for (i = 0; i < nidents; i++) { + c = max(c, StringSize(identtable[i]->name)); + } + + c += 3.0 * borderspace; + + c += (floatish) KEY_BOX_WIDTH; + + return c; +} + + +/* + * A desperately grim solution. + */ + + +floatish fonttab[] = { + /* 20 (' ') = */ 3.0, + /* 21 ('!') = */ 1.0, + /* 22 ('"') = */ 1.0, + /* 23 ('#') = */ 3.0, + /* 24 ('$') = */ 3.0, + /* 25 ('%') = */ 3.0, + /* 26 ('&') = */ 3.0, + /* 27 (''') = */ 1.0, + /* 28 ('(') = */ 3.0, + /* 29 (')') = */ 3.0, + /* 2a ('*') = */ 2.0, + /* 2b ('+') = */ 3.0, + /* 2c (',') = */ 1.0, + /* 2d ('-') = */ 3.0, + /* 2e ('.') = */ 1.0, + /* 2f ('/') = */ 3.0, + /* 30 ('0') = */ 4.0, + /* 31 ('1') = */ 4.0, + /* 32 ('2') = */ 4.0, + /* 33 ('3') = */ 4.0, + /* 34 ('4') = */ 4.0, + /* 35 ('5') = */ 4.0, + /* 36 ('6') = */ 4.0, + /* 37 ('7') = */ 4.0, + /* 38 ('8') = */ 4.0, + /* 39 ('9') = */ 4.0, + /* 3a (':') = */ 1.0, + /* 3b (';') = */ 1.0, + /* 3c ('<') = */ 3.0, + /* 3d ('=') = */ 3.0, + /* 3e ('>') = */ 3.0, + /* 3f ('?') = */ 2.0, + /* 40 ('@') = */ 3.0, + /* 41 ('A') = */ 5.0, + /* 42 ('B') = */ 5.0, + /* 43 ('C') = */ 5.0, + /* 44 ('D') = */ 5.0, + /* 45 ('E') = */ 5.0, + /* 46 ('F') = */ 5.0, + /* 47 ('G') = */ 5.0, + /* 48 ('H') = */ 5.0, + /* 49 ('I') = */ 1.0, + /* 4a ('J') = */ 5.0, + /* 4b ('K') = */ 5.0, + /* 4c ('L') = */ 5.0, + /* 4d ('M') = */ 5.0, + /* 4e ('N') = */ 5.0, + /* 4f ('O') = */ 5.0, + /* 50 ('P') = */ 5.0, + /* 51 ('Q') = */ 5.0, + /* 52 ('R') = */ 5.0, + /* 53 ('S') = */ 5.0, + /* 54 ('T') = */ 5.0, + /* 55 ('U') = */ 5.0, + /* 56 ('V') = */ 5.0, + /* 57 ('W') = */ 5.0, + /* 58 ('X') = */ 5.0, + /* 59 ('Y') = */ 5.0, + /* 5a ('Z') = */ 5.0, + /* 5b ('[') = */ 2.0, + /* 5c ('\') = */ 3.0, + /* 5d (']') = */ 2.0, + /* 5e ('^') = */ 1.0, + /* 5f ('_') = */ 3.0, + /* 60 ('`') = */ 1.0, + /* 61 ('a') = */ 3.0, + /* 62 ('b') = */ 3.0, + /* 63 ('c') = */ 3.0, + /* 64 ('d') = */ 3.0, + /* 65 ('e') = */ 3.0, + /* 66 ('f') = */ 3.0, + /* 67 ('g') = */ 3.0, + /* 68 ('h') = */ 3.0, + /* 69 ('i') = */ 1.0, + /* 6a ('j') = */ 2.0, + /* 6b ('k') = */ 3.0, + /* 6c ('l') = */ 1.0, + /* 6d ('m') = */ 5.0, + /* 6e ('n') = */ 3.0, + /* 6f ('o') = */ 3.0, + /* 70 ('p') = */ 3.0, + /* 71 ('q') = */ 3.0, + /* 72 ('r') = */ 2.0, + /* 73 ('s') = */ 3.0, + /* 74 ('t') = */ 2.0, + /* 75 ('u') = */ 3.0, + /* 76 ('v') = */ 3.0, + /* 77 ('w') = */ 3.0, + /* 78 ('x') = */ 3.0, + /* 79 ('y') = */ 3.0, + /* 7a ('z') = */ 3.0, + /* 7b ('{') = */ 2.0, + /* 7c ('|') = */ 1.0, + /* 7d ('}') = */ 2.0, + /* 7e ('~') = */ 2.0 +}; + + +/* + * What size is a string (in points)? + */ + +#define FUDGE (2.834646 * 0.6) + +floatish +StringSize(s) + char* s; +{ + floatish r; + + for (r = 0.0; *s; s++) { + r += fonttab[(*s) - 0x20]; + } + + return r * FUDGE; +} diff --git a/ghc/utils/hp2ps/Dimensions.h b/ghc/utils/hp2ps/Dimensions.h new file mode 100644 index 0000000000..1b667125ba --- /dev/null +++ b/ghc/utils/hp2ps/Dimensions.h @@ -0,0 +1,22 @@ +#ifndef DIMENSIONS_H +#define DIMENSIONS_H + +extern floatish borderheight; +extern floatish borderwidth; +extern floatish borderspace; +extern floatish borderthick; + +extern floatish titleheight; +extern floatish titlewidth; +extern floatish titletextspace; + +extern floatish graphx0; +extern floatish graphy0; + +extern floatish graphheight; +extern floatish graphwidth; + +extern void Dimensions PROTO((void)); +extern floatish StringSize PROTO((char *)); + +#endif /* DIMENSIONS_H */ diff --git a/ghc/utils/hp2ps/Error.c b/ghc/utils/hp2ps/Error.c new file mode 100644 index 0000000000..4361e0ba0f --- /dev/null +++ b/ghc/utils/hp2ps/Error.c @@ -0,0 +1,54 @@ +#include <stdio.h> +#include "Main.h" +#include "Defines.h" + +/* own stuff */ +#include "Error.h" + +extern void exit PROTO((int)); + +/*VARARGS0*/ +void +Error(a1,a2,a3,a4) + char* a1; char* a2; char* a3; char* a4; +{ + fflush(stdout); + fprintf(stderr, "%s: ", programname); + fprintf(stderr, a1, a2, a3, a4); + fprintf(stderr, "\n"); + exit(1); +} + +/*VARARGS0*/ +void +Disaster(a1,a2,a3,a4) + char* a1; char* a2; char* a3; char* a4; +{ + fflush(stdout); + fprintf(stderr, "%s: ", programname); + fprintf(stderr, " Disaster! ("); + fprintf(stderr, a1, a2, a3, a4); + fprintf(stderr, ")\n"); + exit(1); +} + +void +Usage(str) + char *str; +{ + if (str) printf("error: %s\n", str); + printf("usage: %s -b -d -ef -g -i -p -mn -p -s -tf -y [file[.hp]]\n", programname); + printf("where -b use large title box\n"); + printf(" -d sort by standard deviation\n"); + printf(" -ef[in|mm|pt] produce Encapsulated PostScript f units wide\n"); + printf(" -g produce output suitable for GHOSTSCRIPT previever\n"); + printf(" -i[+|-] sort by identifier string (-i+ gives greatest on top) \n"); + printf(" -mn print maximum of n bands (default & max 20)\n"); + printf(" -m0 removes the band limit altogether\n"); + printf(" -p use previous scaling, shading and ordering\n"); + printf(" -s use small title box\n"); + printf(" -tf ignore trace bands which sum below f%% (default 1%%, max 5%%)\n"); + printf(" -y traditional\n"); + exit(0); +} + diff --git a/ghc/utils/hp2ps/Error.h b/ghc/utils/hp2ps/Error.h new file mode 100644 index 0000000000..0febc84ab0 --- /dev/null +++ b/ghc/utils/hp2ps/Error.h @@ -0,0 +1,8 @@ +#ifndef ERROR_H +#define ERROR_H + +extern void Error (); /*PROTO((char *, ...)); */ +extern void Disaster (); /* PROTO((char *, ...)); */ +extern void Usage (); /* PROTO((char *)); */ + +#endif /* ERROR_H */ diff --git a/ghc/utils/hp2ps/HpFile.c b/ghc/utils/hp2ps/HpFile.c new file mode 100644 index 0000000000..98b62044a9 --- /dev/null +++ b/ghc/utils/hp2ps/HpFile.c @@ -0,0 +1,587 @@ +#include <ctype.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +#ifndef atof +extern double atof PROTO((const char *)); +#endif + +/* own stuff already included */ + +#define N_MARKS 50 /* start size of the mark table */ +#define N_SAMPLES 500 /* start size of the sample table */ + +char *theident; +char *thestring; +int theinteger; +floatish thefloatish; +int ch; /* last character read */ +token thetok; /* last token */ +int linenum; /* current line number */ +int endfile; /* true at end of file */ + +static boolish gotjob = 0; /* "JOB" read */ +static boolish gotdate = 0; /* "DATE" read */ +static boolish gotvalueunit = 0; /* "VALUE_UNIT" read */ +static boolish gotsampleunit = 0; /* "SAMPLE_UNIT" read */ +static boolish insample = 0; /* true when in sample */ + +static floatish lastsample; /* the last sample time */ + +static void GetHpLine PROTO((FILE *)); /* forward */ +static void GetHpTok PROTO((FILE *)); /* forward */ + +static struct entry *GetEntry PROTO((char *)); /* forward */ + +static void MakeIdentTable PROTO((void)); /* forward */ + +char *jobstring; +char *datestring; + +char *sampleunitstring; +char *valueunitstring; + +floatish *samplemap; /* sample intervals */ +floatish *markmap; /* sample marks */ + +/* + * An extremely simple parser. The input is organised into lines of + * the form + * + * JOB s -- job identifier string + * DATE s -- date string + * SAMPLE_UNIT s -- sample unit eg "seconds" + * VALUE_UNIT s -- value unit eg "bytes" + * MARK i -- sample mark + * BEGIN_SAMPLE i -- start of ith sample + * identifier i -- there are i identifiers in this sample + * END_SAMPLE i -- end of ith sample + * + */ + +void +GetHpFile(infp) + FILE *infp; +{ + nsamples = 0; + nmarks = 0; + nidents = 0; + + ch = ' '; + endfile = 0; + linenum = 1; + lastsample = 0.0; + + GetHpTok(infp); + + while (endfile == 0) { + GetHpLine(infp); + } + + if (!gotjob) { + Error("%s: JOB missing", hpfile); + } + + if (!gotdate) { + Error("%s: DATE missing", hpfile); + } + + if (!gotvalueunit) { + Error("%s: VALUE_UNIT missing", hpfile); + } + + if (!gotsampleunit) { + Error("%s: SAMPLE_UNIT missing", hpfile); + } + + if (nsamples == 0) { + Error("%s: contains no samples", hpfile); + } + + + MakeIdentTable(); + + fclose(hpfp); +} + + +/* + * Read the next line from the input, check the syntax, and perform + * the appropriate action. + */ + +static void +GetHpLine(infp) + FILE* infp; +{ + static intish nmarkmax = 0, nsamplemax = 0; + + switch (thetok) { + case JOB_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow JOB", hpfile, linenum); + } + jobstring = thestring; + gotjob = 1; + GetHpTok(infp); + break; + + case DATE_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow DATE", hpfile, linenum); + } + datestring = thestring; + gotdate = 1; + GetHpTok(infp); + break; + + case SAMPLE_UNIT_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow SAMPLE_UNIT", hpfile, + linenum); + } + sampleunitstring = thestring; + gotsampleunit = 1; + GetHpTok(infp); + break; + + case VALUE_UNIT_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow VALUE_UNIT", hpfile, + linenum); + } + valueunitstring = thestring; + gotvalueunit = 1; + GetHpTok(infp); + break; + + case MARK_TOK: + GetHpTok(infp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow MARK", + hpfile, linenum); + } + if (insample) { + Error("%s, line %d, MARK occurs within sample", hpfile, linenum); + } + if (nmarks >= nmarkmax) { + if (!markmap) { + nmarkmax = N_MARKS; + markmap = (floatish*) xmalloc(nmarkmax * sizeof(floatish)); + } else { + nmarkmax *= 2; + markmap = (floatish*) xrealloc(markmap, nmarkmax * sizeof(floatish)); + } + } + markmap[ nmarks++ ] = thefloatish; + GetHpTok(infp); + break; + + case BEGIN_SAMPLE_TOK: + insample = 1; + GetHpTok(infp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow BEGIN_SAMPLE", hpfile, linenum); + } + if (thefloatish < lastsample) { + Error("%s, line %d, samples out of sequence", hpfile, linenum); + } else { + lastsample = thefloatish; + } + if (nsamples >= nsamplemax) { + if (!samplemap) { + nsamplemax = N_SAMPLES; + samplemap = (floatish*) xmalloc(nsamplemax * sizeof(floatish)); + } else { + nsamplemax *= 2; + samplemap = (floatish*) xrealloc(samplemap, + nsamplemax * sizeof(floatish)); + } + } + samplemap[ nsamples ] = thefloatish; + GetHpTok(infp); + break; + + case END_SAMPLE_TOK: + insample = 0; + GetHpTok(infp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d: floating point number must follow END_SAMPLE", + hpfile, linenum); + } + nsamples++; + GetHpTok(infp); + break; + + case IDENTIFIER_TOK: + GetHpTok(infp); + if (thetok != INTEGER_TOK) { + Error("%s, line %d: integer must follow identifier", hpfile, + linenum); + } + StoreSample(GetEntry(theident), nsamples, (floatish) theinteger); + GetHpTok(infp); + break; + + case EOF_TOK: + endfile = 1; + break; + + default: + Error("%s, line %d: %s unexpected", hpfile, linenum, + TokenToString(thetok)); + break; + } +} + + +char * +TokenToString(t) + token t; +{ + switch (t) { + case EOF_TOK: return "EOF"; + case INTEGER_TOK: return "integer"; + case FLOAT_TOK: return "floating point number"; + case IDENTIFIER_TOK: return "identifier"; + case STRING_TOK: return "string"; + case BEGIN_SAMPLE_TOK: return "BEGIN_SAMPLE"; + case END_SAMPLE_TOK: return "END_SAMPLE"; + case JOB_TOK: return "JOB"; + case DATE_TOK: return "DATE"; + case SAMPLE_UNIT_TOK: return "SAMPLE_UNIT"; + case VALUE_UNIT_TOK: return "VALUE_UNIT"; + case MARK_TOK: return "MARK"; + + case X_RANGE_TOK: return "X_RANGE"; + case Y_RANGE_TOK: return "Y_RANGE"; + case ORDER_TOK: return "ORDER"; + case SHADE_TOK: return "SHADE"; + default: return "(strange token)"; + } +} + +/* + * Read the next token from the input and assign its value + * to the global variable "thetok". In the case of numbers, + * the corresponding value is also assigned to "theinteger" + * or "thefloatish" as appropriate; in the case of identifiers + * it is assigned to "theident". + */ + +static void +GetHpTok(infp) + FILE* infp; +{ + + while (isspace(ch)) { /* skip whitespace */ + if (ch == '\n') linenum++; + ch = getc(infp); + } + + if (ch == EOF) { + thetok = EOF_TOK; + return; + } + + if (isdigit(ch)) { + thetok = GetNumber(infp); + return; + } else if (ch == '\"') { + GetString(infp); + thetok = STRING_TOK; + return; + } else if (IsIdChar(ch)) { + ASSERT(! (isdigit(ch))); /* ch can't be a digit here */ + GetIdent(infp); + if (!isupper(theident[0])) { + thetok = IDENTIFIER_TOK; + } else if (strcmp(theident, "BEGIN_SAMPLE") == 0) { + thetok = BEGIN_SAMPLE_TOK; + } else if (strcmp(theident, "END_SAMPLE") == 0) { + thetok = END_SAMPLE_TOK; + } else if (strcmp(theident, "JOB") == 0) { + thetok = JOB_TOK; + } else if (strcmp(theident, "DATE") == 0) { + thetok = DATE_TOK; + } else if (strcmp(theident, "SAMPLE_UNIT") == 0) { + thetok = SAMPLE_UNIT_TOK; + } else if (strcmp(theident, "VALUE_UNIT") == 0) { + thetok = VALUE_UNIT_TOK; + } else if (strcmp(theident, "MARK") == 0) { + thetok = MARK_TOK; + } else { + thetok = IDENTIFIER_TOK; + } + return; + } else { + Error("%s, line %d: strange character (%c)", hpfile, linenum, ch); + } +} + + +/* + * Read a sequence of digits and convert the result to an integer + * or floating point value (assigned to the "theinteger" or + * "thefloatish"). + */ + +static char numberstring[ NUMBER_LENGTH - 1 ]; + +token +GetNumber(infp) + FILE* infp; +{ + int i; + int containsdot; + + ASSERT(isdigit(ch)); /* we must have a digit to start with */ + + containsdot = 0; + + for (i = 0; i < NUMBER_LENGTH && (isdigit(ch) || ch == '.'); i++) { + numberstring[ i ] = ch; + containsdot |= (ch == '.'); + ch = getc(infp); + } + + ASSERT(i < NUMBER_LENGTH); /* did not overflow */ + + numberstring[ i ] = '\0'; + + if (containsdot) { + thefloatish = (floatish) atof(numberstring); + return FLOAT_TOK; + } else { + theinteger = atoi(numberstring); + return INTEGER_TOK; + } +} + +/* + * Read a sequence of identifier characters and assign the result + * to the string "theident". + */ + +void +GetIdent(infp) + FILE *infp; +{ + unsigned int i; + char idbuffer[5000]; + + for (i = 0; i < (sizeof idbuffer)-1 && IsIdChar(ch); i++) { + idbuffer[ i ] = ch; + ch = getc(infp); + } + + idbuffer[ i ] = '\0'; + + if (theident) + free(theident); + + theident = copystring(idbuffer); +} + + +/* + * Read a sequence of characters that make up a string and + * assign the result to "thestring". + */ + +void +GetString(infp) + FILE *infp; +{ + unsigned int i; + char stringbuffer[5000]; + + ASSERT(ch == '\"'); + + ch = getc(infp); /* skip the '\"' that begins the string */ + + for (i = 0; i < (sizeof stringbuffer)-1 && ch != '\"'; i++) { + stringbuffer[ i ] = ch; + ch = getc(infp); + } + + stringbuffer[i] = '\0'; + thestring = copystring(stringbuffer); + + ASSERT(ch == '\"'); + + ch = getc(infp); /* skip the '\"' that terminates the string */ +} + +boolish +IsIdChar(ch) + int ch; +{ + return (!isspace(ch)); +} + + +/* + * The information associated with each identifier is stored + * in a linked list of chunks. The table below allows the list + * of chunks to be retrieved given an identifier name. + */ + +#define N_HASH 513 + +static struct entry* hashtable[ N_HASH ]; + +static intish +Hash(s) + char *s; +{ + int r; + + for (r = 0; *s; s++) { + r = r + r + r + *s; + } + + if (r < 0) r = -r; + + return r % N_HASH; +} + +/* + * Get space for a new chunk. Initialise it, and return a pointer + * to the new chunk. + */ + +static struct chunk* +MakeChunk() +{ + struct chunk* ch; + struct datapoint* d; + + ch = (struct chunk*) xmalloc( sizeof(struct chunk) ); + + d = (struct datapoint*) xmalloc (sizeof(struct datapoint) * N_CHUNK); + + ch->nd = 0; + ch->d = d; + ch->next = 0; + return ch; +} + + +/* + * Get space for a new entry. Initialise it, and return a pointer + * to the new entry. + */ + +struct entry * +MakeEntry(name) + char *name; +{ + struct entry* e; + + e = (struct entry *) xmalloc(sizeof(struct entry)); + e->chk = MakeChunk(); + e->name = copystring(name); + return e; +} + +/* + * Get the entry associated with "name", creating a new entry if + * necessary. + */ + +static struct entry * +GetEntry(name) + char* name; +{ + intish h; + struct entry* e; + + h = Hash(name); + + for (e = hashtable[ h ]; e; e = e->next) { + if (strcmp(e->name, name) == 0) { + break; + } + } + + if (e) { + return (e); + } else { + nidents++; + e = MakeEntry(name); + e->next = hashtable[ h ]; + hashtable[ h ] = e; + return (e); + } +} + + +/* + * Store information from a sample. + */ + +void +StoreSample(en, bucket, value) + struct entry* en; intish bucket; floatish value; +{ + struct chunk* chk; + + for (chk = en->chk; chk->next != 0; chk = chk->next) + ; + + if (chk->nd < N_CHUNK) { + chk->d[ chk->nd ].bucket = bucket; + chk->d[ chk->nd ].value = value; + chk->nd += 1; + } else { + struct chunk* t; + t = chk->next = MakeChunk(); + t->d[ 0 ].bucket = bucket; + t->d[ 0 ].value = value; + t->nd += 1; + } +} + + +struct entry** identtable; + +/* + * The hash table is useful while reading the input, but it + * becomes a liability thereafter. The code below converts + * it to a more easily processed table. + */ + +static void +MakeIdentTable() +{ + intish i; + intish j; + struct entry* e; + + nidents = 0; + for (i = 0; i < N_HASH; i++) { + for (e = hashtable[ i ]; e; e = e->next) { + nidents++; + } + } + + identtable = (struct entry**) xmalloc(nidents * sizeof(struct entry*)); + j = 0; + + for (i = 0; i < N_HASH; i++) { + for (e = hashtable[ i ]; e; e = e->next, j++) { + identtable[ j ] = e; + } + } +} diff --git a/ghc/utils/hp2ps/HpFile.h b/ghc/utils/hp2ps/HpFile.h new file mode 100644 index 0000000000..919b1b470c --- /dev/null +++ b/ghc/utils/hp2ps/HpFile.h @@ -0,0 +1,77 @@ +#ifndef HP_FILE_H +#define HP_FILE_H + +typedef enum { + /* These tokens are found in ".hp" files */ + + EOF_TOK, + INTEGER_TOK, + FLOAT_TOK, + IDENTIFIER_TOK, + STRING_TOK, + BEGIN_SAMPLE_TOK, + END_SAMPLE_TOK, + JOB_TOK, + DATE_TOK, + SAMPLE_UNIT_TOK, + VALUE_UNIT_TOK, + MARK_TOK, + + /* These extra ones are found only in ".aux" files */ + + X_RANGE_TOK, + Y_RANGE_TOK, + ORDER_TOK, + SHADE_TOK +} token; + +struct datapoint { + int bucket; + floatish value; +}; + +struct chunk { + struct chunk *next; + short nd; /* 0 .. N_CHUNK - 1 */ + struct datapoint *d; +}; + + +struct entry { + struct entry *next; + struct chunk *chk; + char *name; +}; + +extern char *theident; +extern char *thestring; +extern int theinteger; +extern floatish thefloatish; +extern int ch; +extern token thetok; +extern int linenum; +extern int endfile; + +extern char *TokenToString PROTO((token)); + +extern struct entry** identtable; + +extern floatish *samplemap; +extern floatish *markmap; + +extern void GetHpFile PROTO((FILE *)); +extern void StoreSample PROTO((struct entry *, intish, floatish)); +extern struct entry *MakeEntry PROTO((char *)); + +extern token GetNumber PROTO((FILE *)); +extern void GetIdent PROTO((FILE *)); +extern void GetString PROTO((FILE *)); +extern boolish IsIdChar PROTO((int)); /* int is a "char" from getc */ + +extern char *jobstring; +extern char *datestring; + +extern char *sampleunitstring; +extern char *valueunitstring; + +#endif /* HP_FILE_H */ diff --git a/ghc/utils/hp2ps/Jmakefile b/ghc/utils/hp2ps/Jmakefile new file mode 100644 index 0000000000..347c799ff5 --- /dev/null +++ b/ghc/utils/hp2ps/Jmakefile @@ -0,0 +1,50 @@ +SRCS_C = \ + AuxFile.c \ + Axes.c \ + AreaBelow.c \ + Curves.c \ + Deviation.c \ + Dimensions.c \ + Error.c \ + HpFile.c \ + Key.c \ + Main.c \ + Marks.c \ + TopTwenty.c \ + TraceElement.c \ + PsFile.c \ + Reorder.c \ + Scale.c \ + Shade.c \ + Utilities.c + +OBJS_C = \ + AuxFile.o \ + Axes.o \ + AreaBelow.o \ + Curves.o \ + Deviation.o \ + Dimensions.o \ + Error.o \ + HpFile.o \ + Key.o \ + Main.o \ + Marks.o \ + TopTwenty.o \ + TraceElement.o \ + PsFile.o \ + Reorder.o \ + Scale.o \ + Shade.o \ + Utilities.o + +SuffixRule_c_o() + +BuildPgmFromCFiles(hp2ps,$(OBJS_C),-lm,) + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTBINDIR_GHC)) +InstallBinaryTarget(hp2ps,$(INSTBINDIR_GHC)) +#endif /* DoInstall... */ + +CDependTarget( $(SRCS_C) ) diff --git a/ghc/utils/hp2ps/Key.c b/ghc/utils/hp2ps/Key.c new file mode 100644 index 0000000000..cafb19e639 --- /dev/null +++ b/ghc/utils/hp2ps/Key.c @@ -0,0 +1,63 @@ +#include <stdio.h> +#include <math.h> +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "Shade.h" + +/* own stuff */ +#include "Key.h" + +static void KeyEntry PROTO((floatish, char *, floatish)); + +void Key() +{ + intish i; + floatish c; + floatish dc; + + for (i = 0; i < nidents; i++) /* count identifiers */ + ; + + c = graphy0; + dc = graphheight / (floatish) (i + 1); + + for (i = 0; i < nidents; i++) { + c += dc; + KeyEntry(c, identtable[i]->name, ShadeOf(identtable[i]->name)); + } +} + + + +static void +KeyEntry(centreline, name, colour) + floatish centreline; char* name; floatish colour; +{ + floatish namebase; + floatish keyboxbase; + floatish kstart; + + namebase = centreline - (floatish) (NORMAL_FONT / 2); + keyboxbase = centreline - ((floatish) KEY_BOX_WIDTH / 2.0); + + kstart = graphx0 + graphwidth; + + fprintf(psfp, "%f %f moveto\n", kstart + borderspace, keyboxbase); + fprintf(psfp, "0 %d rlineto\n", KEY_BOX_WIDTH); + fprintf(psfp, "%d 0 rlineto\n", KEY_BOX_WIDTH); + fprintf(psfp, "0 %d rlineto\n", -KEY_BOX_WIDTH); + fprintf(psfp, "closepath\n"); + + fprintf(psfp, "gsave\n"); + fprintf(psfp, "%f setgray\n", colour); + fprintf(psfp, "fill\n"); + fprintf(psfp, "grestore\n"); + fprintf(psfp, "stroke\n"); + + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "%f %f moveto\n", kstart + (floatish) KEY_BOX_WIDTH + 2 * borderspace, namebase); + + fprintf(psfp, "(%s) show\n", name); +} diff --git a/ghc/utils/hp2ps/Key.h b/ghc/utils/hp2ps/Key.h new file mode 100644 index 0000000000..432541eead --- /dev/null +++ b/ghc/utils/hp2ps/Key.h @@ -0,0 +1,6 @@ +#ifndef KEY_H +#define KEY_H + +extern void Key PROTO((void)); + +#endif /* KEY_H */ diff --git a/ghc/utils/hp2ps/Main.c b/ghc/utils/hp2ps/Main.c new file mode 100644 index 0000000000..7e93541165 --- /dev/null +++ b/ghc/utils/hp2ps/Main.c @@ -0,0 +1,252 @@ +#include <stdio.h> +#include <string.h> +#include "Main.h" +#include "Defines.h" +#include "AuxFile.h" +#include "AreaBelow.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "PsFile.h" +#include "Reorder.h" +#include "Scale.h" +#include "TopTwenty.h" +#include "TraceElement.h" +#include "Deviation.h" +#include "Error.h" +#include "Utilities.h" + +#ifndef atof +extern double atof PROTO((char *)); +#endif + +boolish pflag = 0; /* read auxiliary file */ +boolish eflag = 0; /* scaled EPSF */ +boolish dflag = 0; /* sort by standard deviation */ +int iflag = 0; /* sort by identifier (3-way flag) */ +boolish gflag = 0; /* output suitable for previewer */ +boolish yflag = 0; /* ignore marks */ +boolish bflag = 0; /* use a big title box */ +boolish sflag = 0; /* use a small title box */ +int mflag = 0; /* max no. of bands displayed (default 20) */ +boolish tflag = 0; /* ignored threshold specified */ + +boolish filter; /* true when running as a filter */ + +static floatish WidthInPoints PROTO((char *)); /* forward */ +static FILE *Fp PROTO((char *, char **, char *, char *)); /* forward */ + +char *hpfile; +char *psfile; +char *auxfile; + +char *programname; + +static char *pathName; +static char *baseName; /* "basename" is a std C library name (sigh) */ + +FILE* hpfp; +FILE* psfp; +FILE* auxfp; + +floatish xrange = 0.0; +floatish yrange = 0.0; + +floatish auxxrange = 0.0; +floatish auxyrange = 0.0; + +floatish epsfwidth; +floatish areabelow; + +intish nsamples; +intish nmarks; +intish nidents; + +floatish THRESHOLD_PERCENT = DEFAULT_THRESHOLD; +int TWENTY = DEFAULT_TWENTY; + +int main(argc, argv) +int argc; +char* argv[]; +{ + + programname = copystring(Basename(argv[0])); + + argc--, argv++; + while (argc && argv[0][0] == '-') { + while (*++*argv) + switch(**argv) { + case 'p': + pflag++; + break; + case 'e': + eflag++; + epsfwidth = WidthInPoints(*argv + 1); + goto nextarg; + case 'd': + dflag++; + goto nextarg; + case 'i': + switch( *(*argv + 1) ) { + case '-': + iflag = -1; + case '+': + default: + iflag = 1; + } + goto nextarg; + case 'g': + gflag++; + goto nextarg; + case 'y': + yflag++; + goto nextarg; + case 'b': + bflag++; + goto nextarg; + case 's': + sflag++; + goto nextarg; + case 'm': + mflag++; + TWENTY = atoi(*argv + 1); + if (TWENTY > DEFAULT_TWENTY) + Usage(*argv-1); + goto nextarg; + case 't': + tflag++; + THRESHOLD_PERCENT = (floatish) atof(*argv + 1); + if (THRESHOLD_PERCENT < 0 || THRESHOLD_PERCENT > 5) + Usage(*argv-1); + goto nextarg; + case '?': + default: + Usage(*argv-1); + } +nextarg: ; + argc--, argv++; + } + + hpfile = "stdin"; + psfile = "stdout"; + + hpfp = stdin; + psfp = stdout; + + filter = argc < 1; + + + + if (!filter) { + pathName = copystring(argv[0]); + DropSuffix(pathName, ".hp"); + baseName = copystring(Basename(pathName)); + + hpfp = Fp(pathName, &hpfile, ".hp", "r"); + psfp = Fp(baseName, &psfile, ".ps", "w"); + + if (pflag) auxfp = Fp(baseName, &auxfile, ".aux", "r"); + } + + GetHpFile(hpfp); + + if (!filter && pflag) GetAuxFile(auxfp); + + + TraceElement(); /* Orders on total, Removes trace elements (tflag) */ + + if (dflag) Deviation(); /* ReOrders on deviation */ + + if (iflag) Identorder(iflag); /* ReOrders on identifier */ + + if (pflag) Reorder(); /* ReOrders on aux file */ + + if (TWENTY) TopTwenty(); /* Selects top twenty (mflag) */ + + Dimensions(); + + areabelow = AreaBelow(); + + Scale(); + + PutPsFile(); + + if (!filter) { + auxfp = Fp(baseName, &auxfile, ".aux", "w"); + PutAuxFile(auxfp); + } + + return(0); +} + + + +typedef enum {POINTS, INCHES, MILLIMETRES} pim; + +static pim Units PROTO((char *)); /* forward */ + +static floatish +WidthInPoints(wstr) + char *wstr; +{ + floatish result; + + result = (floatish) atof(wstr); + + switch (Units(wstr)) { + case INCHES: + result *= 72.0; + break; + case MILLIMETRES: + result *= 2.834646; + break; + case POINTS: + default: ; + } + + if (result <= 144) /* Minimum of 2in wide ! */ + Usage(wstr); + + return result; +} + + +static pim +Units(wstr) + char* wstr; +{ +int i; + + i = strlen(wstr) - 2; + + if (wstr[i] == 'p' && wstr[i+1] == 't') { + return POINTS; + } else if (wstr[i] == 'i' && wstr[i+1] == 'n') { + return INCHES; + } else if (wstr[i] == 'm' && wstr[i+1] == 'm') { + return MILLIMETRES; + } else { + return POINTS; + } +} + +static FILE * +Fp(rootname, filename, suffix, mode) + char* rootname; char** filename; char* suffix; char* mode; +{ + *filename = copystring2(rootname, suffix); + + return(OpenFile(*filename, mode)); +} + +#ifdef DEBUG +void +_stgAssert (filename, linenum) + char *filename; + unsigned int linenum; +{ + fflush(stdout); + fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum); + fflush(stderr); + abort(); +} +#endif diff --git a/ghc/utils/hp2ps/Main.h b/ghc/utils/hp2ps/Main.h new file mode 100644 index 0000000000..3ae1dba9f3 --- /dev/null +++ b/ghc/utils/hp2ps/Main.h @@ -0,0 +1,65 @@ +#ifndef MAIN_H +#define MAIN_H + +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) () +#endif + +/* our own ASSERT macro (for C) */ +#ifndef DEBUG +#define ASSERT(predicate) /*nothing*/ + +#else +void _ghcAssert PROTO((char *, unsigned int)); + +#define ASSERT(predicate) \ + if (predicate) \ + /*null*/; \ + else \ + _ghcAssert(__FILE__, __LINE__) +#endif + +/* partain: some ubiquitous types: floatish & intish. + Dubious to use float/int, but that is what it used to be... + (WDP 95/03) +*/ +typedef double floatish; +typedef double doublish; /* higher precision, if anything; little used */ +typedef long intish; +typedef int boolish; + +extern intish nsamples; +extern intish nmarks; +extern intish nidents; + +extern floatish maxcombinedheight; +extern floatish areabelow; +extern floatish epsfwidth; + +extern floatish xrange; +extern floatish yrange; + +extern floatish auxxrange; +extern floatish auxyrange; + +extern boolish eflag; +extern boolish gflag; +extern boolish yflag; +extern boolish bflag; +extern boolish sflag; +extern int mflag; +extern boolish tflag; + +extern char *programname; + +extern char *hpfile; +extern char *psfile; +extern char *auxfile; + +extern FILE *hpfp; +extern FILE *psfp; +extern FILE *auxfp; + +#endif /* MAIN_H */ diff --git a/ghc/utils/hp2ps/Marks.c b/ghc/utils/hp2ps/Marks.c new file mode 100644 index 0000000000..f86cff9939 --- /dev/null +++ b/ghc/utils/hp2ps/Marks.c @@ -0,0 +1,43 @@ +#include <stdio.h> +#include "Main.h" +#include "Curves.h" +#include "Dimensions.h" +#include "HpFile.h" + +/* own stuff */ +#include "Marks.h" + +static void Caret PROTO((floatish, floatish, floatish)); + +void +Marks() +{ + intish i; + floatish m; + + for (i = 0; i < nmarks; i++) { + m = (markmap[i] / xrange) * graphwidth; + Caret(xpage(m), ypage(0.0), 4.0); + } +} + + +/* + * Draw a small white caret at (x,y) with width 2 * d + */ + +static void +Caret(x,y,d) + floatish x; floatish y; floatish d; +{ + fprintf(psfp, "%f %f moveto\n", x - d, y); + fprintf(psfp, "%f %f rlineto\n", d, -d); + fprintf(psfp, "%f %f rlineto\n", d, d); + fprintf(psfp, "closepath\n"); + + fprintf(psfp, "gsave\n"); + fprintf(psfp, "1.0 setgray\n"); + fprintf(psfp, "fill\n"); + fprintf(psfp, "grestore\n"); + fprintf(psfp, "stroke\n"); +} diff --git a/ghc/utils/hp2ps/Marks.h b/ghc/utils/hp2ps/Marks.h new file mode 100644 index 0000000000..07127c988c --- /dev/null +++ b/ghc/utils/hp2ps/Marks.h @@ -0,0 +1,6 @@ +#ifndef MARKS_H +#define MARKS_H + +extern void Marks PROTO((void)); + +#endif /* MARKS_H */ diff --git a/ghc/utils/hp2ps/PsFile.c b/ghc/utils/hp2ps/PsFile.c new file mode 100644 index 0000000000..b2040f1a18 --- /dev/null +++ b/ghc/utils/hp2ps/PsFile.c @@ -0,0 +1,289 @@ +#include <stdio.h> +#include <string.h> +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "Curves.h" +#include "HpFile.h" +#include "Axes.h" +#include "Key.h" +#include "Marks.h" +#include "Utilities.h" + +/* own stuff */ +#include "PsFile.h" + +static void Prologue PROTO((void)); /* forward */ +static void Variables PROTO((void)); /* forward */ +static void BorderOutlineBox PROTO((void)); /* forward */ +static void BigTitleOutlineBox PROTO((void)); /* forward */ +static void TitleOutlineBox PROTO((void)); /* forward */ +static void BigTitleText PROTO((void)); /* forward */ +static void TitleText PROTO((void)); /* forward */ + +void +PutPsFile() +{ + Prologue(); + Variables(); + BorderOutlineBox(); + + if (bflag) { + BigTitleOutlineBox(); + BigTitleText(); + } else { + TitleOutlineBox(); + TitleText(); + } + + CurvesInit(); + + Axes(); + + if (TWENTY) Key(); + + Curves(); + + if (!yflag) Marks(); + + fprintf(psfp, "showpage\n"); +} + + +static void StandardSpecialComments PROTO((void)); /* forward */ +static void EPSFSpecialComments PROTO((floatish)); /* forward */ +static void Landscape PROTO((void)); /* forward */ +static void Portrait PROTO((void)); /* forward */ +static void Scaling PROTO((floatish)); /* forward */ + +static void +Prologue() +{ + floatish epsfscale; + + if (eflag) epsfscale = epsfwidth / (floatish) borderwidth; + + if (eflag) { + EPSFSpecialComments(epsfscale); + } else { + StandardSpecialComments(); + } + + if (eflag) { + Scaling(epsfscale); + } else if (gflag) { + Portrait(); + } else { + Landscape(); + } +} + +extern char *jobstring; +extern char *datestring; + +static void +StandardSpecialComments() +{ + fprintf(psfp, "%%!PS-Adobe-2.0\n"); + fprintf(psfp, "%%%%Title: %s\n", jobstring); + fprintf(psfp, "%%%%Creator: %s (version %s)\n", programname, VERSION); + fprintf(psfp, "%%%%CreationDate: %s\n", datestring); + fprintf(psfp, "%%%%EndComments\n"); +} + +static void +EPSFSpecialComments(epsfscale) + floatish epsfscale; +{ + fprintf(psfp, "%%!PS-Adobe-2.0\n"); + fprintf(psfp, "%%%%Title: %s\n", jobstring); + fprintf(psfp, "%%%%Creator: %s (version %s)\n", programname, VERSION); + fprintf(psfp, "%%%%CreationDate: %s\n", datestring); + fprintf(psfp, "%%%%BoundingBox: 0 0 %d %d\n", + (int) (borderwidth * epsfscale + 0.5), + (int) (borderheight * epsfscale + 0.5) ); + fprintf(psfp, "%%%%EndComments\n"); +} + + + +static void +Landscape() +{ + fprintf(psfp, "-90 rotate\n"); + fprintf(psfp, "%f %f translate\n", -(borderwidth + (floatish) START_Y), + (floatish) START_X); +} + +static void +Portrait() +{ + fprintf(psfp, "%f %f translate\n", (floatish) START_X, (floatish) START_Y); +} + +static void +Scaling(epsfscale) + floatish epsfscale; +{ + fprintf(psfp, "%f %f scale\n", epsfscale, epsfscale); +} + + +static void +Variables() +{ + fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n", + NORMAL_FONT, NORMAL_FONT); + + fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n", + LARGE_FONT, LARGE_FONT); +} + + +static void +BorderOutlineBox() +{ + fprintf(psfp, "newpath\n"); + fprintf(psfp, "0 0 moveto\n"); + fprintf(psfp, "0 %f rlineto\n", borderheight); + fprintf(psfp, "%f 0 rlineto\n", borderwidth); + fprintf(psfp, "0 %f rlineto\n", -borderheight); + fprintf(psfp, "closepath\n"); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); +} + +static void +BigTitleOutlineBox() +{ + fprintf(psfp, "newpath\n"); + fprintf(psfp, "%f %f moveto\n", borderspace, + borderheight - titleheight - borderspace); + fprintf(psfp, "0 %f rlineto\n", titleheight); + fprintf(psfp, "%f 0 rlineto\n", titlewidth); + fprintf(psfp, "0 %f rlineto\n", -titleheight); + fprintf(psfp, "closepath\n"); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); + + fprintf(psfp, "%f %f moveto\n", borderspace, + borderheight - titleheight / 2 - borderspace); + fprintf(psfp, "%f 0 rlineto\n", titlewidth); + fprintf(psfp, "stroke\n"); +} + + +static void +TitleOutlineBox() +{ + fprintf(psfp, "newpath\n"); + fprintf(psfp, "%f %f moveto\n", borderspace, + borderheight - titleheight - borderspace); + fprintf(psfp, "0 %f rlineto\n", titleheight); + fprintf(psfp, "%f 0 rlineto\n", titlewidth); + fprintf(psfp, "0 %f rlineto\n", -titleheight); + fprintf(psfp, "closepath\n"); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); +} + +static void EscapePrint PROTO((char *, int)); /* forward */ + +static void +BigTitleText() +{ + floatish x, y; + + x = borderspace + titletextspace; + y = borderheight - titleheight / 2 - borderspace + titletextspace; + + /* job identifier goes on top at the far left */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "%f %f moveto\n", x, y); + fputc('(', psfp); + EscapePrint(jobstring, BIG_JOB_STRING_WIDTH); + fprintf(psfp, ") show\n"); + + y = borderheight - titleheight - borderspace + titletextspace; + + /* area below curve gows at the botton, far left */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "%f %f moveto\n", x, y); + fputc('(', psfp); + CommaPrint(psfp, (int) areabelow); + fprintf(psfp, " %s x %s)\n", valueunitstring, sampleunitstring); + fprintf(psfp, "show\n"); + + /* date goes at far right */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "(%s)\n", datestring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", (titlewidth + borderspace) - titletextspace); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", y); + fprintf(psfp, "show\n"); +} + + +static void +TitleText() +{ + floatish x, y; + + x = borderspace + titletextspace; + y = borderheight - titleheight - borderspace + titletextspace; + + /* job identifier goes at far left */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "%f %f moveto\n", x, y); + fputc('(', psfp); + EscapePrint(jobstring, SMALL_JOB_STRING_WIDTH); + fprintf(psfp, ") show\n"); + + /* area below curve is centered */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fputc('(', psfp); + CommaPrint(psfp, (int) areabelow); + fprintf(psfp, " %s x %s)\n", valueunitstring, sampleunitstring); + + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "2 div\n"); + fprintf(psfp, "%f\n", titlewidth / 2); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", y); + fprintf(psfp, "show\n"); + + /* date goes at far right */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "(%s)\n", datestring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", (titlewidth + borderspace) - titletextspace); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", y); + fprintf(psfp, "show\n"); +} + +/* + * Print a string s in width w, escaping characters where necessary. + */ + +static void +EscapePrint(s,w) + char* s; int w; +{ + for ( ; *s && w > 0; s++, w--) { + if (*s == '(') { /* escape required */ + fputc('\\', psfp); + } else if (*s == ')') { + fputc('\\', psfp); + } + + fputc(*s, psfp); + } +} diff --git a/ghc/utils/hp2ps/PsFile.h b/ghc/utils/hp2ps/PsFile.h new file mode 100644 index 0000000000..50559d12f9 --- /dev/null +++ b/ghc/utils/hp2ps/PsFile.h @@ -0,0 +1,6 @@ +#ifndef PS_FILE_H +#define PS_FILE_H + +extern void PutPsFile PROTO((void)); + +#endif /* PS_FILE_H */ diff --git a/ghc/utils/hp2ps/README.GHC b/ghc/utils/hp2ps/README.GHC new file mode 100644 index 0000000000..a3fb21e922 --- /dev/null +++ b/ghc/utils/hp2ps/README.GHC @@ -0,0 +1,4 @@ +This "hp2ps" program was written and is maintained by Dave Wakeling at +York. All I (WDP) have done is make it slot into the "make world"ery. + +We are grateful for this contribution of shared code. diff --git a/ghc/utils/hp2ps/Reorder.c b/ghc/utils/hp2ps/Reorder.c new file mode 100644 index 0000000000..94bda2c5b4 --- /dev/null +++ b/ghc/utils/hp2ps/Reorder.c @@ -0,0 +1,89 @@ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "Reorder.h" + +static struct order { + char* ident; + int order; +} *ordermap = 0; + +static int ordermapmax = 0; +static int ordermapindex = 0; + + +void +OrderFor(ident, order) + char* ident; + int order; +{ + if (! ordermap) { + ordermapmax = (nidents > TWENTY ? nidents : TWENTY) * 2; + /* Assume nidents read is indication of the No of + idents in the .aux file (*2 for good luck !) */ + ordermap = xmalloc(ordermapmax * sizeof(struct order)); + } + + if (ordermapindex < ordermapmax) { + ordermap[ ordermapindex ].ident = copystring(ident); + ordermap[ ordermapindex ].order = order; + ordermapindex++; + } else { + Disaster("order map overflow"); + } +} + +/* + * Get the order of to be used for "ident" if there is one. + * Otherwise, return 0 which is the minimum ordering value. + */ + +int +OrderOf(ident) + char* ident; +{ + int i; + + for (i = 0; i < ordermapindex; i++) { + if (strcmp(ordermap[i].ident, ident) == 0) { /* got it */ + return(ordermap[i].order); + } + } + + return 0; +} + +/* + * Reorder on the basis of information from ".aux" file. + */ + +void +Reorder() +{ + intish i; + intish j; + int min; + struct entry* e; + int o1, o2; + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + o1 = OrderOf(identtable[ j ]->name); + o2 = OrderOf(identtable[ min ]->name); + + if (o1 < o2 ) min = j; + } + + e = identtable[ min ]; + identtable[ min ] = identtable[ i ]; + identtable[ i ] = e; + } +} diff --git a/ghc/utils/hp2ps/Reorder.h b/ghc/utils/hp2ps/Reorder.h new file mode 100644 index 0000000000..09ab3597d0 --- /dev/null +++ b/ghc/utils/hp2ps/Reorder.h @@ -0,0 +1,8 @@ +#ifndef REORDER_H +#define REORDER_H + +extern void Reorder PROTO((void)); +extern int OrderOf PROTO((char *)); +extern void OrderFor PROTO((char *, int)); + +#endif /* REORDER_H */ diff --git a/ghc/utils/hp2ps/Scale.c b/ghc/utils/hp2ps/Scale.c new file mode 100644 index 0000000000..576e173c14 --- /dev/null +++ b/ghc/utils/hp2ps/Scale.c @@ -0,0 +1,87 @@ +#include <stdio.h> +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "Scale.h" + +/* + * Return the maximum combined height that all the sample + * curves will reach. This (absolute) figure can then be + * used to scale the samples automatically so that they + * fit on the page. + */ + +extern void free(); + +floatish +MaxCombinedHeight() +{ + intish i; + intish j; + floatish mx; + int bucket; + floatish value; + struct chunk* ch; + floatish *maxima; + + maxima = (floatish*) xmalloc(nsamples * sizeof(floatish)); + for (i = 0; i < nsamples; i++) { + maxima[ i ] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + bucket = ch->d[j].bucket; + value = ch->d[j].value; + if (bucket >= nsamples) + Disaster("bucket out of range"); + maxima[ bucket ] += value; + } + } + } + + for (mx = maxima[ 0 ], i = 0; i < nsamples; i++) { + if (maxima[ i ] > mx) mx = maxima[ i ]; + } + + free(maxima); + return mx; +} + + + +/* + * Scale the values from the samples so that they will fit on + * the page. + */ + +extern floatish xrange; +extern floatish yrange; + +void +Scale() +{ + intish i; + intish j; + floatish sf; + struct chunk* ch; + + if (yrange == 0.0) /* no samples */ + return; + + sf = graphheight / yrange; + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + ch->d[j].value = ch->d[j].value * sf; + } + } + } +} diff --git a/ghc/utils/hp2ps/Scale.h b/ghc/utils/hp2ps/Scale.h new file mode 100644 index 0000000000..a1c4051c31 --- /dev/null +++ b/ghc/utils/hp2ps/Scale.h @@ -0,0 +1,7 @@ +#ifndef SCALE_H +#define SCALE_H + +extern floatish MaxCombinedHeight PROTO((void)); +extern void Scale PROTO((void)); + +#endif /* SCALE_H */ diff --git a/ghc/utils/hp2ps/Shade.c b/ghc/utils/hp2ps/Shade.c new file mode 100644 index 0000000000..0a03decb95 --- /dev/null +++ b/ghc/utils/hp2ps/Shade.c @@ -0,0 +1,92 @@ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "Utilities.h" + +/* own stuff */ +#include "Shade.h" + +static struct shade { + char* ident; + floatish shade; +} *shademap; + +static int shademapmax = 0; +static int shademapindex = 0; + +/* + * Set the shade to be used for "ident" to "shade". + */ + +void +ShadeFor(ident, shade) + char* ident; + floatish shade; +{ + if (! shademap) { + shademapmax = (nidents > TWENTY ? nidents : TWENTY) * 2; + /* Assume nidents read is indication of the No of + idents in the .aux file (*2 for good luck) */ + /* NB *2 is needed as .aux and .hp elements may differ */ + shademap = xmalloc(shademapmax * sizeof(struct shade)); + } + + if (shademapindex < shademapmax) { + shademap[ shademapindex ].ident = copystring(ident); + shademap[ shademapindex ].shade = shade; + shademapindex++; + } else { + Disaster("shade map overflow"); + } +} + +/* + * Get the shade to be used for "ident" if there is one. + * Otherwise, think of a new one. + */ + +static floatish ThinkOfAShade PROTO((void)); /* forward */ + +floatish +ShadeOf(ident) + char* ident; +{ + int i; + floatish shade; + + for (i = 0; i < shademapindex; i++) { + if (strcmp(shademap[i].ident, ident) == 0) { /* got it */ + return(shademap[i].shade); + } + } + + shade = ThinkOfAShade(); + + ShadeFor(ident, shade); + + return shade; +} + + + +#define N_SHADES 10 + +static floatish shades[ N_SHADES ] = { + 0.00000, 0.20000, 0.60000, 0.30000, 0.90000, + 0.40000, 1.00000, 0.70000, 0.50000, 0.80000 +}; + +static floatish +ThinkOfAShade() +{ + static int thisshade = 0; + + floatish x; + + x = shades[ thisshade ]; + thisshade = (thisshade + 1) % N_SHADES; + return x; +} diff --git a/ghc/utils/hp2ps/Shade.h b/ghc/utils/hp2ps/Shade.h new file mode 100644 index 0000000000..b6dd271b64 --- /dev/null +++ b/ghc/utils/hp2ps/Shade.h @@ -0,0 +1,7 @@ +#ifndef SHADE_H +#define SHADE_H + +extern floatish ShadeOf PROTO((char *)); +extern void ShadeFor PROTO((char *, floatish)); + +#endif /* SHADE_H */ diff --git a/ghc/utils/hp2ps/TopTwenty.c b/ghc/utils/hp2ps/TopTwenty.c new file mode 100644 index 0000000000..9060aaf6d2 --- /dev/null +++ b/ghc/utils/hp2ps/TopTwenty.c @@ -0,0 +1,73 @@ +#include <stdio.h> +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "TopTwenty.h" + +/* + * We only have room in the key for a maximum of 20 identifiers. + * We therefore choose to keep the top 20 bands --- these will + * be the most important ones, since this pass is performed after + * the threshold and standard deviation passes. If there are more + * than 20 bands, the excess are gathered together as an "OTHER" ] + * band which appears as band 20. + */ + +extern void free(); + +void +TopTwenty() +{ + intish i; + intish j; + intish compact; + intish bucket; + floatish value; + struct entry* en; + struct chunk* ch; + floatish *other; + + i = nidents; + if (i <= TWENTY) return; /* nothing to do! */ + + other = (floatish*) xmalloc(nsamples * sizeof(floatish)); + /* build a list of samples for "OTHER" */ + + compact = (i - TWENTY) + 1; + + for (i = 0; i < nsamples; i++) { + other[ i ] = 0.0; + } + + for (i = 0; i < compact && i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + bucket = ch->d[j].bucket; + value = ch->d[j].value; + if (bucket >= nsamples) + Disaster("bucket out of range"); + other[ bucket ] += value; + } + } + } + + en = MakeEntry("OTHER"); + en->next = 0; + + for (i = 0; i < nsamples; i++) { + StoreSample(en, i, other[i]); + } + + /* slide samples down */ + for (i = compact; i < nidents; i++) { + identtable[i-compact+1] = identtable[i]; + } + + nidents = TWENTY; + identtable[0] = en; + free(other); +} diff --git a/ghc/utils/hp2ps/TopTwenty.h b/ghc/utils/hp2ps/TopTwenty.h new file mode 100644 index 0000000000..4dff203b38 --- /dev/null +++ b/ghc/utils/hp2ps/TopTwenty.h @@ -0,0 +1,6 @@ +#ifndef TOP_TWENTY_H +#define TOP_TWENTY_H + +extern void TopTwenty PROTO((void)); + +#endif /* TOP_TWENTY_H */ diff --git a/ghc/utils/hp2ps/TraceElement.c b/ghc/utils/hp2ps/TraceElement.c new file mode 100644 index 0000000000..984faf5325 --- /dev/null +++ b/ghc/utils/hp2ps/TraceElement.c @@ -0,0 +1,97 @@ +#include <stdio.h> +#include "Main.h" +#include "Defines.h" +#include "HpFile.h" +#include "Error.h" +#include "Utilities.h" + +/* own stuff */ +#include "TraceElement.h" + +/* + * Compute the total volume for each identifier, and the grand + * total of these totals. The identifiers whose totals when + * added together amount to less that a threshold percentage + * (default 1%) of the grand total are considered to be ``trace + * elements'' and they are thrown away. + */ + +extern void free(); + +extern floatish thresholdpercent; + +void TraceElement() +{ + intish i; + intish j; + struct chunk* ch; + floatish grandtotal; + intish min; + floatish t; + floatish p; + struct entry* e; + intish *totals; + + totals = (intish *) xmalloc(nidents * sizeof(intish)); + + /* find totals */ + + for (i = 0; i < nidents; i++) { + totals[ i ] = 0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + totals[ i ] += ch->d[j].value; + } + } + } + + /* sort on the basis of total */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (totals[ j ] < totals[ min ]) { + min = j; + } + } + + t = totals[ min ]; + totals[ min ] = totals[ i ]; + totals[ i ] = t; + + e = identtable[ min ]; + identtable[ min ] = identtable[ i ]; + identtable[ i ] = e; + } + + + /* find the grand total (NB: can get *BIG*!) */ + + grandtotal = 0.0; + + for (i = 0; i < nidents; i++) { + grandtotal += (floatish) totals[ i ]; + } + + t = 0.0; /* cumulative percentage */ + + for (i = 0; i < nidents; i++) { + p = (100.0 * (floatish) totals[i]) / grandtotal; + t = t + p; + if (t >= THRESHOLD_PERCENT) { + break; + } + } + + /* identifiers from 0 to i-1 should be removed */ + for (j = 0; i < nidents; i++, j++) { + identtable[j] = identtable[i]; + } + + nidents = j; + + free(totals); +} diff --git a/ghc/utils/hp2ps/TraceElement.h b/ghc/utils/hp2ps/TraceElement.h new file mode 100644 index 0000000000..d843392a23 --- /dev/null +++ b/ghc/utils/hp2ps/TraceElement.h @@ -0,0 +1,6 @@ +#ifndef TRACE_ELEMENT_H +#define TRACE_ELEMENT_H + +void TraceElement PROTO((void)); + +#endif /* TRACE_ELEMENT_H */ diff --git a/ghc/utils/hp2ps/Utilities.c b/ghc/utils/hp2ps/Utilities.c new file mode 100644 index 0000000000..c6faca4ab9 --- /dev/null +++ b/ghc/utils/hp2ps/Utilities.c @@ -0,0 +1,132 @@ +#include <stdio.h> +#include <string.h> +#include "Main.h" +#include "Error.h" + +extern void* malloc(); + +char* +Basename(name) + char* name; +{ + char* t; + + t = name; + + while (*name) { + if (*name == '/') { + t = name+1; + } + name++; + } + + return t; +} + +void +DropSuffix(name, suffix) + char* name; char* suffix; +{ + char* t; + + t = (char*) 0; + + while (*name) { + if (*name == '.') { + t = name; + } + name++; + } + + if (t != (char*) 0 && strcmp(t, suffix) == 0) { + *t = '\0'; + } +} + +FILE* +OpenFile(s, mode) + char* s; char* mode; +{ + FILE* r; + + if ((r = fopen(s, mode)) == NULL) { + /*NOTREACHED*/ + Error("cannot open %s", s); + } + + return r; +} + + +#define ONETHOUSAND 1000 + +/* + * Print a positive integer with commas + */ + +void +CommaPrint(fp,n) + FILE* fp; + int n; +{ + if (n < ONETHOUSAND) { + fprintf(fp, "%d", n); + } else { + CommaPrint(fp, n / ONETHOUSAND); + fprintf(fp, ",%03d", n % ONETHOUSAND); + } +} + +void * +xmalloc(n) + int n; +{ + void *r; + + r = (void*) malloc(n); + if (!r) { + /*NOTREACHED*/ + Disaster("%s, sorry, out of memory", hpfile); + } + return r; +} + +void * +xrealloc(p, n) + void *p; + int n; +{ + void *r; + extern void *realloc(); + + r = realloc(p, n); + if (!r) { + /*NOTREACHED*/ + Disaster("%s, sorry, out of memory", hpfile); + } + return r; +} + +char * +copystring(s) + char *s; +{ + char *r; + + r = (char*) xmalloc(strlen(s)+1); + strcpy(r, s); + return r; +} + +char * +copystring2(s, t) + char *s, *t; +{ + char *r; + + r = (char*) xmalloc(strlen(s)+strlen(t)+1); + strcpy(r, s); + strcat(r, t); + return r; +} + diff --git a/ghc/utils/hp2ps/Utilities.h b/ghc/utils/hp2ps/Utilities.h new file mode 100644 index 0000000000..d8195b788a --- /dev/null +++ b/ghc/utils/hp2ps/Utilities.h @@ -0,0 +1,13 @@ +#ifndef UTILITIES_H +#define UTILITIES_H + +extern char* Basename PROTO((char *)); +extern void DropSuffix PROTO((char *, char *)); +extern FILE* OpenFile PROTO((char *, char *)); +extern void CommaPrint PROTO((FILE *, int)); +extern char *copystring PROTO((char *)); +extern char *copystring2 PROTO((char *, char *)); +extern void *xmalloc PROTO((int)); +extern void *xrealloc PROTO((void *, int)); + +#endif /* UTILITIES_H */ diff --git a/ghc/utils/hp2ps/hp2ps.1 b/ghc/utils/hp2ps/hp2ps.1 new file mode 100644 index 0000000000..fa81d34a52 --- /dev/null +++ b/ghc/utils/hp2ps/hp2ps.1 @@ -0,0 +1,143 @@ +.\" man page for hp2ps +.ds PS P\s-2OST\s+2S\s-2CRIPT\s+2 +.\" typeset examples in fixed size font as indented paragraph +.de Ex +.sp +.RS +.nf +.ft C +.. +.de Xe +.RE +.sp +.fi +.. +.TH HP2PS 1 "18 April 1992" +.SH NAME +hp2ps \- convert a heap profile to a \*(PS graph +.SH SYNOPSIS +.B hp2ps +[flags] [file][.hp] +.SH DESCRIPTION +The program +.B hp2ps +converts a heap profile stored in +.IR file +into a \*(PS graph, sending the result to +.IR file.ps. +By convention, files to be processed by +.B hp2ps +have a +.I .hp +extension. However, for compatibility with older versions of +.B hp2ps, +this extension can be omitted. If +.IR file +is omitted entirely, then the program behaves as a filter. +.SH OPTIONS +The flags are: +.IP "\fB\-d\fP" +In order to make graphs more readable, +.B hp2ps +sorts the shaded bands for each identifier. The default sort ordering is for +the bands with the largest area to be stacked on top of the smaller ones. +The +.B \-d +option causes rougher bands (those reprsenting series of values with the +largest standard deviations) to be stacked on top of smoother ones. +.IP "\fB\-b\fP" +Normally, +.B hp2ps +puts the title of the graph in a small box at the top of the page. However, +if the JOB string is too long to fit in a small box (more than 35 characters), +then +.B hp2ps +will choose to use a big box instead. The +.B \-b +option forces +.B hp2ps +to use a big box. +.IP "\fB\-e\fP \fIfloat\fP[in|mm|pt]" +Generate encapsulated \*(PS suitable for inclusion in LaTeX documents. +Usually, the \*(PS graph is drawn in landscape mode in an area +9 inches wide by 6 inches high, and +.B hp2ps +arranges for this area to be approximately centered on a sheet of a4 +paper. This format is convenient of studying the graph in detail, but +it is unsuitable for inclusion in LaTeX documents. The +.B \-e +option causes the graph to be drawn in portrait mode, with +.I float +specifying the width in inches, millimetres or points (the default). +The resulting \*(PS file conforms to the +.I "Encapsulated Post Script" +(EPS) convention, and it can be included in a LaTeX document using Rokicki's +dvi-to-\*(PS converter +.B dvips. +.IP "\fB\-g\fP" +Create output suitable for the +.B gs +\*(PS previewer (or similar). In this case the graph is printed in portrait +mode without scaling. The output is unsuitable for a laser printer. +.IP "\fB\-p\fP" +Use previous parameters. By default, the \*(PS graph is automatically +scaled both horizontally and vertically so that it fills the page. +However, when preparing a seires of graphs for use in a presentation, +it is often useful to draw a new graph using the same scale, shading and +ordering as a previous one. The +.B \-p +flag causes the graph to be drawn using the parameters determined by +a previous run of +.B hp2ps +on +.IR file. +.IP "\fB\-s\fP" +Use a small box for the title. +.IP "\fB\-y\fP" +Draw the graph in the traditional York style, ignoring marks. +.IP "\fB\-?\fP" +Print out usage information. +.SH "INPUT FORMAT" +The format of a heap profile is best described by example: +.Ex +JOB "a.out -p" +DATE "Fri Apr 17 11:43:45 1992" +SAMPLE_UNIT "seconds" +VALUE_UNIT "bytes" +BEGIN_SAMPLE 0.00 + SYSTEM 24 +END_SAMPLE 0.00 +BEGIN_SAMPLE 1.00 + elim 180 + insert 24 + intersect 12 + disin 60 + main 12 + reduce 20 + SYSTEM 12 +END_SAMPLE 1.00 +MARK 1.50 +MARK 1.75 +MARK 1.80 +BEGIN_SAMPLE 2.00 + elim 192 + insert 24 + intersect 12 + disin 84 + main 12 + SYSTEM 24 +END_SAMPLE 2.00 +BEGIN_SAMPLE 2.82 +END_SAMPLE 2.82 + +.Xe +.SH "SEE ALSO" +dvips(1), latex(1), hbchp (1), lmlchp(1) +.br +C. Runciman and D. Wakeling, +.I +Heap Profiling for Lazy Functional Languages, YCS-172, University of York, 1992 +.SH NOTES +\*(PS is a registered trademark of Adobe Systems Incorporated. +.SH AUTHOR +David Wakeling of the University of York. diff --git a/ghc/utils/hp2ps/makefile.original b/ghc/utils/hp2ps/makefile.original new file mode 100644 index 0000000000..a625149552 --- /dev/null +++ b/ghc/utils/hp2ps/makefile.original @@ -0,0 +1,42 @@ +OBJS= \ + AuxFile.o \ + Axes.o \ + AreaBelow.o \ + Curves.o \ + Deviation.o \ + Dimensions.o \ + Error.o \ + HpFile.o \ + Key.o \ + Main.o \ + Marks.o \ + TopTwenty.o \ + TraceElement.o \ + PsFile.o \ + Reorder.o \ + Scale.o \ + Shade.o \ + Utilities.o + +# Please set MATHLIB and BIN appropriately. I don't need MATHLIB on my machine, +# but you may. + +MATHLIB = -lm + +DSTBIN = /n/Numbers/usr/lml/lml-0.997.4hp/sun3/bin + +CC= cc # gcc -Wall +CFLAGS= -g +LDFLAGS= ${STATICFLAG} + +TARGET=hp2ps + +${TARGET}: ${OBJS} + ${CC} -o ${TARGET} ${CCFLAGS} ${LDFLAGS} ${OBJS} ${MATHLIB} + +install: ${TARGET} + mv ${TARGET} ${DSTBIN}/${TARGET} + chmod 555 ${DSTBIN}/${TARGET} + +clean: + rm -f core *.o ${TARGET} diff --git a/ghc/utils/hscpp/Jmakefile b/ghc/utils/hscpp/Jmakefile new file mode 100644 index 0000000000..c40e9e5e28 --- /dev/null +++ b/ghc/utils/hscpp/Jmakefile @@ -0,0 +1,30 @@ +PROGRAMS = hscpp + +all:: $(PROGRAMS) +/* stuff to have before we get going */ +MsubNeededHere($(PROGRAMS)) + +/* === BUILD STUFF (installation, etc., below) ========== */ + +Makefile :: + $(RM) hscpp + +/* do *not* want #! script stuck on the front */ +MsubTarget(hscpp,hscpp.prl,/*no flags*/,/*Makefile*/) + +hscpp :: + @chmod a+x $@ + +/* === INSTALLATION ======== */ + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC)) +InstallScriptTarget(hscpp, $(INSTLIBDIR_GHC)) +#endif /* DoInstall... */ + +/* === OTHER STUFF ========= */ + +ExtraStuffToClean($(PROGRAMS)) + +ClearTagsFile() +PerlTagsTarget( *.prl ) /* nothing for the Bourne shell scripts */ diff --git a/ghc/utils/hscpp/hscpp.prl b/ghc/utils/hscpp/hscpp.prl new file mode 100644 index 0000000000..0a75c2de53 --- /dev/null +++ b/ghc/utils/hscpp/hscpp.prl @@ -0,0 +1,186 @@ +eval "exec perl -S $0 $*" + if $running_under_some_random_shell; +# +# reads CPP output and turns #line things into appropriate Haskell +# pragmas +# +# considered to be GHC-project specific +# +# +# OPTIONALLY processes GENERATE_SPECS pragmas +# when give flag -genSPECS +# +# EXAMPLE: +# +# {-# GENERATE_SPECS a b #-} +# fn :: type +# +#==>> +# +# fn :: type +# {-# SPECIALIZE fn :: type[ a/a,u1/b] #-} +# {-# SPECIALIZE fn :: type[ a/a,u2/b] #-} +# {-# SPECIALIZE fn :: type[u1/a, b/b] #-} +# {-# SPECIALIZE fn :: type[u1/a,u1/b] #-} +# {-# SPECIALIZE fn :: type[u1/a,u2/b] #-} +# {-# SPECIALIZE fn :: type[u2/a, b/b] #-} +# {-# SPECIALIZE fn :: type[u2/a,u1/b] #-} +# {-# SPECIALIZE fn :: type[u2/a,u2/b] #-} +# +# where the u's are extracted from a predetermined +# set of unboxed types $SpecingString +# +# The types to substitute can be specified explicitly in { }s following +# the type variable +# +# EXAMPLES: +# +# {-# GENERATE_SPECS a{ty1,ty2...} b{+,ty1,ty2...} c{~,ty1,ty2,...} d{~,+,ty1,ty2,...} #-} +# fn :: type +# +# where +# ~ indicates that no specialisations are to be left polymorhphic in this type variable +# (this is required for overloaded tyvars which must have ground specialisations) +# + indicates that the predetermined types are to be added to the list +# +# Note: There must be no white space between { }s +# Use ( )s around type names when separation is required +# + +$Verbose = 0; +while ($#ARGV >= 0 && $ARGV[0] eq '-v' || $ARGV[0] =~ /^-genSPECS/) { + if ($ARGV[0] eq '-v') { + $Verbose = 1; + } elsif ( $ARGV[0] eq '-genSPECS0' ) { # do it, but no SpecingString + $SpecingString = ''; + @SpecingTypes = (); + $DoGenSpecs = 1; + } else { + shift(@ARGV); + $SpecingString = $ARGV[0]; + @SpecingTypes = split(/,/, $SpecingString); + $DoGenSpecs = 1; + } + shift(@ARGV); +} +#ToDo: print a version number ? + +$OrigCpp = '$(RAWCPP)'; + +if ( $OrigCpp =~ /(\S+)\s+(.*)/ ) { + $cmd = $1; + $rest = $2; + if ( -x $cmd ) { # cool + $Cpp = $OrigCpp; + } else { # oops; try to guess + $GccV = `gcc -v 2>&1`; + if ( $GccV =~ /Reading specs from (.*)\/specs/ ) { + $Cpp = "$1/cpp $rest"; + } else { + die "hscpp: don't know how to run cpp: $OrigCpp\n"; + } + } +} else { + $Cpp = $OrigCpp; +} + +print STDERR "hscpp:CPP invoked: $Cpp @ARGV\n" if $Verbose; + +open(INPIPE, "$Cpp @ARGV |") || die "Can't open C pre-processor pipe\n"; + +while (<INPIPE>) { + +# line directives come in flavo[u]rs: +# s/^#\s*line\s+\d+$/\{\-# LINE \-\}/; IGNORE THIS ONE FOR NOW + s/^#\s*line\s+(\d+)\s+(\".+\")$/\{\-# LINE \1 \2 \-\}/; + s/^#\s*(\d+)\s+(\".*\").*/\{\-# LINE \1 \2 \-\}/; + +# genSPEC processing: + if ( /^\s*\{-#\s*GENERATE_SPECS/ ) { + if ( $DoGenSpecs ) { + $data_or_inst = 0; + $data_inst_str = ""; + $remove_poly = 1; + + if ( /^\s*\{-#\s*GENERATE_SPECS\s+(data)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) { + $data_or_inst = 1; + $data_inst_str = $1; + $vars = $2; + $type = $3; + } elsif ( /^\s*\{-#\s*GENERATE_SPECS\s+(instance)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) { + $data_or_inst = 1; + $data_inst_str = $1; + $vars = $2; + $type = $3; + } elsif ( /^\s*\{-#\s*GENERATE_SPECS\s+(\S+)\s+(.*)\s*#-\}\s*$/ ) { + $line = $_; + $fun = $1; + $vars = $2; + + $tysig = <INPIPE>; + while ( $tysig =~ /^\s*$/ ) { + print $tysig; + $tysig = <INPIPE>; + } + $funpat = $fun; # quote non alphanumeric characters in pattern + $funpat =~ s/(\W)/\\\1/g; + $tysig =~ /^\s*$funpat\s*::(.*)$/ || die "Error: GENERATE_SPECS not followed by type signature for $fun:\n$line$tysig\n"; + $type = $1; + $type =~ s/^(.*)=>//; # remove context from type + } else { + die "Error: invlaid GENERATE_SPECS pragma:\n $_"; + } + + @tyvars = split(/\s+/, $vars); + @tospec = ($type); + foreach $var (@tyvars) { + @specing = @tospec; + + if ( $var =~ /^(\w+)\{(.*)\}$/ ) { + $var = $1; + @specing_types = split(/,/, $2); + if ($specing_types[0] eq '~') { + shift(@specing_types); + @tospec = (); # remove specs polymorphic in this tyvar + $remove_poly = 0; + } + if ($specing_types[0] eq '+') { + shift(@specing_types); + unshift(@specing_types, @SpecingTypes); + } + } else { + @specing_types = @SpecingTypes; + } + + foreach $uty (@specing_types) { + @speced = @specing; + foreach $i (0..$#speced) { + $speced[$i] =~ s/\b$var\b/$uty/g ; + } + push(@tospec, @speced); + } + } + shift(@tospec) if $remove_poly; # remove fully polymorphic spec + + if ($#tospec >= 0) { + $specty = shift(@tospec); + print ($data_or_inst ? "{-# SPECIALIZE $data_inst_str $specty #-}" : "{-# SPECIALIZE $fun :: $specty"); + while ($#tospec >= 0) { + $specty = shift(@tospec); + print ($data_or_inst ? "; {-# SPECIALIZE $data_inst_str $specty #-}" : ", $specty"); + } + print ($data_or_inst ? "\n" : " #-}\n"); + } else { + print "{-# NO_SPECS_GENERATED ", $data_or_inst ? $specty : $fun, " #-}\n"; + } + print $tysig if ! $data_or_inst; + } else { + print STDERR "Warning: GENERATE_SPECS pre-processing pragma ignored:\n $_"; + print $_; + } + } else { + print $_; + } +} + +close(INPIPE) || exit(1); # exit is so we reflect any errors. diff --git a/ghc/utils/hstags/Jmakefile b/ghc/utils/hstags/Jmakefile new file mode 100644 index 0000000000..ae1d844ba9 --- /dev/null +++ b/ghc/utils/hstags/Jmakefile @@ -0,0 +1,20 @@ +PROGRAMS = hstags hstags-help + +SuffixRule_c_o() + +all:: $(PROGRAMS) +/* stuff to have before we get going */ +MsubNeededHere(hstags) + +MsubMakefileDependentProgramScriptTarget(PerlCmd,hstags,hstags.prl,/*no flags*/,/*Makefile*/) +BuildPgmFromOneCFile(hstags-help) + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC) $(INSTBINDIR_GHC)) +InstallMsubbedScriptTarget(PerlCmd,hstags,hstags.prl,$(INSTBINDIR_GHC)) +InstallBinaryTarget(hstags-help, $(INSTLIBDIR_GHC)) +#endif /* DoInstall... */ + +ExtraStuffToClean($(PROGRAMS)) +ClearTagsFile() +PerlTagsTarget( hstags.prl ) diff --git a/ghc/utils/hstags/README b/ghc/utils/hstags/README new file mode 100644 index 0000000000..388a8e869b --- /dev/null +++ b/ghc/utils/hstags/README @@ -0,0 +1,10 @@ +"hstags" is a relatively sophisticated program to produce Emacs TAGS +files for Glasgow-Haskell-compilable programs. (It is "sophisticated" +only in that it uses the GHC parser to find "interesting" things in +the source files.) + +A simpler alternative is Denis Howe's "fptags" script, which is +distributed in the ghc/CONTRIB directory. + +Will Partain +Sept 1994 diff --git a/ghc/utils/hstags/hstags-help.c b/ghc/utils/hstags/hstags-help.c new file mode 100644 index 0000000000..92604876ff --- /dev/null +++ b/ghc/utils/hstags/hstags-help.c @@ -0,0 +1,59 @@ +#include <stdio.h> +#include <string.h> /* for strlen */ + +/* typedef enum { False, True } Boolean; */ + +#define SKIP /* Algol-68 lives */ + +main(argc,argv) +int argc; +char **argv; +{ + unsigned line; + FILE *srcf; + int thisline = 0, lastline = 0, linestart = 0; + char linebuff[1024]; + + if(argc < 2) + { + fprintf(stderr,"usage: %s sourcefile",argv[0]); + exit(1); + } + + if((srcf=fopen(argv[1],"r")) == NULL) + { + fprintf(stderr,"can't read %s\n",argv[1]); + exit(2); + } + + *linebuff = '\0'; + + while(scanf("%u",&line)!=EOF) + { + if(line != lastline) + { + while(thisline < line && !feof(srcf)) + { + linestart+=strlen(linebuff); + fgets(linebuff,1023,srcf); + thisline++; + } + + if(thisline >= line) + { + char *chpos; + for(chpos = linebuff; *chpos != '=' && *chpos != '\n' && *chpos != '\0'; ++chpos) + putchar(*chpos); + + if(*chpos == '=') + putchar('='); + + printf("%c%d,%d\n",0177,line,linestart); + } + lastline = line; + } + } + + fclose(srcf); + exit(0); +} diff --git a/ghc/utils/hstags/hstags.prl b/ghc/utils/hstags/hstags.prl new file mode 100644 index 0000000000..073db474ea --- /dev/null +++ b/ghc/utils/hstags/hstags.prl @@ -0,0 +1,100 @@ +$tmp = (( $ENV{'TMPDIR'} ) # to make tmp file names + ? ($ENV{'TMPDIR'} . "/$$.eht") + : "$(TMPDIR)/$$.eht" ); + +#------------------------------------------------------------------------ +# If you are adjusting paths by hand for a binary GHC distribution, +# de-commenting the line to set GLASGOW_HASKELL_ROOT should do. +# Or you can leave it as is, and set the environment variable externally. +#------------------------------------------------------------------------ +# $ENV{'GLASGOW_HASKELL_ROOT'} = '/some/absolute/path/name'; + +if (! $ENV{'GLASGOW_HASKELL_ROOT'}) { # good -- death to environment variables + $TopPwd = '$(TOP_PWD)'; + $InstLibDirGhc = '$(INSTLIBDIR_GHC)'; + $InstDataDirGhc = '$(INSTDATADIR_GHC)'; +} else { + $TopPwd = $ENV{'GLASGOW_HASKELL_ROOT'}; + + if ( '$(INSTLIBDIR_GHC)' =~ /\/local\/fp(\/.*)/ ) { + $InstLibDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $1; + } else { + print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $(INSTLIBDIR_GHC).\n(Installation error)\n"; + exit(1); + } + + if ( '$(INSTDATADIR_GHC)' =~ /\/local\/fp(\/.*)/ ) { + $InstDataDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $1; + } else { + print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $(INSTDATADIR_GHC).\n(Installation error)\n"; + exit(1); + } +} + +$Unlit = ( $(INSTALLING) ) ? "$InstLibDirGhc/unlit" + : "$TopPwd/$(CURRENT_DIR)/$(GHC_UNLIT)"; +$HsCpp = # but this is re-set to "cat" (after options) if -cpp not seen + ( $(INSTALLING) ) ? "$InstLibDirGhc/hscpp" + : "$TopPwd/$(CURRENT_DIR)/$(GHC_HSCPP)"; +$HsP = ( $(INSTALLING) ) ? "$InstLibDirGhc/hsp" + : "$TopPwd/$(CURRENT_DIR)/$(GHC_HSP)"; +$HsTagsHelp + = ( $(INSTALLING) ) ? "$InstLibDirGhc/hstags-help" + : "$TopPwd/$(CURRENT_DIR)/$(HSTAGSSRC)/hstags-help"; + +$Verbose = 0; +$Append = '>'; +$DoCpp = 0; +$Cpp_opts = ''; +$HsP_opts = ''; +@Files = (); + +while ($ARGV[0] =~ /^-./) { + $_ = shift(@ARGV); + /^--/ && last; + /^-v/ && ($Verbose = 1, next); + /^-a$/ && ($Append = '>>', next); + /^-fglasgow-ext/ && ($HsP_opts .= ' -N', next); + /^-optP(.*)/ && ($Cpp_opts .= " $1", next); + /^-[UDI]/ && ($Cpp_opts .= " $_", next); + /^-cpp/ && ($DoCpp = 1, next); + /^-/ && next; # ignore the rest + push(@Files, $_); +} + +$ghc_version_info = $(PROJECTVERSION) * 100; +$DoHsCpp = ( ! $DoCpp ) ? 'cat' + : "$HsCpp -D__HASKELL1__=2 -D__GLASGOW_HASKELL__=$ghc_version_info $Cpp_opts"; + +# to find Prelude.hi +$HsP_opts .= ( ( $(INSTALLING) ) ? " -J$InstDataDirGhc/imports" + : " -J$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/prelude" ); + +open(STDOUT, "$Append TAGS") || die "can't create TAGS"; + +foreach $f ( @ARGV ) { + # if file is in a dir && we are CPPing, then we add its dir to the -I list. + if ( $DoCpp && $f =~ /(.+)\/[^\/]+$/ ) { + $Idir = "-I$1"; + } else { + $Idir = ''; + } + + if ( $f =~ /\.lhs$/ ) { + $ToDo = "$Unlit $f - | $DoHsCpp $Idir | $HsP -E $HsP_opts | $HsTagsHelp $f > $tmp"; + } else { + $ToDo = "$DoHsCpp $Idir < $f | $HsP -E $HsP_opts | $HsTagsHelp $f > $tmp"; + } + print STDERR "$ToDo\n" if $Verbose; + system($ToDo); + $return_val = $?; + die "Fatal error $return_val\n" if $return_val != 0; + + $stuff = `ls -l $tmp`; + @size = split(/[ \t]+/,$stuff); + + print STDOUT "\f\n$f,",$size[3],"\n"; + print STDOUT `cat $tmp`; +} + +unlink $tmp; diff --git a/ghc/utils/mkdependHS/Jmakefile b/ghc/utils/mkdependHS/Jmakefile new file mode 100644 index 0000000000..093861787b --- /dev/null +++ b/ghc/utils/mkdependHS/Jmakefile @@ -0,0 +1,16 @@ +PROGRAMS = mkdependHS + +all:: $(PROGRAMS) +MsubNeededHere($(PROGRAMS)) +UnlitNeededHere($(PROGRAMS)) + +MsubMakefileDependentProgramScriptTarget(PerlCmd,mkdependHS,mkdependHS.prl,/*no flags*/,/*Makefile*/) + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTBINDIR_GHC)) +InstallMsubbedScriptTarget(PerlCmd,mkdependHS,mkdependHS.prl,$(INSTBINDIR_GHC)) +#endif /* DoInstall... */ + +ExtraStuffToClean($(PROGRAMS)) +ClearTagsFile() +PerlTagsTarget( mkdependHS.prl ) diff --git a/ghc/utils/mkdependHS/mkdependHS.prl b/ghc/utils/mkdependHS/mkdependHS.prl new file mode 100644 index 0000000000..e915bca089 --- /dev/null +++ b/ghc/utils/mkdependHS/mkdependHS.prl @@ -0,0 +1,430 @@ +# *** MSUB does some substitutions here *** +# *** grep for $( *** +# +# tries to work like mkdependC +# +# ToDo: strip out all the .h junk +# +($Pgm = $0) =~ s/.*\/([^\/]+)$/\1/; +$Usage = "usage: $Pgm: not done yet\n"; + +$Status = 0; # just used for exit() status +$Verbose = ''; +$Dashdashes_seen = 0; + +$OrigCpp = '$(RAWCPP)'; +if ( $OrigCpp =~ /(\S+)\s+(.*)/ ) { + $cmd = $1; + $rest = $2; + if ( -x $cmd ) { # cool + $Cpp = $OrigCpp; + } else { # oops; try to guess + $GccV = `gcc -v 2>&1`; + if ( $GccV =~ /Reading specs from (.*)\/specs/ ) { + $Cpp = "$1/cpp $rest"; + } else { + die "hscpp: don't know how to run cpp: $OrigCpp\n"; + } + } +} else { + $Cpp = $OrigCpp; +} + +$Tmp_prefix = (( $ENV{'TMPDIR'} ) # to make tmp file names + ? ($ENV{'TMPDIR'} . "/mkdependHS$$") + : "$(TMPDIR)/mkdependHS$$" ); + +#------------------------------------------------------------------------ +# If you are adjusting paths by hand for a binary GHC distribution, +# de-commenting the line to set GLASGOW_HASKELL_ROOT should do. +# Or you can leave it as is, and set the environment variable externally. +#------------------------------------------------------------------------ +# $ENV{'GLASGOW_HASKELL_ROOT'} = '/some/absolute/path/name'; + +if (! $ENV{'GLASGOW_HASKELL_ROOT'}) { # good -- death to environment variables + $TopPwd = '$(TOP_PWD)'; + $InstLibDirGhc = '$(INSTLIBDIR_GHC)'; + $InstDataDirGhc = '$(INSTDATADIR_GHC)'; +} else { + $TopPwd = $ENV{'GLASGOW_HASKELL_ROOT'}; + + if ( '$(INSTLIBDIR_GHC)' =~ /\/local\/fp(\/.*)/ ) { + $InstLibDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $1; + } else { + print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $(INSTLIBDIR_GHC).\n(Installation error)\n"; + exit(1); + } + + if ( '$(INSTDATADIR_GHC)' =~ /\/local\/fp(\/.*)/ ) { + $InstDataDirGhc = $ENV{'GLASGOW_HASKELL_ROOT'} . $1; + } else { + print STDERR "GLASGOW_HASKELL_ROOT environment variable is set;\nBut can't untangle $(INSTDATADIR_GHC).\n(Installation error)\n"; + exit(1); + } +} + +$Unlit = ( $(INSTALLING) ) ? "$InstLibDirGhc/unlit" + : "$TopPwd/$(CURRENT_DIR)/$(GHC_UNLIT)"; + +$Begin_magic_str = "# DO NOT DELETE: Beginning of Haskell dependencies\n"; +$End_magic_str = "# DO NOT DELETE: End of Haskell dependencies\n"; +$Obj_suffix = '.o'; +$ghc_version_info = $(PROJECTVERSION) * 100; +@Defines = ('-D__HASKELL1__=2', "-D__GLASGOW_HASKELL__=$ghc_version_info"); + +$Import_dirs = '.'; +%Syslibs = (); +%StableLibs = (); +%PreludeIfaces = ( 'Prelude', '1', + 'PreludeGlaST', '1', + 'PreludeGlaMisc', '1', + 'Concurrent', '1', + 'Parallel', '1'); +%GhcLibIfaces = ( 'Bag', '1', + 'BitSet', '1', + # CharSeq not supposed to be used by user (I think. WDP) + 'FiniteMap', '1', + 'ListSetOps', '1', + 'Maybes', '1', + 'PackedString', '1', + 'Regex', '1', + 'MatchPS', '1', + 'Readline', '1', + 'Socket', '1', + 'SocketPrim', '1', + 'BSD', '1', + 'Pretty', '1', + 'Set', '1', + 'Util', '1' ); +%HbcLibIfaces = ( 'Algebra', '1', + 'Hash', '1', + 'ListUtil', '1', + 'Miranda', '1', + 'NameSupply', '1', + 'Native', '1', + 'Number', '1', + 'Parse', '1', + 'Pretty', '1', + 'Printf', '1', + 'QSort', '1', + 'Random', '1', + 'SimpleLex', '1', + 'Time', '1', + 'Trace', '1', + 'Word', '1' ); +%IO13Ifaces = ( 'LibSystem', '1', + 'LibCPUTime', '1', + 'LibDirectory', '1', + 'LibPosix', '1', + 'LibTime', '1' ); + +$Haskell_1_3 = 0; # assume Haskell 1.2, still. Changed by -fhaskell-1.3 +$Include_dirs = '-I.'; +$Col_width = 78; # ignored +$Makefile = ''; +@Src_files = (); + +&mangle_command_line_args(); + +if ( ! $Makefile && -f 'makefile' ) { + $Makefile = 'makefile'; +} elsif ( ! $Makefile && -f 'Makefile') { + $Makefile = 'Makefile'; +} else { + die "$Pgm: no makefile or Makefile found\n"; +} + +@Depend_lines = (); + +print STDERR "CPP defines=@Defines\n" if $Verbose; +print STDERR "Import_dirs=$Import_dirs\n" if $Verbose; +print STDERR "Include_dirs=$Include_dirs\n" if $Verbose; + +foreach $sf (@Src_files) { + # just like lit-inputter + # except it puts each file through CPP and + # a de-commenter (not implemented); + # builds up @Depend_lines + print STDERR "Here we go for source file: $sf\n" if $Verbose; + ($of = $sf) =~ s/\.l?hs$/$Obj_suffix/; + push(@Depend_lines, "$of : $sf\n"); + + # if it's a literate file, .lhs, then we de-literatize it: + if ( $sf !~ /\.lhs$/ ) { + $file_to_read = $sf; + } else { + $file_to_read = "$Tmp_prefix.hs"; + local($to_do) = "$Unlit $sf $file_to_read"; + &run_something($to_do, 'unlit'); + } + &slurp_file_for_imports($file_to_read, $sf); + + if ( $sf =~ /\.lhs$/ ) { + unlink "$Tmp_prefix.hs"; + } +} + +# OK, mangle the Makefile +unlink("$Makefile.bak"); +rename($Makefile,"$Makefile.bak"); +# now copy Makefile.bak into Makefile, rm'ing old dependencies +# and adding the new +open(OMKF,"< $Makefile.bak") || die "$Pgm: can't open $Makefile.bak: $!\n"; +open(NMKF,"> $Makefile") || die "$Pgm: can't open $Makefile: $!\n"; +select(NMKF); +$_ = <OMKF>; +while ($_ && $_ ne $Begin_magic_str) { # copy through, 'til Begin_magic_str + print $_; + $_ = <OMKF>; +} +while ($_ && $_ ne $End_magic_str) { # delete 'til End_magic_str + $_ = <OMKF>; +} +# insert dependencies +print $Begin_magic_str; +print @Depend_lines; +print $End_magic_str; +while (<OMKF>) { # copy the rest through + print $_; +} +close(NMKF) || exit(1); +close(OMKF) || exit(1); +chmod 0444, 'Makefile'; +exit 0; + +sub mangle_command_line_args { + while($_ = $ARGV[0]) { + shift(@ARGV); + + if ( /^--$/ ) { + $Dashdashes_seen++; + + } elsif ( /^-D(.*)/ ) { # recognized wherever they occur + push(@Defines, $_); + } elsif ( /^-i(.*)/ ) { + $Import_dirs .= ":$1"; + } elsif ( /^-I/ ) { + $Include_dirs .= " $_"; + } elsif ( /^-syslib$/ ) { + push(@Syslibs, &grab_arg_arg($_,'')); + } elsif ( /^-fhaskell-1\.3/ ) { + $Haskell_1_3 = 1; + } elsif ( /^-stable$/ ) { + # user-defined syslibs that she believes are stable. + push(@StableLibs, &grab_arg_arg($_,'')); + + } elsif ($Dashdashes_seen != 1) { # not between -- ... -- + if ( /^-v$/ ) { + $Verbose = '-v'; + } elsif ( /^-f(.*)/ ) { + $Makefile = &grab_arg_arg('-f',$1); + } elsif ( /^-o(.*)/ ) { + $Obj_suffix = &grab_arg_arg('-o',$1); + } elsif ( /^-bs(.*)/ ) { + $Begin_magic_str = &grab_arg_arg('-bs',$1) . "\n"; + } elsif ( /^-es(.*)/ ) { + $End_magic_str = &grab_arg_arg('-es',$1) . "\n"; + } elsif ( /^-w(.*)/ ) { + $Width = &grab_arg_arg('-w',$1); + } elsif ( /^-/ ) { + print STDERR "$Pgm: unknown option ignored: $_\n"; + } else { + push(@Src_files, $_); + } + + } elsif ($Dashdashes_seen == 1) { # where we ignore unknown options + push(@Src_files,$_) if ! /^-/; + } + } +} + +sub grab_arg_arg { + local($option, $rest_of_arg) = @_; + + if ($rest_of_arg) { + return($rest_of_arg); + } elsif ($#ARGV >= 0) { + local($temp) = $ARGV[0]; shift(@ARGV); + return($temp); + } else { + print STDERR "$Pgm: no argument following $option option\n"; + $Status++; + } +} + +sub slurp_file_for_imports { + local($file_to_read, $orig_src_file) = @_; + local($follow_file); + + local($last_seen_dir) = $orig_src_file; + $last_seen_dir =~ s/\/[^\/]+$//; # strip to dir name + $last_seen_dir = '.' if ($last_seen_dir eq $orig_src_file); + + # we mangle #include's so they will also leave something + # behind to indicate the dependency on _them_ + + print STDERR "sed -e '/^# *include/{p;s/^# *include/!include/;};s/'\\''//g;s/\"//g' $file_to_read | $Cpp $Include_dirs -I$last_seen_dir @Defines |\n" if $Verbose; + + open(SRCFILE, "sed -e '/^# *include/{p;s/^# *include/!include/;};s/'\\''//g;s/\"//g' $file_to_read | $Cpp $Include_dirs -I$last_seen_dir @Defines |") + || die "$Pgm: Can't open $file_to_read: $!\n"; + + while (<SRCFILE>) { + if (/^>?\s*import\s+([A-Z][A-Za-z0-9_']*)/ || /^!include\s+"(\S+)"/) { + $modname = $1; + if (/^>?\s*import/) { + $follow_file = &find_in_Import_dirs($orig_src_file, $modname, $last_seen_dir); + } else { + $follow_file = &find_in_Include_dirs($orig_src_file, $modname, $last_seen_dir); + } + + if ($follow_file) { # it found something + + if ($follow_file ne '__syslib__') { + local($int_file); + ($int_file = $follow_file) =~ s/\.l?hs$/\.hi/; + + push(@Depend_lines, "$of : $int_file\n"); + } + } else { + die "$orig_src_file: Couldn't handle: $_\n"; + } + } + } + close(SRCFILE) || exit(1); +} + +# when we see something, we cache that fact ('y'). +# also, when we get a miss, we cache that (so we don't try later); ('n') +%FileExists = (); + +sub find_in_Import_dirs { + local($orig_src_file, $modname, $last_seen_dir) = @_; + local($import_dir); + local($do_magical_check) = 0; + local($name_to_check); + + # hop along Import_dir list + foreach $import_dir (split(/:/,$Import_dirs)) { + # handle . magically + if ($import_dir eq '.') { + # record that we should do a SPECIAL try for a file in last_seen_dir (LAST) + $do_magical_check = 1; + } + + $name_to_check = "$import_dir/$modname.hi"; + if ( $FileExists{$name_to_check} ne 'n' ) { # either 'y' or nothing + print STDERR "trying $name_to_check...\n" if $Verbose; + return($name_to_check) if $FileExists{$name_to_check} eq 'y'; + if (-f $name_to_check) { + $FileExists{$name_to_check} = 'y'; + return($name_to_check) ; + } else { + $FileExists{$name_to_check} = 'n'; + } + } + + $name_to_check = "$import_dir/$modname.hs"; + print STDERR "trying... $name_to_check\n" if $Verbose; + return($name_to_check) if -f $name_to_check; + + $name_to_check = "$import_dir/$modname.lhs"; + print STDERR "trying... $name_to_check\n" if $Verbose; + return($name_to_check) if -f $name_to_check; + } + if ($do_magical_check == 1) { + $name_to_check = "$last_seen_dir/$modname.hi"; + + if ( $FileExists{$name_to_check} ne 'n' ) { # either 'y' or nothing + print STDERR "trying $name_to_check...\n" if $Verbose; + return($name_to_check) if $FileExists{$name_to_check} eq 'y'; + if (-f $name_to_check) { + $FileExists{$name_to_check} = 'y'; + return($name_to_check) ; + } else { + $FileExists{$name_to_check} = 'n'; + } + } + + $name_to_check = "$last_seen_dir/$modname.lhs"; + print STDERR "trying... $name_to_check\n" if $Verbose; + return($name_to_check) if -f $name_to_check; + + $name_to_check = "$last_seen_dir/$modname.hs"; + print STDERR "trying... $name_to_check\n" if $Verbose; + return($name_to_check) if -f $name_to_check; + } + # OK, maybe it's referring to something in a system library + foreach $lib ( @Syslibs ) { + if ( $lib eq 'ghc' ) { + return('__syslib__') if $GhcLibIfaces{$modname}; + } elsif ( $lib eq 'hbc' ) { + return('__syslib__') if $HbcLibIfaces{$modname}; + } else { + die "Unrecognised syslib: $lib\n"; + } + } + + # HACK HACK: Let the user define his own "stable" modules. + foreach $stableLib ( @StableLibs ) { + return('__syslib__') if ( $stableLib eq $modname ); + } + + # Might be a Haskell 1.3 Module (but only if we've said -fhaskell-1.3) + if ( $Haskell_1_3 == 1 ) { + return('__syslib__') if $IO13Ifaces{$modname}; + } + + # Last hope: referring to a Prelude interface + return('__syslib__') if $PreludeIfaces{$modname}; + + die "No file `$modname.hi', `$modname.lhs' or `$modname.hs' (reqd from file `$orig_src_file')\namong import directories:\n\t$Import_dirs\n"; +} + +sub find_in_Include_dirs { + local($orig_src_file, $name, $last_seen_dir) = @_; + local($include_dir); + local($do_magical_check) = 0; + + # no funny name guessing here + + # hop along Include_dir list + foreach $include_dir (split(/\s+/,$Include_dirs)) { + $include_dir =~ s/^-I//; + + # handle . magically + if ($include_dir eq '.') { + # record that we should do a SPECIAL try for a file in last_seen_dir (LAST) + $do_magical_check = 1; + } + print STDERR "trying $include_dir/$name...\n" if $Verbose; + if (-f "$include_dir/$name") { + return("$include_dir/$name"); + } + } + if ($do_magical_check == 1) { + print STDERR "trying $last_seen_dir/$name...\n" if $Verbose; + if (-f "$last_seen_dir/$name") { + return("$last_seen_dir/$name"); + } + } + die "No file `$name' (reqd from file `$orig_src_file') among include directories: $Include_dirs\n"; +} + +# out of the driver, actually +sub run_something { + local($str_to_do, $tidy_name) = @_; + + print STDERR "\n$tidy_name:\n\t" if $Verbose; + print STDERR "$str_to_do\n" if $Verbose; + + local($return_val) = system($str_to_do) >> 8; + + if ($return_val != 0) { + local($die_msg) = "$Pgm: execution of the $tidy_name had trouble"; + $die_msg .= " (program not found)" if $return_val == 255; + $die_msg .= " ($!)" if $Verbose && $! != 0; + $die_msg .= "\n"; + print STDERR $die_msg; + exit $return_val; + } +} diff --git a/ghc/utils/parallel/Jmakefile b/ghc/utils/parallel/Jmakefile new file mode 100644 index 0000000000..371785c667 --- /dev/null +++ b/ghc/utils/parallel/Jmakefile @@ -0,0 +1,37 @@ +PROGRAMS = grs2gr \ + gr2ps \ + gr2qp \ + qp2ps \ + ghc-fool-sort ghc-unfool-sort + +all:: $(PROGRAMS) +/* stuff to have before we get going */ +MsubNeededHere($(PROGRAMS)) + +/* === BUILD STUFF (installation, etc., below) ========== */ + +MsubProgramScriptTarget(PerlCmd,grs2gr,grs2gr.pl,,) +MsubProgramScriptTarget(/usr/local/bin/bash,gr2ps,gr2ps.bash,,) +MsubProgramScriptTarget(PerlCmd,gr2qp,gr2qp.pl,,) +MsubProgramScriptTarget(PerlCmd,qp2ps,qp2ps.pl,,) +MsubProgramScriptTarget(PerlCmd,ghc-fool-sort,ghc-fool-sort.pl,,) +MsubProgramScriptTarget(PerlCmd,ghc-unfool-sort,ghc-unfool-sort.pl,,) + +/* === INSTALLATION ======== */ + +/* the rest of these vary from std/useful to hackish dans le extreme */ + +MakeDirectories(install, $(INSTSCRIPTDIR)) +InstallScriptTarget(grs2gr, $(INSTSCRIPTDIR)) +InstallScriptTarget(gr2ps, $(INSTSCRIPTDIR)) +InstallScriptTarget(gr2qp, $(INSTSCRIPTDIR)) +InstallScriptTarget(qp2ps, $(INSTSCRIPTDIR)) +InstallScriptTarget(ghc-fool-sort, $(INSTSCRIPTDIR)) +InstallScriptTarget(ghc-unfool-sort,$(INSTSCRIPTDIR)) + +/* === OTHER STUFF ========= */ + +ExtraStuffToClean($(PROGRAMS)) + +ClearTagsFile() +PerlTagsTarget( *.pl ) diff --git a/ghc/utils/parallel/ghc-fool-sort.pl b/ghc/utils/parallel/ghc-fool-sort.pl new file mode 100644 index 0000000000..dfa65a1875 --- /dev/null +++ b/ghc/utils/parallel/ghc-fool-sort.pl @@ -0,0 +1,23 @@ +############################################################################## +# +# Usage: fool-sort +# +# Takes a pure (i.e. no header lines) quasi-parallel profile (a .qp file) from +# stdin and inserts a counter as second field to force sort not to change the +# ordering of lines with the same time stamp. The result is written to stdout. +# +############################################################################## + +$last_time = 0; +while (<STDIN>) { + ($time, @rest) = split; + if ( $time == $last_time ) { + $x = ++$count; + } else { + $x = $count = 0; + } + print $time, " ", $x, " ", join(' ',@rest), "\n"; + $last_time = $time; +} + +exit 0; diff --git a/ghc/utils/parallel/ghc-unfool-sort.pl b/ghc/utils/parallel/ghc-unfool-sort.pl new file mode 100644 index 0000000000..90da222a5a --- /dev/null +++ b/ghc/utils/parallel/ghc-unfool-sort.pl @@ -0,0 +1,16 @@ +############################################################################## +# +# Usage: unfool-sort +# +# Reads stdin, elimininates the second field (a dummy counter that has been +# inserted by fool-sort) of each line and writes the result to stdout. +# See documentation of fool-sort. +# +############################################################################## + +while (<STDIN>) { + ($time, $dummy, @rest) = split; + print join(' ',$time,@rest) . "\n"; +} + +exit 0; diff --git a/ghc/utils/parallel/gr2ps.bash b/ghc/utils/parallel/gr2ps.bash new file mode 100644 index 0000000000..28099fbff0 --- /dev/null +++ b/ghc/utils/parallel/gr2ps.bash @@ -0,0 +1,136 @@ +#!/usr/local/bin/bash +############################################################################## +# +# Usage: gr2ps [options] <gr-file> +# +# Transform the log file of a GrAnSim run (a .gr file) into a quasi-parallel +# profile (a .qp file) and then into a PostScript file, showing essentially +# the total number of running, runnable and blocked tasks. +# +# Options: +# -o <file> ... write PS file to <file> +# -i <int> ... info level from 1 to 7; number of queues to display +# -m ... create mono PostScript file instead a color one. +# -O ... optimize the produced .ps w.r.t. size +# NB: With this option info is lost. If there are several values +# with same x value only the first one is printed, all +# others are dropped. +# -s <str> ... print <str> in the top right corner of the generated graph +# -v ... be talkative. +# -h ... print help message (this header). +# +############################################################################## + +############################################################################## +# Internal comments: +# ---------------------------------------------------------------------- +# This version works on both Suns and Alphas -- KH +# Any volunteers to convert it to /bin/sh? +# Next time somebody calls for volunteers I'd better keep my mouth shut ... HWL +############################################################################## + +progname="`basename $0`" +args="$*" + +verb=0 +help=0 +mono="" +psfile="" +debug="" +optimize="" +info_level=0 +info_mask="" +string="" + +getopts "hvmDOSs:o:i:I:" name +while [ "$name" != "?" ] ; do + case $name in + h) help=1;; + v) verb=1;; + m) mono="-m";; + D) debug="-D";; + O) optimize="-O";; + S) lines="-S";; + s) string=$OPTARG;; + i) info_level=$OPTARG;; + I) info_mask=$OPTARG;; + o) psfile=$OPTARG;; + esac + getopts "hvmDOSs:o:i:I:" name +done + +shift $[ $OPTIND - 1 ] + +if [ -z "$1" ] + then echo "usage: $progname [-m] file[.gr]" + exit 1; +fi + +f="`basename $1 .gr`" +grfile="$f".gr +qpfile="$f".qp +ppfile="$f".pp + +if [ -z "$psfile" ] + then psfile="$f".ps +fi + +if [ $help -eq 1 ] + then no_of_lines=`cat $0 | awk 'BEGIN { n = 0; } \ + /^$/ { print n; \ + exit; } \ + { n++; }'` + echo "`head -$no_of_lines $0`" + exit +fi + +if [ $verb -eq 1 ] + then echo "Input file: $grfile" + echo "Quasi-parallel file: $qpfile" + echo "PP file: $ppfile" + echo "PostScript file: $psfile" + if [ "$mono" = "-m" ] + then echo "Producing monochrome PS file" + else echo "Producing color PS file" + fi + if [ "$optimize" = "-O" ] + then echo "Optimization is ON" + else echo "Optimization is OFF" + fi + if [ "$debug" = "-D" ] + then echo "Debugging is turned ON" + else echo "Debugging is turned OFF" + fi +fi + + +# unset noclobber +if [ ! -f "$grfile" ] + then + echo "$grfile does not exist" + exit 1 + else + rm -f "$qpfile" "$psfile" + prog=`head -1 "$grfile" | sed -e 's/Granularity Simulation for //'` + echo "$prog" >| "$qpfile" + if [ $verb -eq 1 ]; then echo "Executed program: $prog"; fi + date >> "$qpfile" + date="`date`" + cat "$grfile" | gr2qp | ghc-fool-sort | sort -n +0 -1 | ghc-unfool-sort >> "$qpfile" + # max=`tail -2 "$qpfile" | awk '!/^Number of threads:/ { print $1; }'` + max=`tail -1 "$qpfile" | awk '{ print $1; }'` + if [ $verb -eq 1 ]; then echo "Total runtime: $max"; fi + opts=""; + if [ $info_level -gt 0 ] + then opts="-i $info_level"; + fi + if [ -n "$info_mask" ] + then opts="-I $info_mask"; + fi + tail +3 "$qpfile" | qp2ps $debug $optimize $mono $lines "-s" "$string" $opts "$max" "$prog" "$date" >| "$psfile" + rm -f "$qpfile" +fi + + + + diff --git a/ghc/utils/parallel/gr2qp.pl b/ghc/utils/parallel/gr2qp.pl new file mode 100644 index 0000000000..c0844622d8 --- /dev/null +++ b/ghc/utils/parallel/gr2qp.pl @@ -0,0 +1,45 @@ +while(<>) { + chop; + ($PE, $pe, $time, $act, $tid, $rest) = split; + next if $act eq 'REPLY'; + chop($tid) if $act eq 'END'; + $from = $queue{$tid}; + $extra = ""; + if ($act eq 'START') { + $from = '*'; + $to = 'G'; + } elsif ($act eq 'START(Q)') { + $from = '*'; + $to = 'A'; + } elsif ($act eq 'STEALING') { + $to = 'C'; + } elsif ($act eq 'STOLEN') { + $to = 'G'; + } elsif ($act eq 'STOLEN(Q)') { + $to = 'A'; + } elsif ($act eq 'FETCH') { + $to = 'Y'; + } elsif ($act eq 'BLOCK') { + $to = 'R'; + } elsif ($act eq 'RESUME') { + $to = 'G'; + $extra = " 0 0x0"; + } elsif ($act eq 'RESUME(Q)') { + $to = 'A'; + $extra = " 0 0x0"; + } elsif ($act eq 'END') { + $to = '*'; + } elsif ($act eq 'SCHEDULE') { + $to = 'G'; + } elsif ($act eq 'DESCHEDULE') { + $to = 'A'; + } + $queue{$tid} = $to; + + if ($to ne $from) { + print substr($time,1,length($time)-3), " ", + $from, $to, " 0 0x", $tid, $extra, "\n"; + } + delete $queue{$tid} if $to eq '*'; + +} diff --git a/ghc/utils/parallel/grs2gr.pl b/ghc/utils/parallel/grs2gr.pl new file mode 100644 index 0000000000..d30c7777ce --- /dev/null +++ b/ghc/utils/parallel/grs2gr.pl @@ -0,0 +1,43 @@ +# +# Convert several .gr files (from the same GUM run) into a single +# .gr file with all times adjusted relative to the earliest start +# time. +# + +$count = 0; + +foreach $i (@ARGV) { + open(GR, $i) || die "Can't read $i\n"; + $cmd = <GR>; + $start = <GR>; + ($pe, $timestamp) = ($start =~ /PE\s+(\d+) \[(\d+)\]/); + die "PE $pe too high\n" if $pe > $#ARGV; + $proc[$count++] = $pe; + $prog[$pe] = $cmd; + $time[$pe] = $timestamp; + close(GR) || die "Can't close $i\n"; +} + +$basetime = 0; + +for($i = 0; $i < $count; $i++) { + $pe = $proc[$i]; + die "PE $pe missing?\n" if !defined($time[$pe]); + die "Mismatched .gr files\n" if $pe > 0 && $prog[$pe] ne $prog[$pe - 1]; + $basetime = $time[$pe] if $basetime == 0 || $basetime > $time[$pe]; +} + +print $cmd; + +for($i = 0; $i < $count; $i++) { + $pe = $proc[$i]; + $delta = $time[$pe] - $basetime; + open(GR, $ARGV[$i]) || die "Can't read $ARGV[i]\n"; + $cmd = <GR>; + $start = <GR>; + while(<GR>) { + /PE\s+(\d+) \[(\d+)\]/; + printf "PE %2u [%lu]%s", $1, $2 + $delta, $'; + } + close(GR) || die "Can't close $ARGV[$i]\n"; +} diff --git a/ghc/utils/parallel/qp2ps.pl b/ghc/utils/parallel/qp2ps.pl new file mode 100644 index 0000000000..d671cb8937 --- /dev/null +++ b/ghc/utils/parallel/qp2ps.pl @@ -0,0 +1,813 @@ +#! /usr/local/bin/perl +############################################################################## +# +# Usage: qp2ps.pl [options] <max-x> <prg> <date> +# +# Filter that transforms a quasi-parallel profile (a .qp file) at stdin to +# a PostScript file at stdout, showing essentially the total number of running, +# runnable and blocked tasks. +# +# Options: +# -o <file> ... write PS file to <file> +# -m ... create mono PostScript file instead a color one. +# -O ... compress i.e. try to minimize the size of the .ps file +# -s <str> ... print <str> in the top right corner of the generated graph +# -i <int> ... info level from 1 to 7; number of queues to display +# -v ... be talkative. +# -h ... print help message (this header). +# +############################################################################## + +require "getopts.pl"; + +&Getopts('hvDOmSs:i:I:'); + +do process_options(); + +if ( $opt_v ) { + do print_verbose_message(); +} + +# --------------------------------------------------------------------------- +# Init +# --------------------------------------------------------------------------- + +$xmin = 100; +$xmax = 790; + +$scalex = $xmin; +$labelx = $scalex - 45; +$markx = $scalex - 30; +$major = $scalex - 5; +$majorticks = 10; + +$pmax = 1; +$amax = 0; +$ymin = 50; +$ymax = 500; + +$active = 0; +$runnable = 0; +$blocked = 0; +$sparks = 0; +$fetching = 0; + +$lines_per_flush = 100; # depends on the PS implementation you use + +%color = ( "a", "green", + "r", "amber", + "b", "red", + "f", "cyan", + "m", "blue", + "s", "crimson" ); + +# --------------------------------------------------------------------------- + +do print_prolog(); + +$otime = -1; +$last_x = -1; +$last_y = -1; +$in_seq = 0; +$time_of_second_event = 0; + +while(<STDIN>) { + chop; + ($time, $event, $tid, $addr, $tid2, $addr2) = split; + $time_of_second_event = $time if $time_of_second_event == 0; + + if($time != $otime) { + $tottime += $G[$samples] * ($time-$T[$samples]); + + if($active > $amax) { + $amax = $active; + } + + if ( $opt_D ) { + if($G[$samples] < $amax && $A[$samples] > 0) { + printf(stderr "%% $otime: G $G[$samples], A $A[$samples], " . + "R $R[$samples], B $B[$samples], " . + "Y $Y[$samples]\n"); + } + } + + # Reality Check + if($G[$samples] < 0 || $A[$samples] < 0 || + $R[$samples] < 0 || $B[$samples] < 0 || + $Y[$samples] < 0) { + printf(stderr "Error: Impossible number of tasks at time " . + "$T[$samples] (G $G[$samples], A $A[$samples], ". + "R $R[$samples], B $B[$samples], Y $Y[$samples])\n"); + } + $samples++; + $otime = $time; + } + + $eventfrom = substr($event,0,1); + $eventto = substr($event,1,1); + + printf(stderr "$time $event $eventfrom $eventto\n") if $opt_D; + + if ($eventfrom eq '*') { + } + + elsif ($eventfrom eq 'G') { + --$active; + } + + elsif ($eventfrom eq 'A') { + --$runnable; + } + + elsif ($eventfrom eq 'R') { + --$blocked; + } + + elsif ($eventfrom eq 'B') { + --$sparks; + } + + elsif ($eventfrom eq 'C') { + --$migrating; + } + + elsif ($eventfrom eq 'Y') { + --$fetching; + } + + if ($eventto eq '*') { + } + + elsif ($eventto eq 'G') { + ++$active; + } + + elsif ($eventto eq 'A') { + ++$runnable; + $somerunnable = 1; + } + + elsif ($eventto eq 'R') { + ++$blocked; + $someblocked = 1; + } + + elsif ($eventto eq 'B') { + ++$sparks; + $somesparks = 1; + } + + elsif ($eventto eq 'C') { + ++$migrating; + $somemigratory = 1; + } + + elsif ($eventto eq 'Y') { + ++$fetching; + $somefetching = 1; + } + + printf(stderr "%% $time: G $active, A $runnable, R $blocked, " . + "B $sparks, C $migrating\n") if 0; + + $T[$samples] = $time; + $G[$samples] = &queue_on("a") ? $active : 0; + $A[$samples] = &queue_on("r") ? $runnable : 0; + $R[$samples] = &queue_on("b") ? $blocked : 0; + $Y[$samples] = &queue_on("f") ? $fetching : 0; + $B[$samples] = &queue_on("s") ? $sparks : 0; + $C[$samples] = &queue_on("m") ? $migrating : 0; + + $all = $G[$samples] + $A[$samples] + $R[$samples] + $Y[$samples] + + $B[$samples] + $C[$samples] ; + + if($all > $pmax) { + $pmax = $all; + } +} + +if($time != $tmax) { + die "Error: Calculated time ($time) does not agree with stated max. time ($tmax)\n"; +} + +# Print optional str + if ( $opt_s ) { + print("HB16 setfont ($opt_s) dup stringwidth pop 790 exch sub 500 moveto show\n"); + } + +# Average Parallelism +if($time > 0) { + if ( 0 ) { # HACK warning; is this *always* correct -- HWL + $avg = ($tottime-$time_of_second_event)/($time-$time_of_second_event); + } else { + $avg = $tottime/$time; + } + $avgs=sprintf("Average Parallelism = %0.1f\n",$avg); + print("HE14 setfont ($avgs) dup stringwidth pop 790 exch sub 525 moveto show\n"); + $rt_str=sprintf("Runtime = %0.0f\n",$tmax); + print("HE14 setfont ($rt_str) dup stringwidth pop 790 exch sub 30 moveto show\n"); +} + +# ----------------------------------------------------------------------------- +# Draw axes lines etc +# ----------------------------------------------------------------------------- + +do print_y_axis(); + +# if ( ! $opt_S ) { + +# Draw dashed line for orientation (startup time) -- HWL + +if ( $draw_lines ) { + local($x, $y); + $x = int((500000/$tmax) * ($xmax-$xmin) + $xmin); + $y = int((0/$pmax) * ($ymax-$ymin) + $ymin); + $h = ($ymax-$ymin); + + print "gsave\n" . + "[1 3] 1 setdash\n" . + "$x $y moveto 0 $h rlineto stroke\n" . + "grestore\n"; +} + +# and another one at the second event -- HWL + +print STDERR "Time of second event is: $time_of_second_event" if $opt_D; + +if ( $draw_lines ) { + local($x, $y); + $x = int(($time_of_second_event/$tmax) * ($xmax-$xmin) + $xmin); + $y = int((0/$pmax) * ($ymax-$ymin) + $ymin); + $h = ($ymax-$ymin); + + print "gsave\n"; + if ( ! $opt_m ) { + print "green setrgbcolor\n"; + } + print "[3 5] 1 setdash\n" . + "$x $y moveto 0 $h rlineto stroke\n" . + "grestore\n"; +} + +# } + +# ----------------------------------------------------------------------------- +# Draw the different kinds of tasks +# ----------------------------------------------------------------------------- + +$rshow = reverse($show); +print STDERR "\nReversed info-mask is : $rshow" if $opt_D; +print STDERR "\nMaximal y value is $pmax" if $opt_D; +for ($j=0; $j<length($rshow); $j++) { + $x = substr($rshow,$j,1); + print STDERR "Queue = $x i.e. " . ($color{$x}) . "\n" if $opt_D; + print("$xmin $ymin moveto\n"); + for($i=1; $i <= $samples; $i++) { + do psout($T[$i],&count($x,$i)); + if ($i % $lines_per_flush == 0) { + print($color{$x} . " flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + + if ( $opt_m ) { + print "closepath " . ($color{$x}) . " setgray fill\n"; + } else { + print "closepath " . ($color{$x}) . " setrgbcolor fill\n"; + } +} + +# ----------------------------------------------------------------------------- + + +# Logo +print("HE14 setfont\n"); +if ( $opt_m ) { + print("50 530 asciilogo\n"); +} else { + print("50 530 logo\n"); +} + +# Epilogue +print("showpage\n"); + +exit 0; + +# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +# ----------------------------------------------------------------------------- +# Scale the (x,y) point (x is time in cycles, y is no. of tasks) s.t. the +# x-(time-) axis fits between $xmin and $xmax (range for .ps graph). +# In case of optimization ($opt_O): +# If there is a sequence of (x,y) pairs with same x value, then just +# print the first and the last pair in the seqence. To do that, $last_x +# always contains the scaled x-val of the last point. $last_y contains +# the y-val of the last point in the current sequence (it is 0 outside a +# sequence!). +# ----------------------------------------------------------------------------- + +sub psout { + local($x, $y ) = @_; + if ( $opt_S ) { + $x = int(( ($x-$time_of_second_event)/($tmax-$time_of_second_event)) * ($xmax-$xmin) + $xmin); + } else { + $x = int(($x/$tmax) * ($xmax-$xmin) + $xmin); + } + $y = int(($y/$pmax) * ($ymax-$ymin) + $ymin); + + die "Error in psout: Neg x coordinate\n" if ($x < 0) ; + + if ( $opt_O ) { + if ( $last_x == $x ) { # If seq before $x that then print last pt + if ( ! $in_seq ) { + $in_seq = 1; + $first_y = $last_y; + } + } else { # If seq with same $x val then ignore pts + if ( $in_seq ) { # Seq before that -> print last in seq + print("$last_x $last_y L\n") if ($first_y != $last_y); + $in_seq = 0; + } + print("$x $y L\n"); + } + $last_x = $x; + $last_y = $y; + } else { + print("$x $y L\n"); + } +} + +# ----------------------------------------------------------------------------- + +sub queue_on { + local ($queue) = @_; + + return index($show,$queue)+1; +} + +# ----------------------------------------------------------------------------- + +sub count{ + local ($queue,$index) = @_; + local ($res); + + $where = &queue_on($queue); + $res = ((&queue_on("a") && (&queue_on("a")<=$where)) ? $G[$index] : 0) + + ((&queue_on("r") && (&queue_on("r")<=$where)) ? $A[$index] : 0) + + ((&queue_on("b") && (&queue_on("b")<=$where)) ? $R[$index] : 0) + + ((&queue_on("f") && (&queue_on("f")<=$where)) ? $Y[$index] : 0) + + ((&queue_on("m") && (&queue_on("m")<=$where)) ? $B[$index] : 0) + + ((&queue_on("s") && (&queue_on("s")<=$where)) ? $C[$index] : 0); + + return $res; +} + +# ----------------------------------------------------------------------------- + +sub get_date { + local ($date); + + open (DATE,"date |") || die ("$!"); + while (<DATE>) { + $date = $_; + } + close (DATE); + + return ($date); +} + +# ----------------------------------------------------------------------------- + +sub print_prolog { + local ($date); + + $date = do get_date(); + + print("%!PS-Adobe-2.0\n"); + print("%%BoundingBox: 0 0 560 800\n"); + print("%%Title: Activity Profile\n"); + print("%%Creator: qp2ps.pl\n"); + print("%%CreationDate: $date\n"); + print("%%EndComments\n"); + #print ("/greenlineto {1.0 setlinewidth lineto} def\n"); + #print ("/amberlineto {0.5 setlinewidth lineto} def\n"); + #print ("/redlineto {1.5 setlinewidth lineto} def\n"); + #print ("/G {newpath moveto greenlineto stroke} def\n"); + #print ("/A {newpath moveto amberlineto stroke} def\n"); + #print ("/R {newpath moveto redlineto stroke} def\n"); + + if ( $opt_m ) { + print "/red { 0.5 } def\n"; + print "/green { 0 } def\n"; + print "/blue { 0.7 } def\n"; + print "/crimson { 0.8 } def\n"; + print "/amber { 0.9 } def\n"; + print "/cyan { 0.3 } def\n"; + } else { + print "/red { 0.8 0 0 } def\n"; + print "/green { 0 0.9 0.1 } def\n"; + print "/blue { 0 0.1 0.9 } def\n"; + print "/crimson { 0.7 0.5 0 } def\n"; + print "/amber { 0.9 0.7 0.2 } def\n"; + print "/cyan { 0 0.6 0.9 } def\n"; + } + + print "/printText { 0 0 moveto (GrAnSim) show } def\n"; + + if ( $opt_m ) { + print "/logo { gsave \n" . + " translate \n" . + " .95 -.05 0\n" . + " { setgray printText 1 -.5 translate } for \n" . + " 1 setgray printText\n" . + " grestore } def\n"; + } else { + print "/logo { gsave \n" . + " translate \n" . + " .95 -.05 0\n" . + " { dup 1 exch sub 0 exch setrgbcolor printText 1 -.5 translate } for \n" . + " 1 0 0 setrgbcolor printText\n" . + " grestore} def\n"; + } + + print "/asciilogo { 5 sub moveto HB16 setfont (GrAnSim) show } def\n"; + print "/cmpx {pop exch pop eq} def % compare x-coors of 2 points\n"; + print "/cmpy {exch pop 3 2 roll pop eq} def % compare y-coors of 2 points\n"; + print "/cmp {2 index eq {exch pop eq} % compare 2 points\n"; + print " {pop pop pop false} ifelse } def\n"; + print "%/L { lineto } def\n"; + print "%/L {2 copy pop 1 sub currentpoint exch pop lineto lineto} def\n"; + print "/L {2 copy currentpoint cmpx not\n"; + print " {2 copy pop currentpoint exch pop lineto} if\n"; + print " 2 copy currentpoint cmpy \n"; + print " {pop pop} \n"; + print " {lineto} ifelse\n"; + print "} def\n"; + print "/flush-it { % draw a segment of the overall area; Arg: color\n"; + print " currentpoint \n"; + print " 1 index 50 lineto closepath\n"; + if ( $opt_m ) { + print " 3 2 roll setgray fill \n"; + } else { + print " 5 2 roll setrgbcolor fill \n"; + } + print " 1 index 50 moveto lineto \n"; + print "} def\n"; + print "% For debugging PS uncomment this line and add the file behandler.ps\n"; + print "% $brkpage begin printonly endprint \n"; + print("/HE10 /Helvetica findfont 10 scalefont def\n"); + print("/HE12 /Helvetica findfont 12 scalefont def\n"); + print("/HE14 /Helvetica findfont 14 scalefont def\n"); + print("/HB16 /Helvetica-Bold findfont 16 scalefont def\n"); + print "% " . "-" x 77 . "\n"; + + print("-90 rotate\n"); + print("-785 30 translate\n"); + print("newpath\n"); + print("0 8 moveto\n"); + print("0 525 760 525 8 arcto\n"); + print("4 {pop} repeat\n"); + print("760 525 760 0 8 arcto\n"); + print("4 {pop} repeat\n"); + print("760 0 0 0 8 arcto\n"); + print("4 {pop} repeat\n"); + print("0 0 0 525 8 arcto\n"); + print("4 {pop} repeat\n"); + print("0.500000 setlinewidth\n"); + print("stroke\n"); + print("newpath\n"); + print("4 505 moveto\n"); + print("4 521 752 521 4 arcto\n"); + print("4 {pop} repeat\n"); + print("752 521 752 501 4 arcto\n"); + print("4 {pop} repeat\n"); + print("752 501 4 501 4 arcto\n"); + print("4 {pop} repeat\n"); + print("4 501 4 521 4 arcto\n"); + print("4 {pop} repeat\n"); + print("0.500000 setlinewidth\n"); + print("stroke\n"); + + print("HE14 setfont\n"); + print("100 505 moveto\n"); + print("($pname ) show\n"); + + # print("($date) dup stringwidth pop 750 exch sub 505 moveto show\n"); + + print("4 8 moveto\n"); + print("4 24 756 24 4 arcto\n"); + print("4 {pop} repeat\n"); + print("756 24 756 4 4 arcto\n"); + print("4 {pop} repeat\n"); + print("756 4 4 4 4 arcto\n"); + print("4 {pop} repeat\n"); + print("4 4 4 24 4 arcto\n"); + print("4 {pop} repeat\n"); + print("0.500000 setlinewidth\n"); + print("stroke\n"); + +# Labels + +# x-range: 100 - 600 +# y-value: + + $x_begin = 100; + $x_end = 600; + $y_label = 10; + + $no_of_labels = length($show); # $info_level; + + $step = ($x_end-$x_begin)/($no_of_labels); + + $x_now = $x_begin; + + if ( &queue_on("a") ) { + do print_box_and_label($x_now,$y_label,"green","running"); + } + + if ( &queue_on("r") ) { + $x_now += $step; + do print_box_and_label($x_now,$y_label,"amber","runnable"); + } + + if ( &queue_on("f") ) { + $x_now += $step; + do print_box_and_label($x_now,$y_label,"cyan","fetching"); + } + + if ( &queue_on("b") ) { + $x_now += $step; + do print_box_and_label($x_now,$y_label,"red","blocked"); + } + + if ( &queue_on("m") ) { + $x_now += $step; + do print_box_and_label($x_now,$y_label,"blue","migrating"); + } + + if ( &queue_on("s") ) { + $x_now += $step; + do print_box_and_label($x_now,$y_label,"crimson","sparked"); + } + + # Print runtime of prg; this is jus a crude HACK; better: x-axis! -- HWL + #print("HE10 setfont\n"); + #print("680 10 moveto\n"); + #print("(RT: $tmax) show\n"); + + print("-40 -20 translate\n"); +} + +# ----------------------------------------------------------------------------- + +sub print_box_and_label { + local ($x,$y,$color,$label) = @_; + local ($z) = (15); + + print("$x 10 moveto\n"); + print("0 10 rlineto\n"); + print("10 0 rlineto\n"); + print("0 -10 rlineto\n"); + print("closepath\n"); + print("gsave\n"); + if ( $opt_m ) { + print("$color setgray\n"); + } else { + print("$color setrgbcolor\n"); + } + print("fill\n"); + print("grestore\n"); + print("stroke\n"); + print("HE14 setfont\n"); + print(($x+$z) . " 10 moveto\n"); + print("($label) show\n"); + +} + +# ----------------------------------------------------------------------------- + +sub print_y_axis { + local ($i); + +# Y-axis label + + print("gsave\n"); + print("HE12 setfont\n"); + print("(tasks)\n"); + print("dup stringwidth pop\n"); + print("$ymax\n"); + print("exch sub\n"); + print("$labelx exch\n"); + print("translate\n"); + print("90 rotate\n"); + print("0 0 moveto\n"); + print("show\n"); + print("grestore\n"); + +# Scale + + if ( $opt_m ) { + print "0 setgray\n"; + } else { + print "0 0 0 setrgbcolor\n"; + } + + print("HE12 setfont\n$scalex $ymin moveto\n$scalex $ymax lineto\n"); + + if ($pmax < $majorticks) { + $majorticks = $pmax; + } + + $majormax = int($pmax/$majorticks)*$majorticks; + $smax = $majormax*(($ymax-$ymin)/$pmax)+$ymin; + $majorint = $majormax/$majorticks; + + for($i=0; $i <= $majorticks; ++$i) { + $y = (($smax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin; + $majorval = int($majorint * ($majormax/$majorint-$i)); + print("$scalex $y moveto\n$major $y lineto\n"); + print("$markx $y moveto\n($majorval) show\n"); + } + + # print("$xmin $ymax moveto\n10 0 rlineto\n10 0 rmoveto\n($pmax) show\n"); + print " stroke\n"; +} + +# ----------------------------------------------------------------------------- + +sub print_verbose_message { + + print "Prg Name: $pname Date: $date Info-str: $show\n"; + print "Input: stdin Output: stdout\n"; +} + +# ---------------------------------------------------------------------------- + +sub process_options { + + if ( $opt_h ) { + open(ME,$0) || die "Can't open myself ($0): $!\n"; + $n = 0; + while (<ME>) { + last if $_ =~ /^$/; + print $_; + $n++; + } + close(ME); + exit ; + } + + if ( $#ARGV != 2 ) { + print "Usage: $0 [options] <max y value> <prg name> <date> \n"; + print "Use -h option to get details\n"; + exit 1; + } + + $tmax = $ARGV[0]; + $pname = $ARGV[1]; + $date = $ARGV[2]; + + $show = "armfb"; + + if ( $opt_S ) { + $draw_lines = 1; + } else { + $draw_lines = 0; + } + + if ( $opt_i ) { + $show = "a" if info_level == 1; + $show = "ar" if info_level == 2; + $show = "arb" if info_level == 3; + $show = "arfb" if info_level == 4; + $show = "armfb" if info_level == 5; + $show = "armfbs" if info_level == 6; + } + + if ( $opt_I ) { + $show = $opt_I; + } + + if ( $opt_v ){ + $verbose = 1; + } + +# if ($#ARGV == 0) { +# printf(stderr "usage: qp2ps.pl runtime [prog [date]]\n"); +# exit 1; +# } +} + +# ----------------------------------------------------------------------------- +# Old way of drawing areas +# ----------------------------------------------------------------------------- + +exit 0; + +# Blocked Tasks +if ($someblocked && ($info_level >= 3)) { + print("$xmin $ymin moveto\n"); + for($i=($opt_S ? 2 : 1); $i <= $samples; $i++) { + do psout($T[$i],$G[$i]+$A[$i]+$C[$i]+$B[$i]+$Y[$i]+$R[$i]); + if ($i % $lines_per_flush == 0) { + print("red flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + + if ( $opt_m ) { + print "closepath red setgray fill\n"; + } else { + print "closepath red setrgbcolor fill\n"; + } +} + +# Fetching Tasks +if ($somefetching && ($info_level >= 4)) { + print("$xmin $ymin moveto\n"); + for($i=($opt_S ? 2 : 1); $i <= $samples; $i++) { + do psout($T[$i],$G[$i]+$A[$i]+$C[$i]+$B[$i]+$Y[$i]); + if ($i % $lines_per_flush == 0) { + print("cyan flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + + if ( $opt_m ) { + print "closepath cyan setgray fill\n"; + } else { + print "closepath cyan setrgbcolor fill\n"; + } +} + +# Sparks +if ($somesparks && ($info_level >= 6)) { + print("$xmin $ymin moveto\n"); + for($i=($opt_S ? 2 : 1); $i <= $samples; $i++) { + do psout($T[$i],$G[$i]+$A[$i]+$C[$i]+$B[$i]); + if ($i % $lines_per_flush == 0) { + print("crimson flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + + if ( $opt_m ) { + print "closepath crimson setgray fill\n"; + } else { + print "closepath crimson setrgbcolor fill\n"; + } +} + +# Migrating Threads +if ($somemigratory && ($info_level >= 5)) { + print("$xmin $ymin moveto\n"); + for($i=($opt_S ? 2 : 1); $i <= $samples; $i++) { + do psout($T[$i],$G[$i]+$A[$i]+$C[$i]); + if ($i % $lines_per_flush == 0) { + print("blue flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + # print("closepath\ngsave\n0.9 setgray\nfill\ngrestore\nstroke\n"); + if ( $opt_m ) { + print "closepath blue setgray fill\n"; + } else { + print "closepath blue setrgbcolor fill\n"; + } +} + +# Runnable Tasks +if($somerunnable && ($info_level >= 2)) { + print("$xmin $ymin moveto\n"); + for($i=($opt_S ? 2 : 1); $i <= $samples; $i++) { + do psout($T[$i],$G[$i]+$A[$i]); + if ($i % $lines_per_flush == 0) { + print("amber flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + # print("closepath\ngsave\n0.9 setgray\nfill\ngrestore\nstroke\n"); + if ( $opt_m ) { + print "closepath amber setgray fill\n"; + } else { + print "closepath amber setrgbcolor fill\n"; + } +} + +# Active Tasks +if ($info_level >= 1) { + print("$xmin $ymin moveto\n"); + for($i=($opt_S ? 2 : 1); $i <= $samples; $i++) { + do psout($T[$i],$G[$i]); + if ($i % $lines_per_flush == 0) { + print("green flush-it\n"); + } + } + # print("$xmax $ymin L\n"); + # print("closepath\ngsave\n0.5 setgray\nfill\ngrestore\nstroke\n"); + if ( $opt_m ) { + print "closepath green setgray fill\n"; + } else { + print "closepath green setrgbcolor fill\n"; + } +} + diff --git a/ghc/utils/pvm/README b/ghc/utils/pvm/README new file mode 100644 index 0000000000..a45840500a --- /dev/null +++ b/ghc/utils/pvm/README @@ -0,0 +1,7 @@ +"debugger2" is our hacked version of the one that +comes with PVM 3.3.7. + +Less sure about "debugger.emacs"... + +Will Partain +95/07/24 diff --git a/ghc/utils/pvm/debugger.emacs b/ghc/utils/pvm/debugger.emacs new file mode 100644 index 0000000000..ee053ca7b4 --- /dev/null +++ b/ghc/utils/pvm/debugger.emacs @@ -0,0 +1,37 @@ +#!/bin/csh -f +# +# debugger.csh +# +# this script is invoked by the pvmd when a task is spawned with +# the PvmTaskDebug flag set. it execs an xterm with script +# debugger2 running inside. +# +# 06 Apr 1993 Manchek +# + +if ($#argv < 1) then + echo "usage: debugger command [args]" + exit 1 +endif + +# scratch file for debugger commands + +set TEMPCMD=gdb$$.cmd +set TEMPLISP=gdb$$.el + +# default debugger and flags + +# +# run the debugger +# + +echo run $argv[2-] > $TEMPCMD +echo "(gdb "'"'"$argv[1] -q -x $TEMPCMD"'")' > $TEMPLISP + +emacs -l $TEMPLISP + +#rm -f $TEMPCMD $TEMPLISP + +exit 0 + + diff --git a/ghc/utils/pvm/debugger2 b/ghc/utils/pvm/debugger2 new file mode 100644 index 0000000000..7cdf8b9a1a --- /dev/null +++ b/ghc/utils/pvm/debugger2 @@ -0,0 +1,48 @@ +#!/bin/csh -f +# +# debugger2.csh +# +# this script is invoked in an xterm by the generic debugger script. +# it starts the debugger and waits when it exits to prevent the +# window from closing. +# +# it expects the pvmd to set envar PVM_ARCH. +# +# 06 Apr 1993 Manchek +# + +set noglob + +# scratch file for debugger commands + +set TEMPCMD=/tmp/debugger2.$$ + +# default debugger and flags + +set DBCMD="gdb" +set DBFF="-q -x $TEMPCMD" + +# +# try to pick the debugger by arch name +# + +# +# run the debugger +# + +echo run $argv[2-] > $TEMPCMD +$DBCMD $DBFF $argv[1] + +#$DBCMD $argv[1] + +#rm -f $TEMPCMD + +# +# wait to go away +# + +#reset +#sleep 1 +rm -f $TEMPCMD +exit 0 + diff --git a/ghc/utils/stat2resid/Jmakefile b/ghc/utils/stat2resid/Jmakefile new file mode 100644 index 0000000000..aed1c169cc --- /dev/null +++ b/ghc/utils/stat2resid/Jmakefile @@ -0,0 +1,26 @@ +/* stuff to have before we get going */ +MsubNeededHere(stat2resid) + +DYN_LOADABLE_BITS = \ + parse-gcstats.prl \ + process-gcstats.prl + +MsubMakefileDependentProgramScriptTarget(PerlCmd,stat2resid,stat2resid.prl,/*no flags*/,/*Makefile*/) + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTBINDIR_GHC) $(INSTLIBDIR_GHC)) + +InstallMsubbedScriptTarget(PerlCmd,stat2resid-v-temp-name,stat2resid.prl,$(INSTBINDIR_GHC)) +/* and continuing ... */ +install:: + $(MV) $(INSTBINDIR_GHC)/stat2resid-v-temp-name $(INSTBINDIR_GHC)/stat2resid + $(RM) $(INSTBINDIR_GHC)/stat2resid-v-temp-name + +dyn_loadable_bits : $(DYN_LOADABLE_BITS) + +InstallMultNonExecTargets(dyn_loadable_bits, $(DYN_LOADABLE_BITS), $(INSTLIBDIR_GHC)) + +install :: install_dyn_loadable_bits + +#endif /* DoInstallGHCSystem */ + diff --git a/ghc/utils/stat2resid/parse-gcstats.prl b/ghc/utils/stat2resid/parse-gcstats.prl new file mode 100644 index 0000000000..b6e80fd9e6 --- /dev/null +++ b/ghc/utils/stat2resid/parse-gcstats.prl @@ -0,0 +1,230 @@ +#!/local/sun4/bin/perl +# +# Subroutines to parses a ghc Garbage Collection stats file +# +#%gcstats = &parse_stats($ARGV[0]); +#&print_stats(">-", %gcstats); +#exit 0; + +sub to_num { + local ($text) = @_; + return($1 * 1000000000 + $2 * 1000000 + $3 * 1000 + $4) + if ( $text =~ /^(\d*),(\d*),(\d*),(\d*)$/ ); + return($1 * 1000000 + $2 * 1000 + $3) + if ( $text =~ /^(\d*),(\d*),(\d*)$/ ); + return($1 * 1000 + $2) + if ( $text =~ /^(\d*),(\d*)$/ ); + return($1) + if ( $text =~ /^(\d*)$/ ); + die "Error converting $text\n"; +} + +sub from_num { + local ($num) = @_; + local ($b, $m, $t, $o) = (int($num/1000000000), int($num/1000000)%1000, + int($num/1000)%1000, $num%1000); + return(sprintf("%d,%03d,%03d,%03d", $b, $m, $t, $o)) if $b > 0; + return(sprintf("%d,%03d,%03d", $m, $t, $o)) if $m > 0; + return(sprintf("%d,%03d", $t, $o)) if $t > 0; + return(sprintf("%d", $o)) if $o > 0; +} + +sub parse_stats { + local($filename) = @_; + local($tot_alloc, $tot_gc_user, $tot_mut_user, $tot_user, + $tot_gc_elap, $tot_mut_elap, $tot_elap); + local($statsfile, $line, $row, $col, $val); + local(@stats, @hdr1, @hdr2, @line_vals); + local(%the_stats); + + open($statsfile, $filename) || die "Cant open $filename \n"; + @stats = <$statsfile>; + + do {$line = shift(@stats);} until ($line !~ /^$/); + chop($line); + ($the_stats{"command"}, $the_stats{"args"}) = split(' ', $line, 2); + + do {$line = shift(@stats);} until ($line !~ /^$/); + $line =~ /Collector:\s*([A-Z]+)\s*HeapSize:\s*([\d,]+)/; + $the_stats{"collector"} = $1; + $the_stats{"heapsize"} = &to_num($2); + + do {$line = shift(@stats);} until ($line !~ /^$/); + chop($line); + @hdr1 = split(' ', $line); + $line = shift(@stats); + chop($line); + @hdr2 = split(' ', $line); + + $row = 0; + $tot_alloc = 0; + $tot_gc_user = 0; + $tot_gc_elap = 0; + $tot_mut_user = 0; + $tot_mut_elap = 0; + $tot_user = 0; + $tot_elap = 0; + + while (($line = shift(@stats)) !~ /^\s*\d+\s*$/) { + chop($line); + @line_vals = split(' ', $line); + + $col = -1; + word: + while(++$col <= $#line_vals) { + + $val = $line_vals[$col]; + $_ = @hdr1[$col] . @hdr2[$col]; + + /^Allocbytes$/ && do { $tot_alloc += $val; + $the_stats{"alloc_$row"} = $val; + next word; }; + + /^Collectbytes$/ && do { $the_stats{"collect_$row"} = $val; + next word; }; + + /^Livebytes$/ && do { $the_stats{"live_$row"} = $val; + next word; }; + + /^Residency$/ && do { next word; }; + + /^GCuser$/ && do { $tot_gc_user += $val; + $the_stats{"gc_user_$row"} = $val; + next word; }; + + /^GCelap$/ && do { $tot_gc_elap += $val; + $the_stats{"gc_elap_$row"} = $val; + next word; }; + + /^TOTuser$/ && do { $the_stats{"mut_user_$row"} = + $val - $tot_user - $the_stats{"gc_user_$row"}; + $tot_mut_user += $the_stats{"mut_user_$row"}; + $tot_user = $val; + next word; }; + + /^TOTelap$/ && do { $the_stats{"mut_elap_$row"} = + $val - $tot_elap - $the_stats{"gc_elap_$row"}; + $tot_mut_elap += $the_stats{"mut_elap_$row"}; + $tot_elap = $val; + next word; }; + + /^PageGC$/ && do { $the_stats{"gc_pflts_$row"} = $val; + next word; }; + + /^FltsMUT$/ && do { $the_stats{"mut_pflts_$row"} = $val; + next word; }; + + /^Collection/ && do { $the_stats{"mode_$row"} = $val; + next word; }; + + /^Astkbytes$/ && do {next word; }; + /^Bstkbytes$/ && do {next word; }; + /^CafNo$/ && do {next word; }; + /^Cafbytes$/ && do {next word; }; + + /^NoAstk$/ && do {next word; }; + /^ofBstk$/ && do {next word; }; + /^RootsReg$/ && do {next word; }; + /^OldGen$/ && do {next word; }; + /^RootsCaf$/ && do {next word; }; + /^Sizebytes$/ && do {next word; }; + /^Resid\%heap$/ && do {next word; }; + + /^$/ && do {next word; }; + + print STDERR "Unknown: $_ = $val\n"; + }; + + $row++; + }; + $tot_alloc += $line; + $the_stats{"alloc_$row"} = $line; + +arg: while($_ = $stats[0]) { + shift(@stats); + + /^\s*([\d,]+) bytes alloc/ && do { local($a) = &to_num($1); + $a == $tot_alloc || die "Total $a != $tot_alloc \n"; + $the_stats{"alloc_total"} = $tot_alloc; + next arg; }; + + /^\s*([\d]+) garbage/ && do { $1 == $row || die "GCNo $1 != $row \n"; + $the_stats{"gc_no"} = $row; + next arg; }; + + /Total time\s+([\d\.]+)s\s+\(\s*([\d.]+)s elapsed\)/ && do { + $the_stats{"user_total"} = $1; + $the_stats{"elap_total"} = $2; + $the_stats{"mut_user_total"} = $1 - $tot_gc_user; + $the_stats{"mut_elap_total"} = $2 - $tot_gc_elap; + $the_stats{"mut_user_$row"} = $1 - $tot_gc_user - $tot_mut_user; + $the_stats{"mut_elap_$row"} = $2 - $tot_gc_elap - $tot_mut_elap; + next arg; }; + + /GC time\s+([\d\.]+)s\s+\(\s*([\d.]+)s elapsed\)/ && do { + # $1 == $tot_gc_user || die "GCuser $1 != $tot_gc_user \n"; + # $2 == $tot_gc_elap || die "GCelap $2 != $tot_gc_elap \n"; + $the_stats{"gc_user_total"} = $tot_gc_user; + $the_stats{"gc_elap_total"} = $tot_gc_elap; + next arg; }; + + /MUT time/ && do { next arg; }; + + /\%GC time/ && do { next arg; }; + /Alloc rate/ && do { next arg; }; + /Productivity/ && do { next arg; }; + /^$/ && do { next arg; }; + /^\#/ && do { next arg; }; # Allows comments to follow + + print STDERR "Unmatched line: $_"; + } + + close($statsfile); + %the_stats; +} + +sub print_stats { + local ($filename, %out_stats) = @_; + local($statsfile, $row); + + open($statsfile, $filename) || die "Cant open $filename \n"; + select($statsfile); + + print $out_stats{"command"}, " ", $out_stats{"args"}, "\n\n"; + print "Collector: ", $out_stats{"collector"}, " HeapSize: ", &from_num($out_stats{"heapsize"}), " (bytes)\n\n"; + + $row = 0; + while ($row < $out_stats{"gc_no"}) { + printf "%7d %7d %7d %5.2f %5.2f %5.2f %5.2f %4d %4d %s\n", + $out_stats{"alloc_$row"}, + $out_stats{"collect_$row"}, + $out_stats{"live_$row"}, + $out_stats{"gc_user_$row"}, + $out_stats{"gc_elap_$row"}, + $out_stats{"mut_user_$row"}, + $out_stats{"mut_elap_$row"}, + $out_stats{"gc_pflts_$row"}, + $out_stats{"mut_pflts_$row"}, + $out_stats{"mode_$row"}; + $row++; + }; + printf "%7d %s %5.2f %5.2f \n\n", + $out_stats{"alloc_$row"}, " " x 27, + $out_stats{"mut_user_$row"}, + $out_stats{"mut_elap_$row"}; + + printf "Total Alloc: %s\n", &from_num($out_stats{"alloc_total"}); + printf " GC No: %d\n\n", $out_stats{"gc_no"}; + + printf " MUT User: %6.2fs\n", $out_stats{"mut_user_total"}; + printf " GC User: %6.2fs\n", $out_stats{"gc_user_total"}; + printf "Total User: %6.2fs\n\n", $out_stats{"user_total"}; + + printf " MUT Elap: %6.2fs\n", $out_stats{"mut_elap_total"}; + printf " GC Elap: %6.2fs\n", $out_stats{"gc_elap_total"}; + printf "Total Elap: %6.2fs\n", $out_stats{"elap_total"}; + + close($statsfile); +} + +1; diff --git a/ghc/utils/stat2resid/process-gcstats.prl b/ghc/utils/stat2resid/process-gcstats.prl new file mode 100644 index 0000000000..aff770ccf5 --- /dev/null +++ b/ghc/utils/stat2resid/process-gcstats.prl @@ -0,0 +1,46 @@ +#!/local/sun4/bin/perl +# +# Subroutines which derive information from +# ghc garbage collection stats -- %gcstat +# + +sub max_residency { + local(%gcstats) = @_; + local($i, $max) = (-1, 0); + + if ($gcstats{"collector"} eq "APPEL") { + die "APPEL stats: average residency not possible\n" ; + } + + while(++$i < $gcstats{"gc_no"}) { + $max = $gcstats{"live_$i"} > $max ? + $gcstats{"live_$i"} : $max; + } + $max; +} + +sub avg_residency { + local(%gcstats) = @_; + local($i, $j, $total); + + if ($gcstats{"collector"} eq "APPEL") { + die "APPEL stats: average residency not possible\n" ; + } + + if ($gcstats{"gc_no"} == 0) { return(0); }; + + $i = 0; $j = 0; + $total = $gcstats{"live_$i"} * $gcstats{"mut_user_$i"} / 2; + + while(++$i < $gcstats{"gc_no"}) { + $total += ($gcstats{"live_$i"} + $gcstats{"live_$j"}) + * $gcstats{"mut_user_$i"} / 2; + $j = $i; + }; + + $total += $gcstats{"live_$j"} * $gcstats{"mut_user_$i"} / 2; + + int($total / $gcstats{"mut_user_total"}); +} + +1; diff --git a/ghc/utils/stat2resid/stat2resid.prl b/ghc/utils/stat2resid/stat2resid.prl new file mode 100644 index 0000000000..95e9e742a5 --- /dev/null +++ b/ghc/utils/stat2resid/stat2resid.prl @@ -0,0 +1,73 @@ +# +# (c) The GRASP Project, Glasgow University, 1992 +# +# *** MSUB does some substitutions here *** +# *** grep for $( *** +# + +$debug = 0; +$outsuffix = ".resid.ps"; # change as appropriate +$tmpfile = "$(TMPDIR)/$$.resid.data"; + +@INC = ( ( $(INSTALLING) ) ? '$(INSTLIBDIR_GHC)' + : '$(TOP_PWD)/$(CURRENT_DIR)' ); + +require('parse-gcstats.prl') || die "Can't load parse-gcstats.prl!\n"; +require('process-gcstats.prl') || die "Can't load process-gcstats.prl!\n"; + +if ($#ARGV < 0) { + $infile = "-"; + $outfile = ""; # gnuplot: set output +} elsif ($#ARGV == 0) { + $infile = $ARGV[0]; + if ($infile =~ /^(.*)\.stat$/) { + $base = $1; + } else { + $base = $infile; + $infile = "$base.stat"; + }; + $outfile = "\"$base$outsuffix\""; # gnuplot: set output "outfile" +} elsif ($#ARGV == 1) { + $infile = $ARGV[0]; + $outfile = "\"$ARGV[1]\""; +} else { + die "Usage: command [infile[.stat] [outfile]]"; +}; + +%gcstats = &parse_stats($infile); + +&print_stats(">&STDERR", %gcstats) if $debug; + +if ($gcstats{"collector"} eq "APPEL") { + die "APPEL stats: no residency plot possible\n"; +} + +# +# stats are now loaded into %gcstats -- write out info +# + +open(DATAFILE, ">$tmpfile") || die "Cant open >$tmpfile \n"; +$i = -1; +$user = 0; +printf DATAFILE "%4.2f %d\n", $user, 0; +while (++$i < $gcstats{"gc_no"}) { + $user += $gcstats{"mut_user_$i"}; + printf DATAFILE "%4.2f %d\n", $user, $gcstats{"live_$i"}; +}; +printf DATAFILE "%4.2f %d\n", $gcstats{"mut_user_total"}, 0; +close(DATAFILE); + +open(PLOTFILE, "|gnuplot") || die "Cant pipe into |gnuplot \n"; +print PLOTFILE "set data style linespoints\n"; +print PLOTFILE "set function style lines\n"; +print PLOTFILE "set nokey\n"; +print PLOTFILE "set xlabel \"Mutator Time (secs)\"\n"; +print PLOTFILE "set ylabel \"Heap Residency (bytes)\" 0,-1\n"; +print PLOTFILE "set term post eps \"Times-Roman\" 20\n"; +printf PLOTFILE "set title \"%s %s (%s)\"\n", $gcstats{"command"}, $gcstats{"args"}, $infile; +print PLOTFILE "set output $outfile\n" ; +print PLOTFILE "plot \"$tmpfile\"\n"; +close(PLOTFILE); + +unlink($tmpfile); +exit 0; diff --git a/ghc/utils/ugen/Jmakefile b/ghc/utils/ugen/Jmakefile new file mode 100644 index 0000000000..e221781258 --- /dev/null +++ b/ghc/utils/ugen/Jmakefile @@ -0,0 +1,26 @@ +/* SRCS_C is for mkdependC's benefit */ +/* lex.c is from lex.l + syntax.tab.c is from syntax.y + tree.c is from tree.u (but a version is provided for bootstrapping) + + if it tries to run "ugen tree.u" while trying to build here, then + you are what is technically known as "dead in the water". +*/ +YFLAGS = -d + +SRCS_C = main.c gen.c lex.c syntax.tab.c id.c tree.c yyerror.c +OBJS_C = main.o gen.o lex.o syntax.tab.o id.o tree.o yyerror.o + +SuffixRule_c_o() + +BuildPgmFromCFiles(ugen,$(OBJS_C),,) + +/* InstallBinaryTarget(ugen,$(INSTBINDIR)) */ + +YaccRunWithExpectMsg(syntax,no,no) + +UgenTarget(tree) + +CDependTarget( $(SRCS_C) ) + +ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) lex.c syntax.tab.c syntax.tab.h ) diff --git a/ghc/utils/ugen/funs.h b/ghc/utils/ugen/funs.h new file mode 100644 index 0000000000..fc105efa1e --- /dev/null +++ b/ghc/utils/ugen/funs.h @@ -0,0 +1,28 @@ +/* fwd decls*/ +extern void g_consels PROTO((tree, id)); +extern void g_tagfun PROTO((id)); +extern void g_typconsel PROTO((tree, id)); +extern void ge_typdef PROTO((tree)); +extern void ge_typlist PROTO((tree)); +extern void gencons PROTO((id, tree)); +extern void genmkfillin PROTO((tree)); +extern void genmkparamdekl PROTO((tree)); +extern void genmkparamlist PROTO((tree)); +extern void genmkprotodekl PROTO((tree)); +extern void gensels PROTO((id, id, tree)); +extern void gentype PROTO((tree)); + +extern void gs_def PROTO((tree, id)); +extern void gs_itemlist PROTO((tree)); +extern void gs_typlist PROTO((tree, id)); + +extern void hs_def PROTO((tree)); +extern void hs_itemlist PROTO((tree)); +extern void hs_typlist PROTO((tree)); +extern void gen_hs_reader PROTO((id, tree)); +extern void gen_hs_rdalts PROTO((id, tree)); +extern void gen_hs_rdalt PROTO((id, tree)); +extern void gen_hs_rdcomponents PROTO((id, id, tree)); +extern void gen_hs_retcomponents PROTO((id, id, tree)); + +extern id installid PROTO((char *)); diff --git a/ghc/utils/ugen/gen.c b/ghc/utils/ugen/gen.c new file mode 100644 index 0000000000..2ba9cc342a --- /dev/null +++ b/ghc/utils/ugen/gen.c @@ -0,0 +1,494 @@ +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) () +#endif + +#include <stdio.h> +#include "id.h" +#include "tree.h" +#include "funs.h" +extern FILE *fh, *fc, *fhs; + +void +ge_typdef(t) + tree t; +{ + /* + ** Generate to the .h file: + ** + ** typdef enum { + ** constructor1, + ** constructor2, + ** ... + ** } *Ttypename; + */ + fprintf(fh, "#ifndef %s_defined\n", gtid(t)); + fprintf(fh, "#define %s_defined\n", gtid(t)); + fprintf(fh, "\n#include <stdio.h>\n"); /* for stderr */ + fprintf(fh, "\n#ifndef PROTO\n"); + fprintf(fh, "#ifdef __STDC__\n"); + fprintf(fh, "#define PROTO(x) x\n"); + fprintf(fh, "#else\n"); + fprintf(fh, "#define PROTO(x) /**/\n"); + fprintf(fh, "#endif\n"); + fprintf(fh, "#endif\n\n"); + fprintf(fh, "typedef enum {\n"); + ge_typlist(gtdeflist(t)); + fprintf(fh, "\n} T%s;\n\n", gtid(t)); + /* + ** Generate to the .hs file: + ** + ** data U_typename + ** = U_constructor1 | U_constructor2 | ... + */ + /* + ** Generate to the .h file: + ** + ** typedef struct { Ttypename tag; } *typename; + */ + fprintf(fh, "typedef struct { T%s tag; } *%s;\n\n", gtid(t), gtid(t)); + + g_tagfun(gtid(t)); /* generate the tag-grabbing function */ + + /* Generate the struct definitions (to the .h file). */ + gs_typlist(gtdeflist(t), gtid(t)); + + /* Generate a Haskell-equiv data type (to the .hs file) */ + fprintf(fhs, "data U_%s = ", gtid(t)); + hs_typlist(gtdeflist(t)); + fprintf(fhs, "\n\n"); + /* And a type with which to talk about the C-land parse tree */ +/* fprintf(fhs, "data U__%s = U__%s Addr#\n", gtid(t), gtid(t)); + fprintf(fhs, "instance _CCallable U__%s\n", gtid(t)); + fprintf(fhs, "instance _CReturnable U__%s\n\n", gtid(t)); +*/ +} + +void +ge_typlist(t) + tree t; +{ + switch(ttree(t)) { + case deflist: + ge_typlist(gdeflist(t)); + fprintf(fh, ",\n\t%s", gdid(gdef(t))); + break; + case def: + fprintf(fh, "\t%s", gdid(t)); + break; + default: + fprintf(stderr,"ge_typlist: funny abstract syntax.\n"); + break; + } +} + +void +gs_typlist(t, tid) + tree t; + id tid; +{ + switch(ttree(t)) { + case deflist: + gs_typlist(gdeflist(t), tid); + gs_def(gdef(t), tid); + break; + case def: + gs_def(t, tid); + break; + default: + fprintf(stderr,"gs_typlist: funny abstract syntax.\n"); + break; + } +} + +void +hs_typlist(t) + tree t; +{ + switch(ttree(t)) { + case deflist: + hs_typlist(gdeflist(t)); + fprintf(fhs, "| "); + hs_def(gdef(t)); + break; + case def: + hs_def(t); + break; + default: + fprintf(stderr,"hs_typlist: funny abstract syntax.\n"); + break; + } +} + +void +gs_def(t, tid) + tree t; + id tid; +{ + fprintf(fh, "struct S%s {\n", gdid(t)); + fprintf(fh, "\tT%s tag;\n", tid); + gs_itemlist(gditemlist(t)); + fprintf(fh, "};\n\n"); +} + +void +hs_def(t) + tree t; +{ + fprintf(fhs, "U_%s ", gdid(t)); + hs_itemlist(gditemlist(t)); +} + +void +gs_itemlist(t) + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + gs_itemlist(gitemlist(t)); + fprintf(fh, "\t%s X%s;\n", + gitemtypid(gitem(t)), gitemfunid(gitem(t)) ); + break; + case item: + fprintf(fh, "\t%s X%s;\n", + gitemtypid(t), gitemfunid(t)); + break; + default: + fprintf(stderr,"gs_itemlist: funny abs. syntax: %d\n.", ttree(t)); + break; + } +} + +void +hs_itemlist(t) + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + hs_itemlist(gitemlist(t)); + fprintf(fhs, "U_%s ", gitemtypid(gitem(t))); + break; + case item: + fprintf(fhs, "U_%s ", gitemtypid(t)); + break; + default: + fprintf(stderr,"hs_itemlist: funny abs. syntax: %d\n.", ttree(t)); + break; + } +} + +void +g_tagfun(typid) + id typid; +{ + fprintf(fh, "#ifdef __GNUC__\n"); + + fprintf(fh, "extern __inline__ T%s t%s(%s t)\n{\n\treturn(t -> tag);\n}\n", + typid, typid, typid); + + fprintf(fh, "#else /* ! __GNUC__ */\n"); + + fprintf(fh, "extern T%s t%s PROTO((%s));\n", typid, typid, typid); + fprintf(fc, "\nT%s t%s(t)\n %s t;\n{\n\treturn(t -> tag);\n}\n\n", + typid, typid, typid); + + fprintf(fh, "#endif /* ! __GNUC__ */\n\n"); +} +/*******************************************************************/ + +void +g_consels(t, typid) + tree t; + id typid; +{ + switch(ttree(t)) { + case deflist: + g_consels(gdeflist(t), typid); + g_typconsel(gdef(t), typid); + break; + case def: + g_typconsel(t, typid); + break; + default: + fprintf(stderr,"g_consel: funny abstract syntax.\n"); + break; + } +} + +/***********************************************************************/ + +void +g_typconsel(t, typid) + tree t; + id typid; +{ + fprintf(fc, "\n/************** %s ******************/\n\n", gdid(t)); + gencons(typid, t); + gensels(typid, gdid(t), gditemlist(t)); + fprintf(fh, "\n"); +} + +void +gencons(typid, t) + id typid; + tree t; /* of kind 'def'. */ +{ + fprintf(fh, "extern %s mk%s PROTO((", typid, gdid(t)); + genmkprotodekl(gditemlist(t)); + fprintf(fh, "));\n"); + + fprintf(fc, "%s mk%s(", typid, gdid(t)); + genmkparamlist(gditemlist(t)); + fprintf(fc, ")\n"); + genmkparamdekl(gditemlist(t)); + fprintf(fc, "{\n\tregister struct S%s *pp =\n", gdid(t)); + fprintf(fc, "\t\t(struct S%s *) malloc(sizeof(struct S%s));\n", + gdid(t), gdid(t)); + fprintf(fc, "\tpp -> tag = %s;\n", gdid(t)); + genmkfillin(gditemlist(t)); + fprintf(fc, "\treturn((%s)pp);\n", typid); + fprintf(fc, "}\n"); +} + +void +genmkparamlist(t) + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + genmkparamlist(gitemlist(t)); + fprintf(fc, ", "); + genmkparamlist(gitem(t)); + break; + case item: + fprintf(fc, "PP%s", gitemfunid(t)); + break; + default: + fprintf(stderr,"genparamlist: funny abs syntax.\n"); + break; + } +} + +void +genmkparamdekl(t) + tree t; /* of kind 'itemlist' or 'item' */ +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + genmkparamdekl(gitemlist(t)); + genmkparamdekl(gitem(t)); + break; + case item: + fprintf(fc, " %s PP%s;\n", gitemtypid(t), gitemfunid(t)); + break; + default: + fprintf(stderr,"genmkparamdekl: funny abs syntax.\n"); + break; + } +} + +void +genmkprotodekl(t) + tree t; /* of kind 'itemlist' or 'item' */ +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + genmkprotodekl(gitemlist(t)); + fprintf(fh, ", "); + genmkprotodekl(gitem(t)); + break; + case item: + fprintf(fh, "%s", gitemtypid(t)); + break; + default: + fprintf(stderr,"genmkprotodekl: funny abs syntax.\n"); + break; + } +} + +void +genmkfillin(t) + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + genmkfillin(gitemlist(t)); + genmkfillin(gitem(t)); + break; + case item: + fprintf(fc, "\tpp -> X%s = PP%s;\n", + gitemfunid(t), gitemfunid(t)); + break; + default: + fprintf(stderr,"genmkfillin: funny abs syntax.\n"); + break; + } +} + +void +gensels(typid, variantid, t) + id typid; + id variantid; + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + gensels(typid, variantid, gitemlist(t)); + gensels(typid, variantid, gitem(t)); + break; + case item: + fprintf(fh, "#ifdef __GNUC__\n"); + + fprintf(fh, "\nextern __inline__ %s *R%s(struct S%s *t)\n{\n", + gitemtypid(t), gitemfunid(t), variantid); + fprintf(fh, "#ifdef UGEN_DEBUG\n"); + fprintf(fh, "\tif(t -> tag != %s)\n", variantid); + fprintf(fh, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t)); + fprintf(fh, "#endif /* UGEN_DEBUG */\n"); + fprintf(fh, "\treturn(& t -> X%s);\n}\n", gitemfunid(t)); + + fprintf(fh, "#else /* ! __GNUC__ */\n"); + + fprintf(fh, + "extern %s *R%s PROTO((struct S%s *));\n", + gitemtypid(t), gitemfunid(t), variantid); + + fprintf(fc, "\n%s *R%s(t)\n struct S%s *t;\n{\n", + gitemtypid(t), gitemfunid(t), variantid); + fprintf(fc, "#ifdef UGEN_DEBUG\n"); + fprintf(fc, "\tif(t -> tag != %s)\n", variantid); + fprintf(fc, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t)); + fprintf(fc, "#endif /* UGEN_DEBUG */\n"); + fprintf(fc, "\treturn(& t -> X%s);\n}\n", gitemfunid(t)); + + fprintf(fh, "#endif /* ! __GNUC__ */\n\n"); + + fprintf(fh, + "#define %s(xyzxyz) (*R%s((struct S%s *) (xyzxyz)))\n", + gitemfunid(t), gitemfunid(t), variantid); + break; + default: + fprintf(stderr,"gensels: funny abs syntax.\n"); + break; + } + +} + +/***********************************************************************/ + +void +gen_hs_reader(typid, deflist) + id typid; + tree deflist; +{ + /* signature */ + fprintf(fhs, "rdU_%s :: _Addr -> UgnM U_%s\n", typid, typid); + + /* defn */ + fprintf(fhs, "rdU_%s t\n = ioToUgnM (_ccall_ t%s t) `thenUgn` \\ tag@(I# _) ->\n", typid, typid); + fprintf(fhs, " if "); + gen_hs_rdalts(typid, deflist); + fprintf(fhs, " else\n\terror (\"rdU_%s: bad tag selection:\"++show tag++\"\\n\")\n", typid); +} + +void +gen_hs_rdalts(typid, t) + id typid; + tree t; +{ + switch(ttree(t)) { + case deflist: + gen_hs_rdalts(typid, gdeflist(t)); + fprintf(fhs, " else if "); + gen_hs_rdalt (typid, gdef(t)); + break; + case def: + gen_hs_rdalt(typid, t); + break; + default: + fprintf(stderr,"gen_hs_rdalts: funny abstract syntax.\n"); + break; + } +} + +void +gen_hs_rdalt(typid, t) + id typid; + tree t; +{ + fprintf(fhs, "tag == ``%s'' then\n", gdid(t)); + gen_hs_rdcomponents (typid, gdid(t), gditemlist(t)); + fprintf(fhs, "\treturnUgn (U_%s ", gdid(t)); + gen_hs_retcomponents(typid, gdid(t), gditemlist(t)); + fprintf(fhs, ")\n"); /* end of alt */ +} + +void +gen_hs_rdcomponents(typid, variantid, t) + id typid; + id variantid; + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + gen_hs_rdcomponents(typid, variantid, gitemlist(t)); + gen_hs_rdcomponents(typid, variantid, gitem(t)); + break; + case item: + fprintf(fhs, "\tioToUgnM (_ccall_ %s t) `thenUgn` \\ x_%s ->\n", + gitemfunid(t), gitemfunid(t)); + + fprintf(fhs, "\trdU_%s x_%s `thenUgn` \\ y_%s ->\n", + gitemtypid(t), gitemfunid(t), gitemfunid(t)); + +/* fprintf(fhs, "\tif(t -> tag != %s)\n", variantid); + fprintf(fhs, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t)); + fprintf(fhs, "\treturn(& t -> X%s);\n}\n", gitemfunid(t)); +*/ break; + + default: + fprintf(stderr,"gen_hs_rdcomponents: funny abs syntax.\n"); + break; + } +} + +void +gen_hs_retcomponents(typid, variantid, t) + id typid; + id variantid; + tree t; +{ + switch(ttree(t)) { + case emitemlist: + break; + case itemlist: + gen_hs_retcomponents(typid, variantid, gitemlist(t)); + fprintf(fhs, " "); + gen_hs_retcomponents(typid, variantid, gitem(t)); + break; + case item: + fprintf(fhs, "y_%s", gitemfunid(t)); + break; + + default: + fprintf(stderr,"gen_hs_retcomponents: funny abs syntax.\n"); + break; + } +} diff --git a/ghc/utils/ugen/id.c b/ghc/utils/ugen/id.c new file mode 100644 index 0000000000..f8c02034c1 --- /dev/null +++ b/ghc/utils/ugen/id.c @@ -0,0 +1,49 @@ +# include "id.h" + +#define bool int +#define true 1 +#define false 0 + +char id_area[10000]; +char *id_top = &id_area[0]; + + + +/* +** Equalid returns true if the two identifiers are the same, +** otherwise false. +*/ +bool equalid(i1, i2) + id i1, i2; +{ + return(i1 == i2); +} + +/* +** Installid installs an identifier into the id_area. +*/ +id installid(string) + char *string; +{ + char *startofid, *search, *s; + + for(search = id_area; search < id_top;) { + startofid = search; + s = string; + while(*search++ == *s++) { + if(*search == 0 && *s == 0) { + return(startofid); + } + } + while(*search != 0) + search++; + search++; + } + + startofid = id_top; + for(s = string; *s != 0;) { + *id_top++ = *s++; + } + *id_top++ = 0; + return(startofid); +} diff --git a/ghc/utils/ugen/id.h b/ghc/utils/ugen/id.h new file mode 100644 index 0000000000..4c17446194 --- /dev/null +++ b/ghc/utils/ugen/id.h @@ -0,0 +1 @@ +typedef char *id; diff --git a/ghc/utils/ugen/lex.l b/ghc/utils/ugen/lex.l new file mode 100644 index 0000000000..3d0e95eb68 --- /dev/null +++ b/ghc/utils/ugen/lex.l @@ -0,0 +1,51 @@ +%{ +#define YYSTYPE long + +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) () +#endif + +# include "syntax.tab.h" +# include <stdio.h> +# include "id.h" +# include "tree.h" +# include "funs.h" +extern YYSTYPE yylval; +extern FILE *fc, *fhs; +#undef ECHO /* partain */ +#define ECHO /*fprintf(stderr, "%s", yytext)*/ + +%} +%% +";" { ECHO; return(SEMICOL); } +":" { ECHO; return(COLON); } +"<" { ECHO; return(STDEF); } +">" { ECHO; return(ENDDEF); } +"type" { ECHO; return(TYPE); } +"end" { ECHO; return(END); } +[A-Za-z][A-Za-z0-9_]* { + ECHO; + yylval = (YYSTYPE) installid(yytext); + return(ID); + } +. ECHO; +"\n" ECHO; +"/*"([^*]|"*"[^/]|\n)*"*/" ECHO; +"%{{"([^%]|"%"[^}]|\n)*"%}}" { /* partain: for Haskell includes */ + ECHO; + yytext[yyleng-3] = '\0'; + fprintf(fhs, "\n%s", &yytext[3]); + } +"%{"([^%]|"%"[^}]|\n)*"%}" { + ECHO; + yytext[yyleng-2] = '\0'; + fprintf(fc, "\n%s", &yytext[2]); + } +%% +int +yywrap() +{ + return(1); +} diff --git a/ghc/utils/ugen/main.c b/ghc/utils/ugen/main.c new file mode 100644 index 0000000000..324ed5052b --- /dev/null +++ b/ghc/utils/ugen/main.c @@ -0,0 +1,87 @@ +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) () +#endif + +#include <stdio.h> +#include "id.h" +#include "tree.h" + +#include "funs.h" + +FILE *fh, *fc, *fhs; + +tree root; /* The root of the built syntax tree. */ + +main(argc, argv) + int argc; + char **argv; +{ + int i = 0; + + if(argc != 2) { + printf("Missing input file.\n"); + exit(1); + } + + if(freopen(argv[1], "r", stdin) == NULL) { + fprintf(stderr, "Cannot open %s.\n", argv[1]); + exit(1); + } + + while(argv[1][i+1] != 0) + i++; + if(! (argv[1][i-3] == '.' && + argv[1][i-2] == 'u' && + argv[1][i-1] == 'g' && + argv[1][i] == 'n')) { + fprintf(stderr, "Not a .ugn file\n"); + exit(1); + } + + argv[1][i-2] = 'c'; + argv[1][i-1] = '\0'; + fc = fopen(argv[1], "w"); /* .c file */ + argv[1][i-2] = 'h'; + fh = fopen(argv[1], "w"); /* .h file */ + argv[1][i-1] = 's'; + argv[1][i] = '\0'; + fhs = fopen(argv[1], "w"); /* .hs file */ + argv[1][i-1] = '\0'; + + if(yyparse() == 0) { + /* No syntax errors. */ + + fprintf(fc, "#include \"%s\"\n", argv[1]); + gentype(root); + exit(0); + + } else { + /* There was a syntax error. */ +/* ToDo: this stuff is now *WWRROONNGG* (WDP 94/10) */ + unlink(argv[1][i]); + argv[i][i] = 'c'; + unlink(argv[1][i]); + fprintf(stderr, "Nothing generated.\n"); + exit(1); + } +} + +void +gentype(t) + tree t; +{ + ge_typdef(t); /* Generate the .h - file. */ + + /* Generate the struct definitions. */ +/*partain:moved gs_typlist(gtdeflist(t), gtid(t)); +*/ + /* Generate constructors and selectors. */ + g_consels(gtdeflist(t), gtid(t)); + + fprintf(fh, "#endif\n"); /* for .h multi-slurp protector */ + + /* Generate Haskell reader */ + gen_hs_reader(gtid(t), gtdeflist(t)); +} diff --git a/ghc/utils/ugen/manual.mm b/ghc/utils/ugen/manual.mm new file mode 100644 index 0000000000..7c64fdcb6a --- /dev/null +++ b/ghc/utils/ugen/manual.mm @@ -0,0 +1,226 @@ +.nr N 1 +.nr L 72 +.so /usr/lib/tmac/tmac.m +.SA 1 +.ce +\fIRecursive Data Types Made Simple with Ugen\fR +.sp +.ce +Thomas Johnsson +.sp 2 +.ce +\*(DT +.sp 2 +.H 1 "Introduction" +Recursive datatypes in an important class of data structures +we often use in, for instance, abstract syntax trees in compilers. +An example of a recursive data type is shown below +(written in some hypothetical language): +.DS + \fItype\fR bintree = + \fIunion\fR + interior: (bintree, bintree); + leaf: (int ); + \fIend union\fR; +.DE +The type bintree is a union of two variants: 'interior' which consists +of two bintrees, and 'leaf' which has an integer value associated to it. +.P +The program \fIugen\fR is yet another tool which relieves the +the C-programmer from the burden of implementing the +constructor-, selector- and variant test functions associated to +such a type. +.H 1 "How to use ugen" +Suppose the specification below is in a file called 'treedef.u'. +.DS + type bintree; + interior : < getleft: bintree; getright: bintree; >; + leaf : < getint: int; >; + end; +.DE +The command +.DS + ugen treedef.u +.DE +creates two files: 'treedef.c' and 'treedef.h'. +The file 'treedef.h' will contain the following definitions: +.DS + typedef enum{ interior, leaf } Tbintree; + typedef .... *bintree; +.DE +The type 'Tbintree' is an enumerated type with the same identifiers as +the variants of the recursive data type, +the type 'bintree' is implemented as a pointer to something. +This file must be included in all files where the type 'bintree' +is used. +Furthermore, the file treedef.h also contains macro definitions for +the selector functions; these macroes simply use the corresponding function +in treedefs.c that returns a pointer to that intended field. +In this manner, updating of a field can be done by simple assignment, +by for example +.DS + getleft(x) = ..... +.DE +The file 'treedef.c' will contain the following definitions. +.sp +.nf +.in +4 +#include "treedef.h" +/* The function tbintree returns the variant of the + * bintree parameter. + */ +Tbintree tbintree(t) bintree t; { ... } + +/* Constructor function for variant interior. + */ +bintree mkinterior(t1, t2) bintree t1, t2; { ... } + +/* Its selector functions, returns pointers to a field in the node. + */ +bintree *Xgetleft(t) bintree t; { ... } +bintree *Xgetright(t) bintree t; { ... } + + +/* Constructor function for variant leaf. + */ +bintree mkleaf(i) int i; { ... } + +/* Its selector function. + */ +int getint(t) bintree t; { ... } +.in -4 +.sp +.fi +The pointers returned by the constructor functions are +returned by the memory allocation function \fImalloc\fR, +so one may use \fIfree\fR to reclaim storage, if that is desired. +.P +The appendix contains the file listings of a complete program +that reads an expression on normal infix form and prints +it in prefix form, eg: +.DS + input: 12 + 3 * 5 + output: +(12, *(3, 5)) +.DE +Lex and yacc has been used for lexical- and syntax analysis, +ugen for the intermediate tree form, and make maintains it all. +.HU "Appendix - Example of use of ugen" +.nf +.sp +syntax.y: +.in +4 +.sp +%{ +#include "tree.h" +extern tree root; +%} +%token PLUS TIMES LPAR RPAR INT +%left PLUS +%right TIMES +%start top +%% +top : expr { root = $1; } + +expr : expr PLUS expr { $$ = mkplus($1, $3); } | + expr TIMES expr { $$ = mktimes($1, $3); } | + LPAR expr RPAR { $$ = $2; } | + INT { $$ = mkinteger($1);} +%% +yyerror(s) char *s; { + printf("%s\n", s); +} +.sp +.in -4 +lexicals.l: +.in +4 +.sp +%{ +#include <stdio.h> +#include "y.tab.h" +extern int yylval; +%} +%% +"*" return(TIMES); +"+" return(PLUS); +"(" return(LPAR); +")" return(RPAR); +[0-9]+ { sscanf(yytext, "%d", &yylval); + return(INT); + } +. ; +"\\n" ; +%% +int yywrap(){ return(1); } +.sp +.in -4 +main.c: +.in +4 +.sp +#include "tree.h" +tree root; + +main() { + if(! yyparse()) /* if no syntax errors .. */ + prefixprint(root); +} + +prefixprint(t) + tree t; +{ + switch(ttree(t)) { + case plus: + printf("+("); + prefixprint(gplusleft(t)); + printf(", "); + prefixprint(gplusright(t)); + printf(")"); + break; + case times: + printf("*("); + prefixprint(gtimesleft(t)); + printf(", "); + prefixprint(gtimesright(t)); + printf(")"); + break; + case integer: + printf("%d", getint(t)); + break; + } +} +.sp +.in -4 +.SK +tree.u: +.sp +.in +4 +type tree; + plus :< gplusleft : tree; + gplusright : tree; + >; + times :< gtimesleft : tree; + gtimesright : tree; + >; + integer :< getint : int; + >; +end; +.sp +.in -4 +makefile: +.sp +.in +4 +pre : main.o y.tab.o lex.yy.o tree.o + cc main.o y.tab.o lex.yy.o tree.o -o pre +main.o : main.c tree.h + cc -c main.c +y.tab.o : y.tab.c + cc -c y.tab.c +lex.yy.o: lex.yy.c y.tab.h + cc -c lex.yy.c +tree.o : tree.c tree.h + cc -c tree.c +y.tab.c : syntax.y + yacc -d syntax.y +lex.yy.c: lexicals.l + lex lexicals.l +tree.c tree.h : tree.u + ugen tree.u diff --git a/ghc/utils/ugen/syntax.y b/ghc/utils/ugen/syntax.y new file mode 100644 index 0000000000..2b14823764 --- /dev/null +++ b/ghc/utils/ugen/syntax.y @@ -0,0 +1,50 @@ +%{ +#define YYSTYPE long +# include "id.h" +# include "tree.h" +extern tree root; +%} +%token ID TYPE SEMICOL COLON END STDEF ENDDEF +%% + +typdef : + TYPE ID SEMICOL deflist END SEMICOL = + { + root = mktypdef($2, $4); + }; + +deflist : + def = + { + $$ = $1; + } | + deflist def = + { + $$ = (long) mkdeflist($1, $2); + }; + +def : + ID COLON STDEF itemlist ENDDEF SEMICOL = + { + $$ = (long) mkdef($1, $4); + } | + ID COLON STDEF ENDDEF SEMICOL = + { + $$ = (long) mkdef($1, mkemitemlist()); + }; + +itemlist: + item = + { + $$ = $1; + } | + itemlist item = + { + $$ = (long) mkitemlist($1, $2); + }; + +item : + ID COLON ID SEMICOL = + { + $$ = (long) mkitem($1, $3); + }; diff --git a/ghc/utils/ugen/tree.ugn b/ghc/utils/ugen/tree.ugn new file mode 100644 index 0000000000..758aabae49 --- /dev/null +++ b/ghc/utils/ugen/tree.ugn @@ -0,0 +1,27 @@ +%{ +#include "id.h" +%} +type tree; + + typdef : < + gtid : id; + gtdeflist : tree; + >; + deflist : < + gdeflist : tree; + gdef : tree; + >; + def : < + gdid : id; + gditemlist : tree; + >; + itemlist : < + gitemlist : tree; + gitem : tree; + >; + emitemlist: < >; + item : < + gitemfunid : id; + gitemtypid : id; + >; +end; diff --git a/ghc/utils/ugen/yyerror.c b/ghc/utils/ugen/yyerror.c new file mode 100644 index 0000000000..4b9a0380d1 --- /dev/null +++ b/ghc/utils/ugen/yyerror.c @@ -0,0 +1,24 @@ +#include <stdio.h> +extern int yylineno; + +void +yyerror(s) + char *s; +{ + extern int yychar; + extern char yytext[1]; + + fprintf(stderr, "\n%s", s); + if(yylineno) + fprintf(stderr, ", line %d, ", yylineno); + fprintf(stderr, "on input: "); + if( yychar >= 0400 ) + fprintf(stderr, "%s\n", &yytext[0]); + else + switch(yychar) { + case '\t' : fprintf(stderr, "\\t\n"); break; + case '\n' : fprintf(stderr, "\\n\n"); break; + case '\0' : fprintf(stderr, "$end\n"); break; + default : fprintf(stderr, "%c\n", yychar); break; + } +} diff --git a/ghc/utils/unlit/Jmakefile b/ghc/utils/unlit/Jmakefile new file mode 100644 index 0000000000..83502b5247 --- /dev/null +++ b/ghc/utils/unlit/Jmakefile @@ -0,0 +1,10 @@ +SuffixRule_c_o() + +BuildPgmFromOneCFile(unlit) + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC)) +InstallBinaryTarget(unlit, $(INSTLIBDIR_GHC)) +#endif /* DoInstall... */ + +CDependTarget( $(SRCS_C) ) diff --git a/ghc/utils/unlit/README b/ghc/utils/unlit/README new file mode 100644 index 0000000000..4dd2ef5132 --- /dev/null +++ b/ghc/utils/unlit/README @@ -0,0 +1,8 @@ +This "unlit" program, used by the GHC driver, is originally by Mark +Jones (then at Oxford). It is taken in its present form *directly* +from the LML/HBC distribution (from Chalmers). + +We are grateful for this piece of shared code. + +For more "powerful" swizzling of literate scripts, please see the +"literate" stuff from Glasgow. diff --git a/ghc/utils/unlit/unlit.c b/ghc/utils/unlit/unlit.c new file mode 100644 index 0000000000..ff9c6781aa --- /dev/null +++ b/ghc/utils/unlit/unlit.c @@ -0,0 +1,327 @@ +/* unlit.c Wed Dec 5 17:16:24 GMT 1990 + * + * Literate script filter. In contrast with the format used by most + * programming languages, a literate script is a program in which + * comments are given the leading role, whilst program text must be + * explicitly flagged as such by placing a `>' character in the first + * column on each line. It is hoped that this style of programming will + * encourage the writing of accurate and clearly documented programs + * in which the writer may include motivating arguments, examples + * and explanations. + * + * Unlit is a filter that can be used to strip all of the comment lines + * out of a literate script file. The command format for unlit is: + * unlit [-n] [-q] ifile ofile + * where ifile and ofile are the names of the input (literate script) and + * output (raw program) files respectively. Either of these names may + * be `-' representing the standard input or the standard output resp. + * A number of rules are used in an attempt to guard against the most + * common errors that are made when writing literate scripts: + * 1) Empty script files are not permitted. A file in which no lines + * begin with `>' usually indicates a file in which the programmer + * has forgotten about the literate script convention. + * 2) A line containing part of program definition (i.e. preceeded by `>') + * cannot be used immediately before or after a comment line unless + * the comment line is blank. This error usually indicates that + * the `>' character has been omitted from a line in a section of + * program spread over a number of lines. + * Using the -q (quiet) flag suppresses the signalling of these error + * conditions. The default behaviour can be selected explicitly using + * the -n (noisy) option so that any potential errors in the script file + * are reported. + * + * The original idea for the use of literate scripts is due to Richard + * Bird of the programming Research Group, Oxford and was initially + * adopted for use in the implementation of the functional programming + * language Orwell used for teaching in Oxford. This idea has subsequently + * been borrowed in a number of other language implementations. + * + * Modified to understand \begin{code} ... \end{code} used in Glasgow. -- LA + * And \begin{pseudocode} ... \end{pseudocode}. -- LA + */ + +#include <stdio.h> +#include <ctype.h> + +#define NULLSTR ((char *)0) +#define DEFNCHAR '>' +#define MISSINGBLANK "unlit: Program line next to comment" +#define EMPTYSCRIPT "unlit: No definitions in file (perhaps you forgot the '>'s?)" +#define USAGE "usage: unlit [-q] [-n] [-c] file1 file2\n" +#define CANNOTOPEN "unlit: cannot open \"%s\"\n" +#define DISTINCTNAMES "unlit: input and output filenames must differ\n" +#define MISSINGCODE "unlit: missing %s\n" + +#define BEGINCODE "\\begin{code}" +#define LENBEGINCODE 12 +#define ENDCODE "\\end{code}" +#define LENENDCODE 10 +#ifdef PSEUDOCODE +/* According to Will Partain, the inventor of pseudocode, this gone now. */ +#define BEGINPSEUDOCODE "\\begin{pseudocode}" +#define LENBEGINPSEUDOCODE 18 +#define ENDPSEUDOCODE "\\end{pseudocode}" +#define LENENDPSEUDOCODE 16 +#endif + +typedef enum { START, BLANK, TEXT, DEFN, BEGIN, /*PSEUDO,*/ END, HASH } line; +#define isWhitespace(c) (c==' ' || c=='\t') +#define isLineTerm(c) (c=='\n' || c==EOF) + +static int noisy = 1; /* 0 => keep quiet about errors, 1 => report errors */ +static int errors = 0; /* count the number of errors reported */ +static int crunchnl = 0; /* don't print \n for removed lines */ +static int leavecpp = 1; /* leave preprocessor lines */ + +/* complain(file,line,what) + * + * print error message `what' for `file' at `line'. The error is suppressed + * if noisy is not set. + */ + +complain(file, lin, what) +char *file; +char *what; +int lin; { + if (noisy) { + if (file) + fprintf(stderr, "%s ", file); + fprintf(stderr,"line %d: %s\n",lin,what); + errors++; + } +} + +#define TABPOS 8 + +/* As getc, but does TAB expansion */ +int +egetc(istream) +FILE *istream; +{ + static int spleft = 0; + static int linepos = 0; + int c; + + if (spleft > 0) { + spleft--; + linepos++; + return ' '; + } + c = getc(istream); + if (c == EOF) + return c; + else if (c == '\n' || c == '\f') { + linepos = 0; + return c; + } else if (c == '\t') { + spleft = TABPOS - linepos % TABPOS; + spleft--; + linepos++; + return ' '; + } else { + linepos++; + return c; + } + +} + +/* readline(istream, ostream) + * + * Read a line from the input stream `istream', and return a value + * indicating whether that line was: + * BLANK (whitespace only), + * DEFN (first character is DEFNCHAR), + * TEXT (a line of text) + * BEGIN (a \begin{code} line) + * PSEUDO (a \begin{pseodocode} line) + * HASH (a preprocessor line) + * or END (indicating an EOF). + * Lines of type DEFN are copied to the output stream `ostream' + * (without the leading DEFNCHAR). BLANK and TEXT lines are + * replaced by empty (i.e. blank lines) in the output stream, so + * that error messages refering to line numbers in the output file + * can also be used to locate the corresponding line in the input + * stream. + */ + +line readline(istream,ostream) +FILE *istream, *ostream; { + int c = egetc(istream); + char buf[100]; + int i; + + if (c==EOF) + return END; + + if (leavecpp && c=='#') { + putc(c, ostream); + while (c=egetc(istream), !isLineTerm(c)) + putc(c,ostream); + putc('\n',ostream); + return HASH; + } + + if (c==DEFNCHAR) { +/* putc(' ',ostream);*/ + while (c=egetc(istream), !isLineTerm(c)) + putc(c,ostream); + putc('\n',ostream); + return DEFN; + } + + if (!crunchnl) + putc('\n',ostream); + + while (isWhitespace(c)) + c=egetc(istream); + if (isLineTerm(c)) + return BLANK; + + i = 0; + buf[i++] = c; + while (c=egetc(istream), !isLineTerm(c)) + if (i < sizeof buf - 1) + buf[i++] = c; + while(i > 0 && isspace(buf[i-1])) + i--; + buf[i] = 0; + if (strcmp(buf, BEGINCODE) == 0) + return BEGIN; +#ifdef PSEUDOCODE + else if (strcmp(buf, BEGINPSEUDOCODE) == 0) + return PSEUDO; +#endif + else + return TEXT; +} + + +/* unlit(file,istream,ostream) + * + * Copy the file named `file', accessed using the input stream `istream' + * to the output stream `ostream', removing any comments and checking + * for bad use of literate script features: + * - there should be at least one BLANK line between a DEFN and TEXT + * - there should be at least one DEFN line in a script. + */ + +unlit(file, istream, ostream) +char *file; +FILE *istream; +FILE *ostream; { + line last, this=START; + int linesread=0; + int defnsread=0; + + do { + last = this; + this = readline(istream, ostream); + linesread++; + if (this==DEFN) + defnsread++; + if (last==DEFN && this==TEXT) + complain(file, linesread-1, MISSINGBLANK); + if (last==TEXT && this==DEFN) + complain(file, linesread, MISSINGBLANK); + if (this == BEGIN) { + /* start of code, copy to end */ + char lineb[1000]; + for(;;) { + if (fgets(lineb, sizeof lineb, istream) == NULL) { + fprintf(stderr, MISSINGCODE, ENDCODE); + exit(1); + } + linesread++; + if (strncmp(lineb,ENDCODE,LENENDCODE) == 0) { + putc('\n', ostream); + break; + } + fputs(lineb, ostream); + } + defnsread++; + } +#ifdef PSEUDOCODE + if (this == PSEUDO) { + char lineb[1000]; + for(;;) { + if (fgets(lineb, sizeof lineb, istream) == NULL) { + fprintf(stderr, MISSINGCODE, ENDPSEUDOCODE); + exit(1); + } + linesread++; + putc('\n', ostream); + if (strncmp(lineb,ENDPSEUDOCODE,LENENDPSEUDOCODE) == 0) { + break; + } + } + } +#endif + } while(this!=END); + + if (defnsread==0) + complain(file,linesread,EMPTYSCRIPT); +} + +/* main(argc, argv) + * + * Main program. Processes command line arguments, looking for leading: + * -q quiet mode - do not complain about bad literate script files + * -n noisy mpde - complain about bad literate script files. + * Expects two additional arguments, a file name for the input and a file + * name for the output file. These two names must normally be distinct. + * An exception is made for the special name "-" which can be used in either + * position to specify the standard input or the standard output respectively. + */ + +main(argc,argv) +int argc; +char **argv; { + FILE *istream, *ostream; + char *file; + + for (argc--, argv++; argc > 0; argc--, argv++) + if (strcmp(*argv,"-n")==0) + noisy = 1; + else if (strcmp(*argv,"-q")==0) + noisy = 0; + else if (strcmp(*argv,"-c")==0) + crunchnl = 1; + else + break; + + if (argc!=2) { + fprintf(stderr, USAGE); + exit(1); + } + + if (strcmp(argv[0],argv[1])==0 && strcmp(argv[0],"-")!=0) { + fprintf(stderr, DISTINCTNAMES); + exit(1); + } + + file = argv[0]; + if (strcmp(argv[0], "-")==0) { + istream = stdin; + file = "stdin"; + } + else + if ((istream=fopen(argv[0], "r")) == NULL) { + fprintf(stderr, CANNOTOPEN, argv[0]); + exit(1); + } + + if (strcmp(argv[1], "-")==0) + ostream = stdout; + else + if ((ostream=fopen(argv[1], "w")) == NULL) { + fprintf(stderr, CANNOTOPEN, argv[1]); + exit(1); + } + + unlit(file, istream, ostream); + + fclose(istream); + fclose(ostream); + + exit(errors==0 ? 0 : 1); +} |