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 * (c) The GHC Team, 1998-1999
* *
...@@ -72,7 +72,7 @@ SchedulerStatus ...@@ -72,7 +72,7 @@ SchedulerStatus
rts_evalIO ( HaskellObj p, /*out*/HaskellObj *ret ); rts_evalIO ( HaskellObj p, /*out*/HaskellObj *ret );
SchedulerStatus SchedulerStatus
rts_evalIO_ ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret ); rts_evalLazyIO ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
void void
rts_checkSchedStatus ( char* site, SchedulerStatus rc); 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 * (c) The GHC Team 1998
* *
...@@ -26,7 +26,7 @@ typedef enum { ...@@ -26,7 +26,7 @@ typedef enum {
SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret); SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret);
/* /*
* Creating thraeds * Creating threads
*/ */
StgTSO *createThread (nat stack_size); StgTSO *createThread (nat stack_size);
...@@ -57,6 +57,21 @@ createIOThread(nat stack_size, StgClosure *closure) { ...@@ -57,6 +57,21 @@ createIOThread(nat stack_size, StgClosure *closure) {
return t; 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 * 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 * (c) The GHC Team, 1998-1999
* *
...@@ -97,6 +97,7 @@ extern DLL_IMPORT_DATA StgClosure END_TSO_QUEUE_closure; ...@@ -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 END_MUT_LIST_closure;
extern DLL_IMPORT_DATA StgClosure NO_FINALIZER_closure; extern DLL_IMPORT_DATA StgClosure NO_FINALIZER_closure;
extern DLL_IMPORT_DATA StgClosure dummy_ret_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 CHARLIKE_closure[];
extern DLL_IMPORT_DATA StgIntCharlikeClosure INTLIKE_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 * (c) The GHC Team, 1998-1999
* *
...@@ -13,12 +13,6 @@ ...@@ -13,12 +13,6 @@
#include "RtsFlags.h" #include "RtsFlags.h"
#include "RtsUtils.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. Building Haskell objects from C datatypes.
------------------------------------------------------------------------- */ ------------------------------------------------------------------------- */
...@@ -214,8 +208,6 @@ rts_apply (HaskellObj f, HaskellObj arg) ...@@ -214,8 +208,6 @@ rts_apply (HaskellObj f, HaskellObj arg)
char char
rts_getChar (HaskellObj p) rts_getChar (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( p->header.info == (const StgInfoTable*)&Czh_con_info || if ( p->header.info == (const StgInfoTable*)&Czh_con_info ||
p->header.info == (const StgInfoTable*)&Czh_static_info) { p->header.info == (const StgInfoTable*)&Czh_static_info) {
return (char)(StgWord)(p->payload[0]); return (char)(StgWord)(p->payload[0]);
...@@ -227,8 +219,6 @@ rts_getChar (HaskellObj p) ...@@ -227,8 +219,6 @@ rts_getChar (HaskellObj p)
int int
rts_getInt (HaskellObj p) rts_getInt (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( 1 || if ( 1 ||
p->header.info == (const StgInfoTable*)&Izh_con_info || p->header.info == (const StgInfoTable*)&Izh_con_info ||
p->header.info == (const StgInfoTable*)&Izh_static_info ) { p->header.info == (const StgInfoTable*)&Izh_static_info ) {
...@@ -241,8 +231,6 @@ rts_getInt (HaskellObj p) ...@@ -241,8 +231,6 @@ rts_getInt (HaskellObj p)
int int
rts_getInt32 (HaskellObj p) rts_getInt32 (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( 1 || if ( 1 ||
p->header.info == (const StgInfoTable*)&Izh_con_info || p->header.info == (const StgInfoTable*)&Izh_con_info ||
p->header.info == (const StgInfoTable*)&Izh_static_info ) { p->header.info == (const StgInfoTable*)&Izh_static_info ) {
...@@ -255,8 +243,6 @@ rts_getInt32 (HaskellObj p) ...@@ -255,8 +243,6 @@ rts_getInt32 (HaskellObj p)
unsigned int unsigned int
rts_getWord (HaskellObj p) rts_getWord (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( 1 || /* see above comment */ if ( 1 || /* see above comment */
p->header.info == (const StgInfoTable*)&Wzh_con_info || p->header.info == (const StgInfoTable*)&Wzh_con_info ||
p->header.info == (const StgInfoTable*)&Wzh_static_info ) { p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
...@@ -269,8 +255,6 @@ rts_getWord (HaskellObj p) ...@@ -269,8 +255,6 @@ rts_getWord (HaskellObj p)
unsigned int unsigned int
rts_getWord32 (HaskellObj p) rts_getWord32 (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( 1 || /* see above comment */ if ( 1 || /* see above comment */
p->header.info == (const StgInfoTable*)&Wzh_con_info || p->header.info == (const StgInfoTable*)&Wzh_con_info ||
p->header.info == (const StgInfoTable*)&Wzh_static_info ) { p->header.info == (const StgInfoTable*)&Wzh_static_info ) {
...@@ -283,8 +267,6 @@ rts_getWord32 (HaskellObj p) ...@@ -283,8 +267,6 @@ rts_getWord32 (HaskellObj p)
float float
rts_getFloat (HaskellObj p) rts_getFloat (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( p->header.info == (const StgInfoTable*)&Fzh_con_info || if ( p->header.info == (const StgInfoTable*)&Fzh_con_info ||
p->header.info == (const StgInfoTable*)&Fzh_static_info ) { p->header.info == (const StgInfoTable*)&Fzh_static_info ) {
return (float)(PK_FLT((P_)p->payload)); return (float)(PK_FLT((P_)p->payload));
...@@ -296,8 +278,6 @@ rts_getFloat (HaskellObj p) ...@@ -296,8 +278,6 @@ rts_getFloat (HaskellObj p)
double double
rts_getDouble (HaskellObj p) rts_getDouble (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( p->header.info == (const StgInfoTable*)&Dzh_con_info || if ( p->header.info == (const StgInfoTable*)&Dzh_con_info ||
p->header.info == (const StgInfoTable*)&Dzh_static_info ) { p->header.info == (const StgInfoTable*)&Dzh_static_info ) {
return (double)(PK_DBL((P_)p->payload)); return (double)(PK_DBL((P_)p->payload));
...@@ -309,8 +289,6 @@ rts_getDouble (HaskellObj p) ...@@ -309,8 +289,6 @@ rts_getDouble (HaskellObj p)
StgStablePtr StgStablePtr
rts_getStablePtr (HaskellObj p) rts_getStablePtr (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info || if ( p->header.info == (const StgInfoTable*)&StablePtr_con_info ||
p->header.info == (const StgInfoTable*)&StablePtr_static_info ) { p->header.info == (const StgInfoTable*)&StablePtr_static_info ) {
return (StgStablePtr)(p->payload[0]); return (StgStablePtr)(p->payload[0]);
...@@ -322,8 +300,6 @@ rts_getStablePtr (HaskellObj p) ...@@ -322,8 +300,6 @@ rts_getStablePtr (HaskellObj p)
void * void *
rts_getAddr (HaskellObj p) rts_getAddr (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if ( p->header.info == (const StgInfoTable*)&Azh_con_info || if ( p->header.info == (const StgInfoTable*)&Azh_con_info ||
p->header.info == (const StgInfoTable*)&Azh_static_info ) { p->header.info == (const StgInfoTable*)&Azh_static_info ) {
...@@ -337,8 +313,6 @@ rts_getAddr (HaskellObj p) ...@@ -337,8 +313,6 @@ rts_getAddr (HaskellObj p)
int int
rts_getBool (HaskellObj p) rts_getBool (HaskellObj p)
{ {
CHASE_OUT_INDIRECTIONS(p);
if (p == &True_closure) { if (p == &True_closure) {
return 1; return 1;
} else if (p == &False_closure) { } else if (p == &False_closure) {
...@@ -366,15 +340,22 @@ rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret) ...@@ -366,15 +340,22 @@ rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
return schedule(tso, 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 SchedulerStatus
rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret) 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); return schedule(tso, ret);
} }
/*
* Like rts_evalIO(), but doesn't force the action's result.
*/
SchedulerStatus 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); StgTSO *tso = createIOThread(stack_size, p);
return schedule(tso, ret); 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 * (c) The GHC Team, 1998-1999
* *
...@@ -19,6 +19,11 @@ ...@@ -19,6 +19,11 @@
#include <stdio.h> #include <stdio.h>
#endif #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. Entry code for an indirection.
...@@ -54,7 +59,6 @@ STGFUN(IND_PERM_entry) ...@@ -54,7 +59,6 @@ STGFUN(IND_PERM_entry)
{ {
FB_ FB_
/* Don't add INDs to granularity cost */ /* Don't add INDs to granularity cost */
/* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */ /* Dont: TICK_ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */
#if defined(TICKY_TICKY) && !defined(PROFILING) #if defined(TICKY_TICKY) && !defined(PROFILING)
...@@ -275,8 +279,7 @@ EF_(BCO_entry) { ...@@ -275,8 +279,7 @@ EF_(BCO_entry) {
STGFUN(type##_entry) \ STGFUN(type##_entry) \
{ \ { \
FB_ \ FB_ \
STGCALL1(fflush,stdout); \ DUMP_ERRMSG(#type " object entered!\n"); \
STGCALL2(fprintf,stderr,#type " object entered!\n"); \
STGCALL1(raiseError, errorHandler); \ STGCALL1(raiseError, errorHandler); \
stg_exit(EXIT_FAILURE); /* not executed */ \ stg_exit(EXIT_FAILURE); /* not executed */ \
FE_ \ FE_ \
...@@ -421,8 +424,7 @@ NON_ENTERABLE_ENTRY_CODE(MUT_VAR); ...@@ -421,8 +424,7 @@ NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
STGFUN(stg_error_entry) \ STGFUN(stg_error_entry) \
{ \ { \
FB_ \ FB_ \
STGCALL1(fflush,stdout); \ DUMP_ERRMSG("fatal: stg_error_entry"); \
STGCALL2(fprintf,stderr,"fatal: stg_error_entry"); \
STGCALL1(raiseError, errorHandler); \ STGCALL1(raiseError, errorHandler); \
exit(EXIT_FAILURE); /* not executed */ \ exit(EXIT_FAILURE); /* not executed */ \
FE_ \ FE_ \
...@@ -449,6 +451,48 @@ FN_(dummy_ret_entry) ...@@ -449,6 +451,48 @@ FN_(dummy_ret_entry)
SET_STATIC_HDR(dummy_ret_closure,dummy_ret_info,CCS_DONTZuCARE,,EI_) 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) 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