* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.38 $
- * $Date: 2000/02/08 15:32:29 $
+ * $Revision: 1.39 $
+ * $Date: 2000/02/15 13:16:19 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
Bool multiInstRes = FALSE;
#endif
-#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
-
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: stg.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/12/07 11:14:56 $
+ * $Revision: 1.11 $
+ * $Date: 2000/02/15 13:16:20 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
* Utility functions
* ------------------------------------------------------------------------*/
-void* stgConInfo( StgDiscr d )
+/* Make an info table for a constructor or tuple. */
+void* stgConInfo ( StgDiscr d )
{
+ int tag;
switch (whatIs(d)) {
- case NAME:
+ case NAME: {
+ tag = cfunOf(d);
+ if (tag > 0) tag--;
if (!name(d).itbl)
- name(d).itbl = asmMkInfo(cfunOf(d),name(d).arity);
+ name(d).itbl = asmMkInfo(tag,name(d).arity);
return name(d).itbl;
- case TUPLE:
+ }
+ case TUPLE: {
+ tag = 0;
if (!tycon(d).itbl)
- tycon(d).itbl = asmMkInfo(0,tupleOf(d));
+ tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
return tycon(d).itbl;
+ }
default:
internal("stgConInfo");
}
}
-int stgDiscrTag( StgDiscr d )
+/* Return the tag for a constructor or tuple, starting at zero. */
+int stgDiscrTag ( StgDiscr d )
{
+ int tag;
switch (whatIs(d)) {
- case NAME:
- return cfunOf(d);
- case TUPLE:
- return 0;
- default:
- internal("stgDiscrTag");
+ case NAME: tag = cfunOf(d); break;
+ case TUPLE: tag = 0;
+ default: internal("stgDiscrTag");
}
+ if (tag > 0) tag--;
+ return tag;
}
/* --------------------------------------------------------------------------
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.42 $
- * $Date: 2000/02/08 17:50:46 $
+ * $Revision: 1.43 $
+ * $Date: 2000/02/15 13:16:20 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
}
Bool isPreludeScript() { /* Test whether this is the Prelude*/
- return (scriptHw==0);
+ return (scriptHw < N_PRELUDE_SCRIPTS /*==0*/ );
}
Bool moduleThisScript(m) /* Test if given module is defined */
Module m; { /* in current script file */
- return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw;
+ return scriptHw < 1
+ || m>=scripts[scriptHw-1].moduleHw;
}
Module lastModule() { /* Return module in current script file */
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.25 $
- * $Date: 2000/01/11 15:40:57 $
+ * $Revision: 1.26 $
+ * $Date: 2000/02/15 13:16:20 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
#define isPrelude(m) (m==modulePrelude)
+#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
+
/* --------------------------------------------------------------------------
* Type constructor names:
* ------------------------------------------------------------------------*/
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.32 $
- * $Date: 2000/02/14 11:04:58 $
+ * $Revision: 1.33 $
+ * $Date: 2000/02/15 13:16:20 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
{
int tag = BCO_INSTR_8;
StgWord offset = BCO_INSTR_16;
- if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
+ if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
bciPtr += offset;
}
Continue;
case RET_VEC_SMALL:
case RET_BIG:
case RET_VEC_BIG:
- // barf("todo: RET_[VEC_]{BIG,SMALL}");
+ cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
default:
belch("entered CONSTR with invalid continuation on stack");
IF_DEBUG(evaluator,
/* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.10 2000/02/14 11:01:27 sewardj Exp $
+ * $Id: StgCRun.c,v 1.11 2000/02/15 13:16:20 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
static jmp_buf jmp_environment;
-#if 1
+#if 0
extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg)
{