X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FRtsAPI.c;h=fb4df6ced2fda128dbdd8470e133c8e36d231e47;hb=a71cef4b2055d1e8f0f72405f5df17ad49e89098;hp=0a486576129f2bb8d5fb1b699480c136347917dc;hpb=50a70f642ca958cbb2dec99b0b0ae67120c9ffa9;p=ghc-hetmet.git

diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c
index 0a48657..fb4df6c 100644
--- 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.10 1999/11/02 15:05:59 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -10,15 +10,10 @@
 #include "Rts.h"
 #include "Storage.h"
 #include "RtsAPI.h"
+#include "SchedAPI.h"
 #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.
    ------------------------------------------------------------------------- */
@@ -194,6 +189,7 @@ rts_mkString (char *s)
 {
   return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
 }
+#endif /* COMPILER */
 
 HaskellObj
 rts_apply (HaskellObj f, HaskellObj arg)
@@ -205,7 +201,6 @@ rts_apply (HaskellObj f, HaskellObj arg)
   ap->payload[0] = (P_)arg;
   return (StgClosure *)ap;
 }
-#endif /* COMPILER */
 
 /* ----------------------------------------------------------------------------
    Deconstructing Haskell objects
@@ -214,8 +209,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 +220,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 +232,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 +244,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 +256,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 +268,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 +279,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 +290,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 +301,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 +314,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) {
@@ -356,28 +331,39 @@ SchedulerStatus
 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 {
   StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
-  return schedule(tso, ret);
+  scheduleThread(tso);
+  return waitThread(tso, ret);
 }
 
 SchedulerStatus
 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 {
   StgTSO *tso = createGenThread(stack_size, p);
-  return schedule(tso, ret);
+  scheduleThread(tso);
+  return waitThread(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);
-  return schedule(tso, ret);
+  StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
+  scheduleThread(tso);
+  return waitThread(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);
+  scheduleThread(tso);
+  return waitThread(tso, ret);
 }
 
 /* Convenience function for decoding the returned status. */