[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().

diff --git a/ghc/includes/RtsAPI.h b/ghc/includes/RtsAPI.h
index c9c24f9..bbea2cb 100644 (file)
--- a/ghc/includes/RtsAPI.h
+++ b/ghc/includes/RtsAPI.h
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $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);

diff --git a/ghc/includes/SchedAPI.h b/ghc/includes/SchedAPI.h
index 2774527..26dac54 100644 (file)
--- a/ghc/includes/SchedAPI.h
+++ b/ghc/includes/SchedAPI.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $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
  */

diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h
index aad9895..94bf651 100644 (file)
--- a/ghc/includes/StgMiscClosures.h
+++ b/ghc/includes/StgMiscClosures.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $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[];

diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c
index 0a48657..5f8648b 100644 (file)
--- a/ghc/rts/RtsAPI.c
+++ b/ghc/rts/RtsAPI.c
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $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);

diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc
index e371799..2c98ac0 100644 (file)
--- a/ghc/rts/StgMiscClosures.hc
+++ b/ghc/rts/StgMiscClosures.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $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_                                                                  \
@@ -450,6 +452,48 @@ 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)
    -------------------------------------------------------------------------- */