X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fruntime%2Fmain%2FStgThreads.lhc;h=ffd0286eb3ef1c3375d30737ea55fa1ade7e3f61;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=c75eaaf44295e2a49c8f390296c865f81f644efb;hpb=769ce8e72ae626356ce57162b7ff448c0ef7e700;p=ghc-hetmet.git

diff --git a/ghc/runtime/main/StgThreads.lhc b/ghc/runtime/main/StgThreads.lhc
index c75eaaf..ffd0286 100644
--- a/ghc/runtime/main/StgThreads.lhc
+++ b/ghc/runtime/main/StgThreads.lhc
@@ -161,7 +161,11 @@ STGFUN(RBH_entry)
     STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);	
 #  endif
 
-    switch (INFO_TYPE(InfoPtr)) {
+    /* In GranSim and GUM on 2.04 the InfoPtr seems to be invalid when entering
+       this routine (exact reason is unknown). This change does the safe 
+       thing instead. -- HWL */
+
+    switch (INFO_TYPE(INFO_PTR(Node))) {  /* HWL orig: INFO_TYPE(InfoPtr) */
     case INFO_SPEC_RBH_TYPE:
 	TSO_LINK(CurrentTSO) = (P_) SPEC_RBH_BQ(Node);
 	SPEC_RBH_BQ(Node) = (W_) CurrentTSO;
@@ -356,7 +360,7 @@ DO_RETURN_TEMPLATE(UnderflowVect7, ((P_)RetReg)[RVREL(7)])
 
 DO_RETURN_TEMPLATE(StackUnderflowEnterNode, EnterNodeCode)
 
-#else
+#else /* PAR */
 
 \end{code}
 
@@ -436,6 +440,9 @@ STGFUN(PrimUnderflow)
  * because R2 is dead, and R1 points to a PAP.  Only R1 is live.
  */
 
+#if 0
+
+/* old version of the code */
 STGFUN(StackUnderflowEnterNode)
 {
     FB_
@@ -445,8 +452,50 @@ STGFUN(StackUnderflowEnterNode)
     FE_
 }
 
+#else
+
+/*
+   We've inlined CommonUnderFlow because setting RetReg would zap
+   the return vector that the node needs.
+   We pick up the RetReg from the STkO header instead.
+   KH/HWL 14/2/97
+*/
+
+STGFUN(StackUnderflowEnterNode)
+{
+    P_ temp;
+    FB_
+    RetReg = STKO_RETURN(StkOReg); /* pick up return code from the StkO hdr
+                                      needed because we come from UpdatePAP */
+    LivenessReg = LIVENESS_R1;
+
+    temp = STKO_LINK(StkOReg);
+
+    /*? fprintf(stderr,"Stk Underflow from: %lx to: %lx size abandoned: %d\n",StkOReg,temp,STKO_CLOSURE_CTS_SIZE(StkOReg)); ?*/
+
+    /* change the guy we are abandoning into something
+       that will not be "interesting" on the mutables
+       list.  (As long as it is there, it will be
+       scavenged in GC, and we cannot guarantee that
+       it is still a "sane" StkO object).  (And, besides,
+       why continue to keep it [and all it pts to] alive?)
+       Will & Phil 95/10
+    */
+    FREEZE_MUT_HDR(StkOReg, ImMutArrayOfPtrs_info);
+    MUTUPLE_CLOSURE_SIZE(StkOReg) = MUTUPLE_VHS;
+
+    StkOReg = temp;
+    /* ToDo: Fetch the remote stack object here! */
+    RestoreStackStgRegs();
+    JMP_(EnterNodeCode);  /* this will enter a PAP containing the old stkos
+			     A and B stacks */
+    FE_
+}
 #endif
 
+
+#endif /* !PAR */
+
 const W_
 vtbl_Underflow[] = {
     /* "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
@@ -460,38 +509,5 @@ vtbl_Underflow[] = {
     (W_) UnderflowVect7
 };
 
-\end{code}
-
-\begin{code}
-
-IFN_(seqDirectReturn) {
-    void *cont;
-
-    FB_
-    RetReg = (StgRetAddr) SpB[BREL(0)];
-    cont = (void *) SpB[BREL(1)];
-    /* SpB += BREL(2); */
-    JMP_(cont);
-    FE_
-}
-
-/*
-   NB: For direct returns to work properly, the name of the routine must be
-   the same as the name of the vector table with vtbl_ removed and DirectReturn
-   appended.  This is all the mangler understands.
- */
-
-const W_
-vtbl_seq[] = {
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn,
-    (W_) seqDirectReturn
-};
-
 #endif /* CONCURRENT */
 \end{code}