%************************************************************************
%*									*
\section[update-code]{Code required for update abstraction}
%*									*
%************************************************************************

This code is required by the update interface which sits on top of the
storage manager interface (See \tr{SMupdate.lh}).

Some of this stuff has been separated (correctly!) into StgThreads.lhc
for version 0.23.  Could someone (Hans?) bring us up to date, please!
KH.

\begin{itemize}
\item Indirection entry code and info table.
\item Black Hole entry code and info table.
\item Update frame code and return vectors.
\item PAP update code.
\item PAP entry code and info table.
\end{itemize}

System-wide constants need to be included:
\begin{code}
#define MAIN_REG_MAP	    /* STG world */

#include "rtsdefs.h"
#include "SMupdate.h"
#if 0
#ifdef PAR
# include "Statistics.h"
#endif
#endif

EXTDATA(Nil_closure);

#if defined(DO_REDN_COUNTING)
extern void PrintRednCountInfo(STG_NO_ARGS);
extern I_   showRednCountStats;
#endif
\end{code}

%************************************************************************
%*									*
\subsection[indirection-code]{Indirection code}
%*									*
%************************************************************************

The entry code for indirections and the indirection info-table.
\begin{code}
STGFUN(Ind_entry)
{
    FB_
    ENT_IND(Node);	/* Ticky-ticky profiling info */
    SET_ACTIVITY(ACT_INDIRECT); /* SPAT profiling */

    Node = (P_) IND_CLOSURE_PTR((P_) Node);
    ENT_VIA_NODE();
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FE_
}

IND_ITBL(Ind_info,Ind_entry,const,EF_);

\end{code}

We also need a special @CAF@ indirection info table which is used to
indirect @CAF@s to evaluated results in the heap.
\begin{code}
STGFUN(Caf_entry)	/* same as Ind_entry */
{
    FB_
    ENT_IND(Node);
    SET_ACTIVITY(ACT_INDIRECT); /* SPAT profiling */

    Node = (P_) IND_CLOSURE_PTR((P_) Node);
    ENT_VIA_NODE();
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FE_
}

CAF_ITBL(Caf_info,Caf_entry,const,EF_);
\end{code}

%************************************************************************
%*									*
\subsection[black-hole-code]{Black Hole code}
%*									*
%************************************************************************

The entry code for black holes abort indicating a cyclic data dependency.
It is used to overwrite closures currently being evaluated.

In the concurrent world, black holes are synchronization points, and they
are turned into blocking queues when there are threads waiting for the 
evaluation of the closure to finish.

\begin{code}
#ifdef CONCURRENT
EXTFUN(EnterNodeCode);
EXTFUN(StackUnderflowEnterNode);
EXTDATA_RO(BQ_info);
#else
extern StgStablePtr errorHandler;
extern void raiseError PROTO((StgStablePtr));
#endif

STGFUN(BH_UPD_entry)
{
#ifndef CONCURRENT
    FB_
    (void) STGCALL1(int,(void *, FILE *),fflush,stdout);
    (void) STGCALL2(int,(),fprintf,stderr,"Entered a `black hole': the program has a cyclic data dependency.\n");

# if defined(USE_COST_CENTRES)
    {
	CostCentre cc = (CostCentre) CC_HDR(Node);
	(void) STGCALL5(int,(),fprintf,stderr,"Cost Centre: %s  Module: %s  Group %s\n",cc->label, cc->module, cc->group);
    }
# endif    

# if defined(DO_REDN_COUNTING)
    if (showRednCountStats) {
	(void) STGCALL0(void,(),PrintRednCountInfo);
    }
# endif

    (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
    FE_

#else /* threads! */

    FB_

# if 0
    if ( debug & 0x80 ) 
      (void) STGCALL4(int,(),fprintf,stderr,"GRAN_CHECK in BH_UPD_entry: Entered a `black hole' @ 0x%x (CurrentTSO @ 0x%x\n ",Node,CurrentTSO);
#endif

# if defined(GRAN)
    STGCALL0(void,(),GranSimBlock);	/* Do this before losing its TSO_LINK */
# endif

    TSO_LINK(CurrentTSO) = Nil_closure;
    SET_INFO_PTR(Node, BQ_info);
    BQ_ENTRIES(Node) = (W_) CurrentTSO;

# if defined(GCap) || defined(GCgn)
    /* If we modify a black hole in the old generation,
       we have to make sure it goes on the mutables list */

    if(Node <= StorageMgrInfo.OldLim) {
    	MUT_LINK(Node) = (W_) StorageMgrInfo.OldMutables;
        StorageMgrInfo.OldMutables = Node;
    } else
        MUT_LINK(Node) = MUT_NOT_LINKED;
# endif

    LivenessReg = LIVENESS_R1;
    SaveAllStgRegs();
    TSO_PC1(CurrentTSO) = EnterNodeCode;

    if (DO_QP_PROF) {
    	QP_Event1("GR", CurrentTSO);
    }

# ifdef PAR
    if(do_gr_profile) {
	TIME now = CURRENT_TIME;
        TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
        TSO_BLOCKCOUNT(CurrentTSO)++;
	TSO_QUEUE(CurrentTSO) = Q_BLOCKED;
        TSO_BLOCKEDAT(CurrentTSO) = now;
        DumpGranEvent(GR_BLOCK, CurrentTSO);
    }
# endif

# if defined(GRAN)
    /* CurrentTSO = Nil_closure; */
    ReSchedule(NEW_THREAD);
# else
    ReSchedule(0);
# endif

    FE_
#endif /* threads */
}

/* made external so that debugger can get at it more effectively */
STGFUN(BH_SINGLE_entry)
{
    FB_

    (void) STGCALL1(int,(void *, FILE *),fflush,stdout);
    (void) STGCALL2(int,(),fprintf,stderr,"Entered a single-entry `black hole' --\n");
    (void) STGCALL2(int,(),fprintf,stderr,"either the compiler made a mistake on single-entryness,\n");
    (void) STGCALL2(int,(),fprintf,stderr,"or the program has a cyclic data dependency.\n");

#if defined(USE_COST_CENTRES)
    {
	CostCentre cc = (CostCentre) CC_HDR(Node);
	(void) STGCALL5(int,(),fprintf,stderr, "Cost Centre: %s  Module: %s  Group %s\n",cc->label, cc->module, cc->group);
    }
#endif    

# if defined(DO_REDN_COUNTING)
    if (showRednCountStats) {
	(void) STGCALL0(void,(),PrintRednCountInfo);
    }
# endif

#ifndef CONCURRENT
    (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
#else
    EXIT(EXIT_FAILURE);
#endif

    FE_
}
\end{code}

Updatable closures are overwritten with a black hole of a fixed size,
@MIN_UPD_SIZE@.

\begin{code}
CAT_DECLARE(BH,BH_K,"BH","BH")	/* just one, shared */

BH_ITBL(BH_UPD_info,BH_UPD_entry,U,const,EF_);
\end{code}

Single-Entry closures, which are not updated, are also overwritten
with a black hole. They have size @MIN_NONUPD_SIZE@.

\begin{code}
BH_ITBL(BH_SINGLE_info,BH_SINGLE_entry,N,const,EF_);
\end{code}

%************************************************************************
%*									*
\subsection[static-update-code]{Static update code in update frames}
%*									*
%************************************************************************

This code is pointed to from update frames.  It has to cope with
any kind of algebraic return: vectored or unvectored.

See \tr{SMupdate.lh} for a description of the various update frames
and the macros defining their layout.

On entry to this code:
\begin{itemize}
\item @R1@ points to a recently created heap object (return in heap) or
is dead (return in regs).
\item @R2@ points to the info table for the constructor.
\item When returning in regs, any of the return-regs (@R3@...) may be live,
but aren't used by this code.  They must be preserved.
\item @SpB@ points to the topmost word of the update frame.
\end{itemize}

NEW update mechanism (Jan '94):

When returning to an update frame, we want to jump directly to the
update code for the constructor in hand.  Because of the various
possible return conventions (all of which must be handled by the
generic update frame), we actually end up with a somewhat indirect
jump.

\begin{code}

STGFUN(StdUpdFrameDirectReturn)
{
    FB_
    JMP_(UPDATE_CODE(InfoPtr));
    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_StdUpdFrame[] = {
    /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
    (W_) StdUpdFrameDirectReturn/*0*/,
    (W_) StdUpdFrameDirectReturn/*1*/,
    (W_) StdUpdFrameDirectReturn/*2*/,
    (W_) StdUpdFrameDirectReturn/*3*/,
    (W_) StdUpdFrameDirectReturn/*4*/,
    (W_) StdUpdFrameDirectReturn/*5*/,
    (W_) StdUpdFrameDirectReturn/*6*/,
    (W_) StdUpdFrameDirectReturn/*7*/
};

\end{code}

%************************************************************************
%*									*
\subsection[existing-con-update-code]{Update code for existing constructors}
%*									*
%************************************************************************

Here is the standard update code for objects that are returned in the heap
(or those which are initially returned in registers, but have already been
allocated in the heap earlier in the update chain.)  In either case, Node
points to the heap object.  The update code grabs the address of the updatee
out of the partial update frame (the return address has already been popped),
makes the updatee an indirection to Node, and returns according to the convention
for the constructor.

\begin{code}
#define IND_UPD_TEMPLATE(label, retvector) 				    	\
  STGFUN(label) 								\
  { 										\
    FB_	    	    	    	    	    	    	    	    	    	\
    UPD_EXISTING();			/* Ticky-ticky profiling info */ 	\
    /* Update thing off stk with an indirection to Node */			\
    UPD_IND(GRAB_UPDATEE(SpB), Node);                                    	\
    /* Pop the standard update frame */                                         \
    POP_STD_UPD_FRAME()	    	    	    	    	    	    	    	\
										\
    JMP_(retvector);								\
    FE_ 	    	    	    	    	    	    	    	    	\
  }

IND_UPD_TEMPLATE(IndUpdRetDir, DIRECT(((P_)RetReg)))
IND_UPD_TEMPLATE(IndUpdRetV0, ((P_)RetReg)[RVREL(0)])
IND_UPD_TEMPLATE(IndUpdRetV1, ((P_)RetReg)[RVREL(1)])
IND_UPD_TEMPLATE(IndUpdRetV2, ((P_)RetReg)[RVREL(2)])
IND_UPD_TEMPLATE(IndUpdRetV3, ((P_)RetReg)[RVREL(3)])
IND_UPD_TEMPLATE(IndUpdRetV4, ((P_)RetReg)[RVREL(4)])
IND_UPD_TEMPLATE(IndUpdRetV5, ((P_)RetReg)[RVREL(5)])
IND_UPD_TEMPLATE(IndUpdRetV6, ((P_)RetReg)[RVREL(6)])
IND_UPD_TEMPLATE(IndUpdRetV7, ((P_)RetReg)[RVREL(7)])

\end{code}

%************************************************************************
%*									*
\subsection[no-update-code]{Code for Erroneous Updates}
%*									*
%************************************************************************

\begin{code}

STGFUN(UpdErr)
{
    FB_

    fflush(stdout);
    fprintf(stderr, "Update error: not a constructor!\n");
    abort();

    FE_
}

STGFUN(StdErrorCode)
{
    FB_

    fflush(stdout);
    fprintf(stderr, "Standard error: should never happen!\n");
    abort();

    FE_
}
\end{code}

%************************************************************************
%*									*
\subsection[permanent-indirections]{Lexical Scoping Updates}
%*									*
%************************************************************************

A function entered without any arguments is updated with an
indirection. For lexically scoped profiling we still need to set the
cost centre if we enter the PAP. As the indirection is removed by the
garbage collector this would not be possible.

To solve this problem we introduce a permanent indirection which sets
the cost centre when entered. The heap profiler ignores the space
occupied by it as it would not reside in the heap during normal
execution.

\begin{code}
#if defined(USE_COST_CENTRES)

STGFUN(Perm_Ind_entry)
{
    FB_

    /* Don't add INDs to granularity cost */

    ENT_IND(Node);	/* Ticky-ticky profiling info */

    /* Enter PAP cost centre -- lexical scoping only */
    ENTER_CC_PAP_CL(Node);

    Node = (P_) IND_CLOSURE_PTR((P_) Node);
    ENT_VIA_NODE();	/* Ticky-ticky profiling info */

    InfoPtr=(D_)(INFO_PTR(Node));
# if defined(GRAN)
    GRAN_EXEC(1,1,2,0,0);
# endif
    JMP_(ENTRY_CODE(InfoPtr));
    FE_
}

PERM_IND_ITBL(Perm_Ind_info,Perm_Ind_entry,const,EF_);

#endif /* USE_COST_CENTRES */
\end{code}

%************************************************************************
%*									*
\subsection[partial-application-updates]{Partial applications}
%*									*
%************************************************************************

See STG paper implementation section of Partial application updates.

We jump here when the current function fails an argument satisfaction
check.  There can be two reasons for this.  In the usual case, there
is an update frame blocking our access to anything deeper on the
stack.  We then update the updatee in the frame with a partial
application node and squeeze out the update frame.  The other
possibility is that we are running threaded code, and we are sitting
on the bottom of a stack chunk.  In this case, we still build the
partial application, but we have nothing in our hands to update, so we
underflow the stack (awakening the previous chunk) and enter the
partial application node just built.

On entry to @UpdatePAP@, we assume the following:
\begin{itemize}
\item SuB points to topmost word of an update frame or to the bottom of a 
stack chunk.
\item SpA and SpB point to the topmost words of their respective stacks.
\item Node points to the closure which needs more arguments than are there.
\end{itemize}

\begin{code}

STGFUN(UpdatePAP)
{
    /* 
     * Use STG registers for these locals which must survive the HEAP_CHK.
     * Don't squash Node (R1), because it's an implicit argument.
     */

#define NNonPtrWords	(R2.i)
#define NPtrWords   	(R3.i)
#define NArgWords   	(R4.i)
#define PapSize		(R5.i)
#if defined(USE_COST_CENTRES)
# define CC_pap	((CostCentre)(R7.p))
#endif

    /* These other locals do not have to survive a HEAP_CHK */

    P_ PapClosure;
    P_ Updatee;
    P_ p;
    I_ i;

    FB_

#if defined(COUNT)
      ++nPAPs;
#endif

    SET_ACTIVITY(ACT_UPDATE_PAP);   /* SPAT profiling */

    NPtrWords    = AREL(SuA - SpA);
    NNonPtrWords = BREL(SuB - SpB);

    ASSERT(NPtrWords >= 0);
    ASSERT(NNonPtrWords >= 0);

    NArgWords = NPtrWords + NNonPtrWords + 1;	/* +1 for Node */

#if defined(USE_COST_CENTRES)
      /* set "CC_pap" to go in the updatee (see Sansom thesis, p 183) */

    CC_pap /*really cc_enter*/ = (CostCentre) CC_HDR(Node);
    if (IS_SUBSUMED_CC(CC_pap) /*really cc_enter*/)
	CC_pap = CCC;
#endif

    if (NArgWords == 1) { 

        /* 
         * No arguments, only Node.  Skip building the PAP and
         * just plan to update with an indirection.
         */

	PapClosure = Node;

    } else {
   
        /* Build the PAP.  A generic PAP closure is laid out thus:
         *	code ptr, size, no of words of ptrs, Node, ptrs, non-ptrs 
         * (i.e. a DYN closure)
         * ToDo: add stuff for special cases, to omit size and no. of ptrs 
         *	(Still ToDo?  (JSM))
         */

	PapSize = NArgWords + DYN_HS;
    
	ALLOC_UPD_PAP(DYN_HS, NArgWords, 0, PapSize);
	CC_ALLOC(CC_pap, PapSize, PAP_K);
    
	/* Allocate PapClosure -- Only Node (R1) is live */
	HEAP_CHK(LIVENESS_R1, PapSize, 0);

	SET_ACTIVITY(ACT_UPDATE_PAP);   /* back to it (for SPAT profiling) */
    
	PapClosure = Hp + 1 - PapSize;	/* The new PapClosure */

	SET_DYN_HDR(PapClosure, PAP_info, CC_pap, NArgWords + DYN_VHS, NPtrWords + 1);

	/* Now fill in the closure fields */

	p = Hp;
        for (i = NNonPtrWords - 1; i >= 0; i--) *p-- = (W_) SpB[BREL(i)];
        for (i = NPtrWords - 1; i >= 0; i--)    *p-- = (W_) SpA[AREL(i)];
	*p = (W_) Node;
	}

    /* 
     * Finished constructing PAP closure; now update the updatee. 
     * But wait!  What if there is no updatee?  Then we fall off the stack.
     */

#ifdef CONCURRENT
    if (SuB < STKO_BSTK_BOT(StkOReg)) {
    	    Node = PapClosure;
# ifdef PAR
    	    LivenessReg = LIVENESS_R1;
# endif
        JMP_(StackUnderflowEnterNode);
    	}
#endif

    /* 
     * Now we have a standard update frame, so we update the updatee with 
     * either the new PAP or Node.
     *
     * Supposedly, it is not possible to get a constructor update frame,
     * (Why not?  (JSM))
     * (Because they have *never* been implemented.  (WDP))
     */

    Updatee = GRAB_UPDATEE(SuB); 
    UPD_IND(Updatee, PapClosure);   /* Indirect Updatee to PapClosure */

    if (NArgWords != 1) {
	UPD_PAP_IN_NEW();

    } else {
	UPD_PAP_IN_PLACE();	

#if defined(USE_COST_CENTRES)
	/* 
         * Lexical scoping requires a *permanent* indirection, and we
         * also have to set the cost centre for the indirection.
         */
	INFO_PTR(Updatee) = (W_) Perm_Ind_info;
	SET_CC_HDR(Updatee, CC_pap);

#endif /* USE_COST_CENTRES */
    }

#if defined(USE_COST_CENTRES)
    /* 
     * Restore the Cost Centre too (if required); again see Sansom thesis p 183.
     * Take the CC out of the update frame if a CAF/DICT.
     */

    CCC = (IS_CAF_OR_DICT_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;

#endif /* USE_COST_CENTRES */

    /* Restore SuA, SuB, RetReg */
    RetReg = GRAB_RET(SuB);
    SuA = GRAB_SuA(SuB);
    SuB = GRAB_SuB(SuB);

    /* 
     * Squeeze out update frame from B stack.  Note that despite our best
     * efforts with [AB]REL and friends, the loop order depends on the B
     * stack growing up.
     */
    for (i = NNonPtrWords - 1; i >= 0; i--) 
	SpB[BREL(i+STD_UF_SIZE)] = SpB[BREL(i)];

    SpB += BREL(STD_UF_SIZE);

    /* 
     * All done!  Restart by re-entering Node
     * Don't count this entry for ticky-ticky profiling. 
    */

#if defined(GRAN)
    GRAN_EXEC(16,4,7,4,0);
#endif
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FE_

#undef NNonPtrWords
#undef NPtrWords
#undef NArgWords
#undef PapSize
#ifdef USE_COST_CENTRES
# undef CC_pap
#endif
}
\end{code}

The entry code for a generic PAP. @Node@ points to the PAP closure.
Reload the stacks from the PAP, and enter the closure stored in the
PAP. PAPs are in HNF so no update frame is needed.

\begin{code}
STGFUN(PAP_entry)
{
    /* Use STG registers for these locals which must survive the STK_CHK */
#define NPtrWords   	(R2.i)
#define NNonPtrWords	(R3.i)
#if defined(USE_COST_CENTRES)
# define CC_pap	((CostCentre)(R7.p))
#endif

    /* These locals don't have to survive a HEAP_CHK */
    P_ Updatee;
    P_ p;
    I_ i;
    I_ aWords, bWords;

    FB_

    SET_ACTIVITY(ACT_UPDATE_PAP);   /* SPAT profiling */

    while (AREL(SuA - SpA) == 0 && BREL(SuB - SpB) == 0) {
#ifdef CONCURRENT
        if (SuB < STKO_BSTK_BOT(StkOReg)) {
# ifdef PAR
            LivenessReg = LIVENESS_R1;
# endif
	    JMP_(StackUnderflowEnterNode);
        }
#endif

	/* We're sitting on top of an update frame, so let's do the business */

        Updatee = GRAB_UPDATEE(SuB);
	UPD_IND(Updatee, Node);

#if defined(USE_COST_CENTRES)
        /* 
         * Restore the Cost Centre too (if required); again see Sansom thesis p 183.
         * Take the CC out of the update frame if a CAF/DICT.
     */

        CC_pap = (CostCentre) CC_HDR(Node);
        CCC = (IS_CAF_OR_DICT_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;

#endif /* USE_COST_CENTRES */

        RetReg = GRAB_RET(SuB);
        SuA = GRAB_SuA(SuB);
        SuB = GRAB_SuB(SuB);
        SpB += BREL(STD_UF_SIZE);
    }

    NPtrWords    = DYN_CLOSURE_NoPTRS(Node) - 1; /* The saved Node counts as one */
    NNonPtrWords = DYN_CLOSURE_NoNONPTRS(Node);

    /* Ticky-ticky profiling info */
    ENT_PAP(Node);

    /* Enter PAP cost centre -- lexical scoping only */
    ENTER_CC_PAP_CL(Node);

    /* 
     * Check for stack overflow.  Ask to take all of the current frame with
     * us to the new world.  If there is no update frame on the current stack,
     * bWords will exceed the size of the B stack, but StackOverflow will deal 
     * with it.
     */

    aWords = AREL(SuA - SpA);
    bWords = BREL(SuB - SpB) + STD_UF_SIZE;

    STK_CHK(LIVENESS_R1, NPtrWords, NNonPtrWords, aWords, bWords, 0, 0);

    SpA -= AREL(NPtrWords);
    SpB -= BREL(NNonPtrWords);

    /* Reload Node */
    p = Node + DYN_HS;     /* Point to first pointer word */
    Node = (P_) *p++;

    /* Reload the stacks */

    for (i=0; i<NPtrWords;    i++) SpA[AREL(i)] = (P_) *p++;
    for (i=0; i<NNonPtrWords; i++) SpB[BREL(i)] = *p++;

    /* Off we go! */
    ENT_VIA_NODE();
    InfoPtr=(D_)(INFO_PTR(Node));
    JMP_(ENTRY_CODE(InfoPtr));
    FE_

#undef NPtrWords
#undef NNonPtrWords
#ifdef USE_COST_CENTRES
# undef CC_pap
#endif
}
\end{code}

The info table for a generic PAP:
\begin{code}
DYN_ITBL(PAP_info,PAP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,PAP_K,"PAP","->");
\end{code}