Backend interop fixes:
-- Make Hugs use the same constructor tag numbering as GHC, viz, starting
at zero.
-- Evaluator.c: when unwinding the stack on entering a constructor,
return to the scheduler if a RET_{VEC_}{SMALL|BIG} is found on the
stack.
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* 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>
* ------------------------------------------------------------------------*/
#include <setjmp.h>
Bool multiInstRes = FALSE;
#endif
Bool multiInstRes = FALSE;
#endif
-#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
-
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: stg.c,v $
* 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"
* ------------------------------------------------------------------------*/
#include "prelude.h"
* Utility functions
* ------------------------------------------------------------------------*/
* Utility functions
* ------------------------------------------------------------------------*/
-void* stgConInfo( StgDiscr d )
+/* Make an info table for a constructor or tuple. */
+void* stgConInfo ( StgDiscr d )
+ case NAME: {
+ tag = cfunOf(d);
+ if (tag > 0) tag--;
- name(d).itbl = asmMkInfo(cfunOf(d),name(d).arity);
+ name(d).itbl = asmMkInfo(tag,name(d).arity);
+ }
+ case TUPLE: {
+ tag = 0;
- tycon(d).itbl = asmMkInfo(0,tupleOf(d));
+ tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
default:
internal("stgConInfo");
}
}
default:
internal("stgConInfo");
}
}
-int stgDiscrTag( StgDiscr d )
+/* Return the tag for a constructor or tuple, starting at zero. */
+int stgDiscrTag ( StgDiscr 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 $
* 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"
* ------------------------------------------------------------------------*/
#include "prelude.h"
}
Bool isPreludeScript() { /* Test whether this is the Prelude*/
}
Bool isPreludeScript() { /* Test whether this is the Prelude*/
+ return (scriptHw < N_PRELUDE_SCRIPTS /*==0*/ );
}
Bool moduleThisScript(m) /* Test if given module is defined */
Module m; { /* in current script file */
}
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 */
}
Module lastModule() { /* Return module in current script file */
* included in the distribution.
*
* $RCSfile: storage.h,v $
* 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 isPrelude(m) (m==modulePrelude)
+#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
+
/* --------------------------------------------------------------------------
* Type constructor names:
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* Type constructor names:
* ------------------------------------------------------------------------*/
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
* 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"
* ---------------------------------------------------------------------------*/
#include "Rts.h"
{
int tag = BCO_INSTR_8;
StgWord offset = BCO_INSTR_16;
{
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;
bciPtr += offset;
}
Continue;
case RET_VEC_SMALL:
case RET_BIG:
case RET_VEC_BIG:
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,
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
*
*
* (c) The GHC Team, 1998-1999
*
static jmp_buf jmp_environment;
static jmp_buf jmp_environment;
extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg)
{
extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg)
{