* Hugs version 1.4, December 1997
*
* $RCSfile: options.h,v $
- * $Revision: 1.28 $
- * $Date: 2000/05/09 09:26:29 $
+ * $Revision: 1.29 $
+ * $Date: 2000/05/10 09:00:20 $
* ------------------------------------------------------------------------*/
#define PROVIDE_PTREQUALITY 1
#define PROVIDE_CONCURRENT 1
-/* Enable a crude profiler which counts BCO entries, bytes allocated
- and bytecode insns executed on a per-fn basis. Used for assessing
- the effect of the simplifier/optimiser.
-*/
-#undef CRUDE_PROFILING
-
/* Turn bytecode interpreter support on/off.
*/
#define INTERPRETER 1
* included in the distribution.
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.23 $
- * $Date: 2000/04/27 16:35:29 $
+ * $Revision: 1.24 $
+ * $Date: 2000/05/10 09:00:20 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
* Profile and accelerate. Code generation is slower because linking
is slower. Evaluation GC is slower because markHugsObjects has
- sloweed down.
+ slowed down.
* Make setCurrentModule ignore name table entries created by the
lambda-lifter.
-
-* Zap various #if 0 in codegen.c/Assembler.c.
-
-* Zap CRUDE_PROFILING.
*/
}
}
-#if 0
-static void cgPushRef ( AsmBCO bco, Cell c )
-{
- switch (whatIs(c)) {
- case CPTRCELL:
- asmPushRefNoOp(bco,(StgPtr)cptrOf(c)); break;
- case PTRCELL:
- asmPushRefObject(bco,ptrOf(c)); break;
- case NAME:
- case TUPLE:
- asmPushRefHugs(bco,c); break;
- default:
- internal("cgPushRef");
- }
-}
-#endif
-
/* Get a pointer to atom e onto the stack. */
static Void pushAtom ( AsmBCO bco, StgAtom e )
{
static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
{
-#ifdef CRUDE_PROFILING
- AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
-#else
AsmBCO bco = asmBeginContinuation(sp, alts);
-#endif
Bool omit_test
= length(alts) == 2 &&
isDefaultAlt(hd(tl(alts))) &&
}
else
internal("build: STGAPP");
-#if 0
-Looks like a hack to me.
- if (isName(fun)) {
- if (nonNull(name(fun).closure))
- fun = name(fun).closure; else
- fun = cptrFromName(fun);
- }
-
- if (isCPtr(fun)) {
- assert(isName(fun0));
- itsaPAP = name(fun0).arity > length(args);
-# if DEBUG_CODEGEN
- fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
- nameFromOPtr(cptrOf(fun)), name(fun0).arity,
- length(args) );
-# endif
- } else {
- itsaPAP = FALSE;
- if (nonNull(stgVarBody(fun))
- && whatIs(stgVarBody(fun)) == LAMBDA
- && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
- )
- itsaPAP = TRUE;
- }
-#endif
if (itsaPAP) {
AsmSp start = asmBeginMkPAP(bco);
setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
break;
case LAMBDA:
-# ifdef CRUDE_PROFILING
- setObj(v,asmBeginBCO(currentTop));
-# else
setObj(v,asmBeginBCO(rhs));
-# endif
break;
default:
setObj(v,asmBeginCAF());
* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.30 $
- * $Date: 2000/04/27 16:35:29 $
+ * $Revision: 1.31 $
+ * $Date: 2000/05/10 09:00:20 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
This all also seems to imply that doRevertCAFs should always
be TRUE.
*/
-
-# ifdef CRUDE_PROFILING
- cp_init();
-# endif
-
{
HaskellObj result; /* ignored */
SchedulerStatus status;
fflush(stdout);
fflush(stderr);
}
-# ifdef CRUDE_PROFILING
- cp_show();
-# endif
-
}
* included in the distribution.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.40 $
- * $Date: 2000/04/27 16:35:29 $
+ * $Revision: 1.41 $
+ * $Date: 2000/05/10 09:00:20 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Int outColumn; /* current output column number */
-
-/*---------------------------------------------------------------------------
- * Crude profiling (probably doesn't work)
- *-------------------------------------------------------------------------*/
-
-#ifdef CRUDE_PROFILING
-extern void cp_init ( void );
-extern void cp_enter ( Cell /*StgVar*/ );
-extern void cp_bill_words ( int );
-extern void cp_bill_insns ( int );
-extern void cp_show ( void );
-#endif
-
-
/*---------------------------------------------------------------------------
* For dynamic.c and general object-related stuff
*-------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.69 $
- * $Date: 2000/04/27 16:35:29 $
+ * $Revision: 1.70 $
+ * $Date: 2000/05/10 09:00:20 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
{":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
{":quit", QUIT}, {":set", SET}, {":find", FIND},
{":names", NAMES}, {":info", INFO}, {":project", PROJECT},
- {":dump", DUMP}, {":ztats", STATS},
- {":module",SETMODULE},
+ {":dump", DUMP},
+ {":module", SETMODULE},
{":browse", BROWSE},
#if EXPLAIN_INSTANCE_RESOLUTION
{":xplain", XPLAIN},
Printf(":gc force garbage collection\n");
Printf(":version print Hugs version\n");
Printf(":dump <name> print STG code for named fn\n");
-#ifdef CRUDE_PROFILING
- Printf(":ztats <name> print reduction stats\n");
-#endif
Printf(":quit exit Hugs interpreter\n");
}
break;
case SET : set();
break;
- case STATS:
-#ifdef CRUDE_PROFILING
- cp_show();
-#endif
- break;
case SYSTEM : if (shellEsc(readLine()))
Printf("Warning: Shell escape terminated abnormally\n");
break;
* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.28 $
- * $Date: 2000/05/09 10:00:35 $
+ * $Revision: 1.29 $
+ * $Date: 2000/05/10 09:00:20 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
}
-#if 0
-void asmMarkObject ( AsmObject obj )
-{
- ASSERT(obj->num_unresolved == 0 && obj->closure);
- obj->closure = MarkRoot(obj->closure);
-}
-#endif
-
/* --------------------------------------------------------------------------
* Keeping track of the simulated stack pointer
* ------------------------------------------------------------------------*/
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.51 $
- * $Date: 2000/05/09 10:00:36 $
+ * $Revision: 1.52 $
+ * $Date: 2000/05/10 09:00:20 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
extern int /* Bool */ combined;
-/* --------------------------------------------------------------------------
- * Crude profiling stuff (mainly to assess effect of optimiser)
- * ------------------------------------------------------------------------*/
-
-#ifdef CRUDE_PROFILING
-
-#define M_CPTAB 10000
-#define CP_NIL (-1)
-
-int cpInUse = -1;
-int cpCurr;
-
-typedef
- struct { int /*StgVar*/ who;
- int /*StgVar*/ twho;
- int enters;
- int bytes;
- int insns;
- }
- CPRecord;
-
-CPRecord cpTab[M_CPTAB];
-
-void cp_init ( void )
-{
- int i;
- cpCurr = CP_NIL;
- cpInUse = 0;
- for (i = 0; i < M_CPTAB; i++)
- cpTab[i].who = CP_NIL;
-}
-
-
-
-void cp_enter ( StgBCO* b )
-{
- int is_ret_cont;
- int h;
- int /*StgVar*/ v = b->stgexpr;
- if ((void*)v == NULL) return;
-
- is_ret_cont = 0;
- if (v > 500000000) {
- is_ret_cont = 1;
- v -= 1000000000;
- }
-
- if (v < 0)
- h = (-v) % M_CPTAB; else
- h = v % M_CPTAB;
-
- assert (h >= 0 && h < M_CPTAB);
- while (cpTab[h].who != v && cpTab[h].who != CP_NIL) {
- h++; if (h == M_CPTAB) h = 0;
- };
- cpCurr = h;
- if (cpTab[cpCurr].who == CP_NIL) {
- cpTab[cpCurr].who = v;
- if (!is_ret_cont) cpTab[cpCurr].enters = 1;
- cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0;
- cpInUse++;
- if (cpInUse * 2 > M_CPTAB) {
- fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" );
- assert(0);
- }
- } else {
- if (!is_ret_cont) cpTab[cpCurr].enters++;
- }
-
-
-}
-
-void cp_bill_words ( int nw )
-{
- if (cpCurr == CP_NIL) return;
- cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
-}
-
-
-void cp_bill_insns ( int ni )
-{
- if (cpCurr == CP_NIL) return;
- cpTab[cpCurr].insns += ni;
-}
-
-
-static double percent ( double a, double b )
-{
- return (100.0 * a) / b;
-}
-
-
-void cp_show ( void )
-{
- int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
- char nm[200];
-
- if (cpInUse == -1) return;
-
- fflush(stdout);fflush(stderr);
- printf ( "\n\n" );
-
- totE = totB = totI = 0;
- for (i = 0; i < M_CPTAB; i++) {
- cpTab[i].twho = cpTab[i].who;
- if (cpTab[i].who != CP_NIL) {
- totE += cpTab[i].enters;
- totB += cpTab[i].bytes;
- totI += cpTab[i].insns;
- }
- }
-
- printf ( "Totals: "
- "%6d (%7.3f M) enters, "
- "%6d (%7.3f M) insns, "
- "%6d (%7.3f M) bytes\n\n",
- totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 );
-
- cumE = cumB = cumI = 0;
- for (j = 0; j < 32; j++) {
-
- maxN = max = -1;
- for (i = 0; i < M_CPTAB; i++)
- if (cpTab[i].who != CP_NIL &&
- cpTab[i].enters > maxN) {
- maxN = cpTab[i].enters;
- max = i;
- }
- if (max == -1) break;
-
- cumE += cpTab[max].enters;
- cumB += cpTab[max].bytes;
- cumI += cpTab[max].insns;
-
- strcpy(nm, maybeName(cpTab[max].who));
- if (strcmp(nm, "(unknown)")==0)
- sprintf ( nm, "id%d", -cpTab[max].who);
-
- printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) "
- "%7d bs (%4.1f%%, %4.1f%% c) "
- "%7d is (%4.1f%%, %4.1f%% c)\n",
- nm,
- cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE),
- cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB),
- cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI)
- );
-
- cpTab[max].twho = cpTab[max].who;
- cpTab[max].who = CP_NIL;
- }
-
- for (i = 0; i < M_CPTAB; i++)
- cpTab[i].who = cpTab[i].twho;
-
- printf ( "\n" );
-}
-
-#endif
/* --------------------------------------------------------------------------
RETURN(HeapOverflow);
}
-# if CRUDE_PROFILING
- cp_enter ( bco );
-# endif
-
-
bciPtr = &(bcoInstr(bco,0));
LoopTopLabel
LLL;
);
-# if CRUDE_PROFILING
- SSS; cp_bill_insns(1); LLL;
-# endif
-
Dispatch
Case(i_INTERNAL_ERROR):
static inline StgPtr grabHpUpd( nat size )
{
ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
-#ifdef CRUDE_PROFILING
- cp_bill_words ( size );
-#endif
return allocate(size);
}
static inline StgPtr grabHpNonUpd( nat size )
{
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
-#ifdef CRUDE_PROFILING
- cp_bill_words ( size );
-#endif
return allocate(size);
}
projects / ghc-hetmet.git / commitdiff