/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.4 1999/03/02 19:44:15 sof Exp $
+ * $Id: RtsAPI.h,v 1.5 1999/05/21 14:46:20 sof Exp $
*
* (c) The GHC Team, 1998-1999
*
rts_evalIO ( HaskellObj p, /*out*/HaskellObj *ret );
SchedulerStatus
-rts_evalIO_ ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
+rts_evalLazyIO ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
void
rts_checkSchedStatus ( char* site, SchedulerStatus rc);
/* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.2 1998/12/02 13:21:33 simonm Exp $
+ * $Id: SchedAPI.h,v 1.3 1999/05/21 14:46:21 sof Exp $
*
* (c) The GHC Team 1998
*
SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret);
/*
- * Creating thraeds
+ * Creating threads
*/
StgTSO *createThread (nat stack_size);
return t;
}
+/*
+ * Same as above, but also evaluate the result of the IO action
+ * to whnf while we're at it.
+ */
+
+static inline StgTSO *
+createStrictIOThread(nat stack_size, StgClosure *closure) {
+ StgTSO *t;
+ t = createThread(stack_size);
+ pushClosure(t,closure);
+ pushClosure(t,&forceIO_closure);
+ return t;
+}
+
+
/*
* Killing threads
*/
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.12 1999/05/11 16:47:41 keithw Exp $
+ * $Id: StgMiscClosures.h,v 1.13 1999/05/21 14:46:21 sof Exp $
*
* (c) The GHC Team, 1998-1999
*
extern DLL_IMPORT_DATA StgClosure END_MUT_LIST_closure;
extern DLL_IMPORT_DATA StgClosure NO_FINALIZER_closure;
extern DLL_IMPORT_DATA StgClosure dummy_ret_closure;
+extern DLL_IMPORT_DATA StgClosure forceIO_closure;
extern DLL_IMPORT_DATA StgIntCharlikeClosure CHARLIKE_closure[];
extern DLL_IMPORT_DATA StgIntCharlikeClosure INTLIKE_closure[];
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.6 1999/05/04 10:19:18 sof Exp $
+ * $Id: RtsAPI.c,v 1.7 1999/05/21 14:46:19 sof Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "RtsFlags.h"
#include "RtsUtils.h"
-/* This is a temporary fudge until the scheduler guarantees
- that the result returned from an evalIO() is fully evaluated.
-*/
-#define CHASE_OUT_INDIRECTIONS(p) \
- while ((p)->header.info == &IND_info || (p)->header.info == &IND_STATIC_info || (p)->header.info == &IND_OLDGEN_info || (p)->header.info == &IND_PERM_info || (p)->header.info == &IND_OLDGEN_PERM_info) { p=((StgInd*)p)->indirectee; }
-
/* ----------------------------------------------------------------------------
Building Haskell objects from C datatypes.
------------------------------------------------------------------------- */
char
rts_getChar (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( p->header.info == (const StgInfoTable*)&Czh_con_info ||
p->header.info == (const StgInfoTable*)&Czh_static_info) {
return (char)(StgWord)(p->payload[0]);
int
rts_getInt (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( 1 ||
p->header.info == (const StgInfoTable*)&Izh_con_info ||
p->header.info == (const StgInfoTable*)&Izh_static_info ) {
int
rts_getInt32 (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( 1 ||
p->header.info == (const StgInfoTable*)&Izh_con_info ||
p->header.info == (const StgInfoTable*)&Izh_static_info ) {
unsigned int
rts_getWord (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( 1 || /* see above comment */
p->header.info == (const StgInfoTable*)&Wzh_con_info ||
p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
unsigned int
rts_getWord32 (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( 1 || /* see above comment */
p->header.info == (const StgInfoTable*)&Wzh_con_info ||
p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
float
rts_getFloat (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( p->header.info == (const StgInfoTable*)&Fzh_con_info ||
p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
return (float)(PK_FLT((P_)p->payload));
double
rts_getDouble (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( p->header.info == (const StgInfoTable*)&Dzh_con_info ||
p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
return (double)(PK_DBL((P_)p->payload));
StgStablePtr
rts_getStablePtr (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info ||
p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
return (StgStablePtr)(p->payload[0]);
void *
rts_getAddr (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if ( p->header.info == (const StgInfoTable*)&Azh_con_info ||
p->header.info == (const StgInfoTable*)&Azh_static_info ) {
int
rts_getBool (HaskellObj p)
{
- CHASE_OUT_INDIRECTIONS(p);
-
if (p == &True_closure) {
return 1;
} else if (p == &False_closure) {
return schedule(tso, ret);
}
+/*
+ * rts_evalIO() evaluates a value of the form (IO a), forcing the action's
+ * result to WHNF before returning.
+ */
SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
{
- StgTSO *tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
+ StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
return schedule(tso, ret);
}
+/*
+ * Like rts_evalIO(), but doesn't force the action's result.
+ */
SchedulerStatus
-rts_evalIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
+rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
{
StgTSO *tso = createIOThread(stack_size, p);
return schedule(tso, ret);
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.23 1999/05/13 17:31:12 simonm Exp $
+ * $Id: StgMiscClosures.hc,v 1.24 1999/05/21 14:46:19 sof Exp $
*
* (c) The GHC Team, 1998-1999
*
#include <stdio.h>
#endif
+/* ToDo: make the printing of panics more Win32-friendly, i.e.,
+ * pop up some lovely message boxes (as well).
+ */
+#define DUMP_ERRMSG(msg) STGCALL1(fflush,stdout); STGCALL2(fprintf,stderr,msg)
+
/* -----------------------------------------------------------------------------
Entry code for an indirection.
{
FB_
/* Don't add INDs to granularity cost */
-
/* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */
#if defined(TICKY_TICKY) && !defined(PROFILING)
STGFUN(type##_entry) \
{ \
FB_ \
- STGCALL1(fflush,stdout); \
- STGCALL2(fprintf,stderr,#type " object entered!\n"); \
+ DUMP_ERRMSG(#type " object entered!\n"); \
STGCALL1(raiseError, errorHandler); \
stg_exit(EXIT_FAILURE); /* not executed */ \
FE_ \
STGFUN(stg_error_entry) \
{ \
FB_ \
- STGCALL1(fflush,stdout); \
- STGCALL2(fprintf,stderr,"fatal: stg_error_entry"); \
+ DUMP_ERRMSG("fatal: stg_error_entry"); \
STGCALL1(raiseError, errorHandler); \
exit(EXIT_FAILURE); /* not executed */ \
FE_ \
};
/* -----------------------------------------------------------------------------
+ Strict IO application - performing an IO action and entering its result.
+
+ rts_evalIO() lets you perform Haskell IO actions from outside of Haskell-land,
+ returning back to you their result. Want this result to be evaluated to WHNF
+ by that time, so that we can easily get at the int/char/whatever using the
+ various get{Ty} functions provided by the RTS API.
+
+ forceIO takes care of this, performing the IO action and entering the
+ results that comes back.
+
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE_SRT_BITMAP(forceIO_ret_info,forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0);
+FN_(forceIO_ret_entry)
+{
+ FB_
+ Sp++;
+ Sp -= sizeofW(StgSeqFrame);
+ PUSH_SEQ_FRAME(Sp);
+ JMP_(GET_ENTRY(R1.cl));
+}
+
+
+INFO_TABLE(forceIO_info,forceIO_entry,1,0,FUN,,EF_,0,0);
+FN_(forceIO_entry)
+{
+ FB_
+ /* Sp[0] contains the IO action we want to perform */
+ R1.p = (P_)Sp[0];
+ /* Replace it with the return continuation that enters the result. */
+ Sp[0] = (W_)&forceIO_ret_info;
+ Sp--;
+ /* Push the RealWorld# tag and enter */
+ Sp[0] =(W_)REALWORLD_TAG;
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+SET_STATIC_HDR(forceIO_closure,forceIO_info,CCS_DONTZuCARE,,EI_)
+};
+
+
+/* -----------------------------------------------------------------------------
Standard Infotables (for use in interpreter)
-------------------------------------------------------------------------- */