%************************************************************************
%*									*
\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}).

\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(Prelude_Z91Z93_closure);

#if defined(TICKY_TICKY)
void PrintTickyInfo(STG_NO_ARGS);
#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 */

    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);

    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
void raiseError PROTO((StgStablePtr));
extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
#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(PROFILING)
    {
	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(TICKY_TICKY)
    if (RTSflags.TickyFlags.showTickyStats) {
	(void) STGCALL0(void,(),PrintTickyInfo);
    }
# endif

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

#else /* threads! */

    FB_

# if 0
    if ( RTSflags.GranFlags.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)
    /* Do this before losing its TSO_LINK */
    STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);	
# endif

    TSO_LINK(CurrentTSO) = Prelude_Z91Z93_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(RTSflags.ParFlags.granSimStats) {
	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 = Prelude_Z91Z93_closure; */
    ReSchedule(SAME_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(PROFILING)
    {
	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(TICKY_TICKY)
    if (RTSflags.TickyFlags.showTickyStats) {
	(void) STGCALL0(void,(),PrintTickyInfo);
    }
# 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.

In ticky-land: If we are trying to collect update-entry counts
(controlled by an RTS flag), then we must use permanent indirections
(the shorting-out of regular indirections loses the counts).

\begin{code}
#if defined(PROFILING) || defined(TICKY_TICKY)

STGFUN(Perm_Ind_entry)
{
    FB_

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

    /* Dont: ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */

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

    Node = (P_) IND_CLOSURE_PTR((P_) Node);

    /* Dont: ENT_VIA_NODE(); for ticky-ticky; as above */

    InfoPtr=(D_)(INFO_PTR(Node));

    JMP_(ENTRY_CODE(InfoPtr));
    FE_
}

PERM_IND_ITBL(Perm_Ind_info,Perm_Ind_entry,const,EF_);

#endif /* PROFILING or TICKY */
\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(PROFILING)
# 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(GRAN_COUNT)
      ++nPAPs;
#endif

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

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

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

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

    CC_pap /*really cc_enter*/ = (CostCentre) CC_HDR(Node);
    if (IS_CAF_OR_DICT_OR_SUB_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);

	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(NArgWords);

    } else {
	UPD_PAP_IN_PLACE();	

#if defined(PROFILING)
	/* 
         * 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 /* PROFILING */
    }

#if defined(PROFILING)
    /* 
     * 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_OR_SUB_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;

#endif /* PROFILING */

    /* 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 0 /* 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 PROFILING
# 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(PROFILING)
# define CC_pap	((CostCentre)(R7.p))
#endif

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

    FB_

    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(PROFILING)
        /* 
         * 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_OR_SUB_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;

#endif /* PROFILING */

        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 PROFILING
# 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}