/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.2 1998/12/02 13:29:00 simonm Exp $
+ * $Id: Updates.hc,v 1.11 1999/03/22 11:26:03 simonm Exp $
+ *
+ * (c) The GHC Team, 1998-1999
*
* Code to perform updates.
*
#include "Rts.h"
#include "RtsUtils.h"
#include "HeapStackCheck.h"
+#include "Storage.h"
/*
The update frame return address must be *polymorphic*, that means
TICK_UPD_EXISTING(); \
\
updatee = ((StgUpdateFrame *)Sp)->updatee; \
- \
+ \
/* update the updatee with an indirection to the return value */\
UPD_IND(updatee,R1.p); \
\
UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_6_entry,RET_VEC(Sp[0],6));
UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_7_entry,RET_VEC(Sp[0],7));
-
/*
Make sure this table is big enough to handle the maximum vectored
return size!
/*
* Check for stack overflow.
*/
- STK_CHK(Words,PAP_entry,R2.p,1,);
+ STK_CHK_NP(Words,1,);
Sp -= Words;
TICK_ENT_PAP(pap);
JMP_(stg_gc_entertop);
}
- TICK_ALLOC_UPD_PAP(DYN_HS, NArgWords, 0, PapSize);
+ TICK_ALLOC_UPD_PAP(1/*fun*/ + Words, 0);
#ifdef PROFILING
CCS_ALLOC(CCS_pap, PapSize);
#endif
-
+
PapClosure = (StgPAP *)(Hp + 1 - PapSize); /* The new PapClosure */
SET_HDR(PapClosure,&PAP_info,CCS_pap);
case SEQ_FRAME:
/* Set Sp to just above the SEQ frame (should be an activation rec.)*/
- Sp = stgCast(StgPtr,Su) + sizeofW(StgSeqFrame);
+ Sp = (P_)Su + sizeofW(StgSeqFrame);
/* restore Su */
- Su = stgCast(StgSeqFrame*,Su)->link;
+ Su = ((StgSeqFrame *)Su)->link;
/* return to the activation record, with the address of the PAP in R1 */
R1.p = (P_)PapClosure;
case CATCH_FRAME:
/* Set Sp to just above the CATCH frame (should be an activation rec.)*/
- Sp = stgCast(StgPtr,Su) + sizeofW(StgCatchFrame);
+ Sp = (P_)Su + sizeofW(StgCatchFrame);
/* restore Su */
- Su = stgCast(StgCatchFrame*,Su)->link;
+ Su = ((StgCatchFrame *)Su)->link;
/* restart by entering the PAP */
R1.p = (P_)PapClosure;
* either the new PAP or Node.
*/
- Updatee = Su->updatee;
- UPD_IND(Updatee,PapClosure);
-
+ Updatee = Su->updatee;
+
+#if defined(PROFILING)
if (Words != 0) {
- TICK_UPD_PAP_IN_NEW(NArgWords);
-
+ UPD_IND(Updatee,PapClosure);
+ TICK_UPD_PAP_IN_NEW(Words+1);
} else {
- TICK_UPD_PAP_IN_PLACE();
-
-#if defined(PROFILING)
- /*
- * Lexical scoping requires a *permanent* indirection, and we
+ /* Lexical scoping requires a *permanent* indirection, and we
* also have to set the cost centre for the indirection.
*/
- SET_INFO(Updatee, &IND_PERM_info);
+ UPD_PERM_IND(Updatee,PapClosure);
+ TICK_UPD_PAP_IN_PLACE();
Updatee->header.prof.ccs = CCS_pap;
-#endif /* PROFILING */
}
-
+#else
+ UPD_IND(Updatee,PapClosure);
+ if (Words != 0) {
+ TICK_UPD_PAP_IN_NEW(Words+1);
+ } else {
+ TICK_UPD_PAP_IN_PLACE();
+ }
+#endif
+
#if defined(PROFILING)
/*
* Restore the Cost Centre too (if required); again see Sansom
PUSH_UPD_FRAME(R1.p, 0);
Sp -= sizeofW(StgUpdateFrame) + Words;
- TICK_ENT_PAP(ap); /* ToDo: TICK_ENT_AP_UPD */
+ TICK_ENT_AP_UPD(ap);
/* Enter PAP cost centre -- lexical scoping only */
ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_UPD_CL */
IFN_(label) \
{ \
FB_ \
- Su = stgCast(StgSeqFrame*,Sp)->link; \
+ Su = ((StgSeqFrame *)Sp)->link; \
Sp += sizeofW(StgSeqFrame); \
JMP_(ret); \
FE_ \
Exception Primitives
-------------------------------------------------------------------------- */
-FN_(catchZh_fast);
-FN_(raiseZh_fast);
+FN_(catchzh_fast);
+FN_(raisezh_fast);
#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
FN_(label); \
FB_
R2.cl = payloadCPtr(R1.cl,1); /* h */
R1.cl = payloadCPtr(R1.cl,0); /* x */
- JMP_(catchZh_fast);
+ JMP_(catchzh_fast);
FE_
}
-FN_(catchZh_fast)
+FN_(catchzh_fast)
{
StgCatchFrame *fp;
FB_
/* args: R1 = m, R2 = k */
- STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchZh_fast, );
+ STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchzh_fast, );
Sp -= sizeofW(StgCatchFrame);
- fp = stgCast(StgCatchFrame*,Sp);
+ fp = (StgCatchFrame *)Sp;
SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS);
fp -> handler = R2.cl;
fp -> link = Su;
- Su = stgCast(StgUpdateFrame*,fp);
+ Su = (StgUpdateFrame *)fp;
+ TICK_CATCHF_PUSHED();
TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
*
* raise = {err} \n {} -> raise#{err}
*
- * It is used in raiseZh_fast to update thunks on the update list
+ * It is used in raisezh_fast to update thunks on the update list
* -------------------------------------------------------------------------- */
INFO_TABLE(raise_info,raise_entry,1,0,FUN,const,EF_,0,0);
STGFUN(raise_entry)
{
FB_
- R1.cl = payloadCPtr(R1.cl,0);
- JMP_(raiseZh_fast);
+ R1.cl = R1.cl->payload[0];
+ JMP_(raisezh_fast);
FE_
}
-FN_(raiseZh_fast)
+FN_(raisezh_fast)
{
StgClosure *handler;
StgUpdateFrame *p;
+ StgClosure *raise_closure;
FB_
/* args : R1 = error */
p = Su;
+ /* This closure represents the expression 'raise# E' where E
+ * is the exception raise. It is used to overwrite all the
+ * thunks which are currently under evaluataion.
+ */
+ raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
+ sizeofW(StgClosure)+1);
+ raise_closure->header.info = &raise_info;
+ raise_closure->payload[0] = R1.cl;
+
while (1) {
switch (get_itbl(p)->type) {
case UPDATE_FRAME:
- UPD_INPLACE1(p->updatee,&raise_info,R1.cl);
+ UPD_IND(p->updatee,raise_closure);
p = p->link;
continue;
case SEQ_FRAME:
- p = stgCast(StgSeqFrame*,p)->link;
+ p = ((StgSeqFrame *)p)->link;
continue;
case CATCH_FRAME:
break;
case STOP_FRAME:
- barf("raiseZh_fast: STOP_FRAME");
+ barf("uncaught exception");
default:
- barf("raiseZh_fast: weird activation record");
+ barf("raisezh_fast: weird activation record");
}
break;
Su = ((StgCatchFrame *)p)->link;
handler = ((StgCatchFrame *)p)->handler;
- Sp = stgCast(StgPtr,p) + sizeofW(StgCatchFrame) - 1;
+ Sp = (P_)p + sizeofW(StgCatchFrame) - 1;
*Sp = R1.w;
TICK_ENT_VIA_NODE();
projects / ghc-hetmet.git / blobdiff