Commit 263aaaa5 authored by sof's avatar sof
Browse files

[project @ 1999-05-21 14:46:19 by sof]

Made rts_evalIO() stricter, i.e.,

   rts_evalIO( action );

will now essentially cause `action' to be applied
to the following (imaginary) defn of `evalIO':

    evalIO :: IO a -> IO a
    evalIO action = action >>= \ x -> x `seq` return x

instead of just

    evalIO :: IO a -> IO a
    evalIO action = action >>= \ x -> return x

The old, lazier behaviour is now available via rts_evalLazyIO().
parent 472e4418
/* ----------------------------------------------------------------------------
* $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
*
......@@ -72,7 +72,7 @@ SchedulerStatus
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
*
......@@ -26,7 +26,7 @@ typedef enum {
SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret);
/*
* Creating thraeds
* Creating threads
*/
StgTSO *createThread (nat stack_size);
......@@ -57,6 +57,21 @@ createIOThread(nat stack_size, StgClosure *closure) {
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
*
......@@ -97,6 +97,7 @@ extern DLL_IMPORT_DATA StgClosure END_TSO_QUEUE_closure;
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
*
......@@ -13,12 +13,6 @@
#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.
------------------------------------------------------------------------- */
......@@ -214,8 +208,6 @@ rts_apply (HaskellObj f, HaskellObj arg)
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]);
......@@ -227,8 +219,6 @@ rts_getChar (HaskellObj p)
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 ) {
......@@ -241,8 +231,6 @@ rts_getInt (HaskellObj p)
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 ) {
......@@ -255,8 +243,6 @@ rts_getInt32 (HaskellObj p)
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 ) {
......@@ -269,8 +255,6 @@ rts_getWord (HaskellObj p)
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 ) {
......@@ -283,8 +267,6 @@ rts_getWord32 (HaskellObj p)
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));
......@@ -296,8 +278,6 @@ rts_getFloat (HaskellObj p)
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));
......@@ -309,8 +289,6 @@ rts_getDouble (HaskellObj p)
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]);
......@@ -322,8 +300,6 @@ rts_getStablePtr (HaskellObj p)
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 ) {
......@@ -337,8 +313,6 @@ rts_getAddr (HaskellObj p)
int
rts_getBool (HaskellObj p)
{
CHASE_OUT_INDIRECTIONS(p);
if (p == &True_closure) {
return 1;
} else if (p == &False_closure) {
......@@ -366,15 +340,22 @@ rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
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
*
......@@ -19,6 +19,11 @@
#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.
......@@ -54,7 +59,6 @@ STGFUN(IND_PERM_entry)
{
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)
......@@ -275,8 +279,7 @@ EF_(BCO_entry) {
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_ \
......@@ -421,8 +424,7 @@ NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
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_ \
......@@ -449,6 +451,48 @@ FN_(dummy_ret_entry)
SET_STATIC_HDR(dummy_ret_closure,dummy_ret_info,CCS_DONTZuCARE,,EI_)
};
/* -----------------------------------------------------------------------------
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)
-------------------------------------------------------------------------- */
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment