ghc/runtime/main/StgOverflow.lc

   1 \section[stk-overflow]{Stack overflow routine}
   2
   3 %************************************************************************
   4 %*                                                                      *
   5 \subsection[arity-error]{Arity error has nothing to do with stack overflow}
   6 %*                                                                      *
   7 %************************************************************************
   8
   9 \begin{code}
  10
  11 #include "rtsdefs.h"
  12
  13 extern void PrintRednCountInfo(STG_NO_ARGS);
  14 extern I_   showRednCountStats;
  15
  16 #ifdef __DO_ARITY_CHKS__
  17 I_ ExpectedArity;
  18
  19 void
  20 ArityError(n)
  21   I_ n;
  22 {
  23     fflush(stdout);
  24     fprintf(stderr, "Arity error: called with %ld args, should have been %ld\n",
  25                 ExpectedArity, n);
  26
  27 #if defined(DO_REDN_COUNTING)
  28     if (showRednCountStats) {
  29         PrintRednCountInfo();
  30     }
  31 #endif
  32
  33     EXIT(EXIT_FAILURE);
  34 }
  35
  36 #endif  /* __DO_ARITY_CHECKS__ */
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection[stk-oflow-seq]{Boring sequential stack overflow}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 \begin{code}
  46 #ifndef CONCURRENT
  47
  48 void
  49 StackOverflow(STG_NO_ARGS)
  50 {
  51     fflush(stdout);
  52     StackOverflowHook(SM_word_stk_size * sizeof(W_)); /*msg*/
  53
  54 #if defined(DO_REDN_COUNTING)
  55     if (showRednCountStats) {
  56         PrintRednCountInfo();
  57     }
  58 #endif
  59
  60     EXIT(EXIT_FAILURE);
  61 }
  62 #endif
  63 \end{code}
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection[stk-squeeze]{Code for squeezing out update frames}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 Code for squeezing out vacuous update frames.  Updatees of squeezed frames
  72 are turned into indirections to the common black hole (or blocking queue).
  73
  74 \begin{code}
  75
  76 I_ squeeze_upd_frames = 1; /* now ON by default */
  77
  78 I_
  79 SqueezeUpdateFrames(bottom, top, frame)
  80 P_ bottom;
  81 P_ top;
  82 P_ frame;
  83 {
  84     I_ displacement = 0;
  85     P_ next_frame = NULL;       /* Temporally next */
  86     P_ prev_frame;              /* Temporally previous */
  87
  88     /*
  89      * If we have no update frames, there is nothing to do.
  90      */
  91
  92     if (frame <= bottom)
  93         return 0;
  94
  95     if ((prev_frame = GRAB_SuB(frame)) <= bottom) {
  96 #if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
  97         if (!noBlackHoles)
  98             UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
  99 #endif
 100         return 0;
 101     }
 102
 103     /*
 104      * Walk down the stack, reversing the SuB pointers so that we can walk back up
 105      * as we squeeze from the bottom.  Note that next_frame and prev_frame refer to
 106      * next and previous as they were added to the stack, rather than the way we see
 107      * them in this walk. (It makes the next loop less confusing.)
 108      */
 109
 110     while (prev_frame > bottom) {
 111         PUSH_SuB(frame, next_frame);
 112         next_frame = frame;
 113         frame = prev_frame;
 114         prev_frame = GRAB_SuB(frame);
 115     }
 116
 117     /*
 118      * Now, we're at the bottom.  Frame points to the lowest update frame on the
 119      * stack, and its saved SuB actually points to the frame above. We have to walk
 120      * back up the stack, squeezing out empty update frames and turning the pointers
 121      * back around on the way back up.
 122      */
 123
 124     /*
 125      * The bottom-most frame has not been altered, and we never want to eliminate it
 126      * anyway.  Just black hole the updatee and walk one step up
 127      * before starting to squeeze. When you get to the topmost frame,
 128      * remember that there are still some words above it that might
 129      * have to be moved.
 130      */
 131
 132 #if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
 133     if (!noBlackHoles)
 134         UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
 135 #endif
 136     prev_frame = frame;
 137     frame = next_frame;
 138
 139     /*
 140      * Loop through all of the middle frames (everything except the very
 141      * bottom and the very top).
 142      */
 143     while ((next_frame = GRAB_SuB(frame)) != NULL) {
 144         P_ sp;
 145         P_ frame_bottom = frame + BREL(STD_UF_SIZE);
 146
 147         /* Check to see if the current frame is empty (both A and B) */
 148         if (prev_frame == frame_bottom + BREL(displacement) &&
 149           GRAB_SuA(next_frame) == GRAB_SuA(frame)) {
 150
 151             /* Now squeeze out the current frame */
 152             P_ updatee_keep = GRAB_UPDATEE(prev_frame);
 153             P_ updatee_bypass = GRAB_UPDATEE(frame);
 154
 155             /*
 156               fprintf(stderr, "squeezing frame at %lx, ret %lx\n", frame,
 157               GRAB_RET(frame));
 158              */
 159
 160 #ifdef CONCURRENT
 161             /* Check for a blocking queue on the node that's going away */
 162             if (INFO_PTR(updatee_bypass) == (W_) BQ_info) {
 163                 /* Sigh.  It has one.  Don't lose those threads! */
 164                 if (INFO_PTR(updatee_keep) == (W_) BQ_info) {
 165                     /* Urgh.  Two queues.  Merge them. */
 166                     P_ tso = (P_) BQ_ENTRIES(updatee_keep);
 167
 168                     while (TSO_LINK(tso) != Nil_closure)
 169                         tso = TSO_LINK(tso);
 170
 171                     TSO_LINK(tso) = (P_) BQ_ENTRIES(updatee_bypass);
 172                 } else {
 173                     /* For simplicity, just swap the BQ for the BH */
 174                     P_ temp = updatee_keep;
 175
 176                     updatee_keep = updatee_bypass;
 177                     updatee_bypass = temp;
 178
 179                     /* Record the swap in the kept frame (below) */
 180                     PUSH_UPDATEE(prev_frame, updatee_keep);
 181                 }
 182             }
 183 #endif
 184
 185             UPD_EXISTING();     /* ticky stuff (NB: nothing for spat-profiling) */
 186             UPD_IND(updatee_bypass, updatee_keep);
 187
 188             sp = frame - BREL(1);       /* Toss the current frame */
 189             displacement += STD_UF_SIZE;
 190
 191         } else {
 192 #if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
 193             if (!noBlackHoles)
 194                 UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
 195 #endif
 196
 197             /* No squeeze for this frame */
 198             sp = frame_bottom - BREL(1);        /* Keep the current frame */
 199
 200             /* Fix the SuB in the current frame (should point to the frame below) */
 201             PUSH_SuB(frame, prev_frame);
 202         }
 203
 204         /* Now slide all words from sp up to the next frame */
 205
 206         if (displacement > 0) {
 207             P_ next_frame_bottom = next_frame + BREL(STD_UF_SIZE);
 208
 209             /*
 210              fprintf(stderr, "sliding [%lx, %lx] by %d\n", sp, next_frame_bottom,
 211              displacement);
 212             */
 213
 214             while (sp <= next_frame_bottom) {
 215                 sp[BREL(displacement)] = *sp;
 216                 sp -= BREL(1);
 217             }
 218         }
 219         prev_frame = frame + BREL(displacement);
 220         frame = next_frame;
 221     }
 222
 223     /*
 224      * Now handle the topmost frame.  Patch SuB, black hole the updatee,
 225      * and slide down.
 226      */
 227
 228     PUSH_SuB(frame, prev_frame);
 229
 230 #if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
 231     if (!noBlackHoles)
 232         UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
 233 #endif
 234
 235     if (displacement > 0) {
 236         P_ sp = frame + BREL(STD_UF_SIZE) - BREL(1);
 237
 238         /*
 239          fprintf(stderr, "sliding [%lx, %lx] by %d\n", sp, top, displacement);
 240         */
 241
 242         while (sp <= top) {
 243             sp[BREL(displacement)] = *sp;
 244             sp -= BREL(1);
 245         }
 246     }
 247     return displacement;
 248 }
 249
 250 \end{code}
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 \subsection[stk-ouflow-par]{Rather exciting parallel stack overflow and underflow}
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 \begin{code}
 259 #ifdef CONCURRENT
 260 \end{code}
 261
 262 StackOverflow: called inside a nice ``callwrapper'' when stack
 263 overflow occurs.  The state is already saved in the TSO, and the stack
 264 is in a tidy saved state.
 265
 266 \begin{code}
 267 EXTDATA_RO(StkO_info);          /* boring extern decl */
 268 EXTFUN(EnterNodeCode);          /* For reentering node after potential GC */
 269
 270 #ifdef PAR
 271 EXTDATA_RO(FetchMe_info);
 272 #endif
 273
 274 I_
 275 StackOverflow(args1, args2)
 276 W_ args1;
 277 W_ args2;
 278 {
 279     I_ i;
 280     P_ old_stko, new_stko;
 281     W_ headroom = STACK_OVERFLOW_HEADROOM(args1, args2);
 282     I_ cts_size;
 283
 284 #ifdef PAR
 285     W_ is_prim_return = STACK_OVERFLOW_PRIM_RETURN(args1, args2);
 286 #endif
 287     W_ reenter = STACK_OVERFLOW_REENTER(args1, args2);
 288     W_ words_of_a = STACK_OVERFLOW_AWORDS(args1, args2);
 289     W_ words_of_b = STACK_OVERFLOW_BWORDS(args1, args2);
 290     W_ liveness = STACK_OVERFLOW_LIVENESS(args1, args2);
 291     I_ really_reenter_node = 0;
 292
 293     SET_TASK_ACTIVITY(ST_OVERHEAD);
 294
 295
 296     /*
 297      * fprintf(stderr,"StackOverflow:liveness=%lx,a=%lx,b=%lx\n",
 298      * liveness,words_of_a,words_of_b);
 299      */
 300
 301     old_stko = SAVE_StkO;
 302
 303     /*
 304      * fprintf(stderr, "SpA %lx SuA %lx SpB %lx SuB %lx\n", STKO_SpA(old_stko),
 305      * STKO_SuA(old_stko), STKO_SpB(old_stko), STKO_SuB(old_stko));
 306      */
 307
 308     if (squeeze_upd_frames) {
 309         i = SqueezeUpdateFrames(STKO_BSTK_BOT(old_stko), STKO_SpB(old_stko),
 310           STKO_SuB(old_stko));
 311         STKO_SuB(old_stko) += BREL(i);
 312         STKO_SpB(old_stko) += BREL(i);
 313         if ((P_) STKO_SpA(old_stko) - AREL(headroom) > STKO_SpB(old_stko)) {
 314
 315             /*
 316              * fprintf(stderr, "SpA %lx SpB %lx headroom %d\n", STKO_SpA(old_stko),
 317              * STKO_SpB(old_stko), headroom);
 318              */
 319
 320             /* We saved enough space to continue on the old StkO */
 321             return 0;
 322         }
 323     }
 324     SAVE_Liveness = liveness;
 325
 326     /* Double the stack chunk size each time we grow the stack */
 327     cts_size = STKO_CLOSURE_CTS_SIZE(old_stko) * 2;
 328
 329     if (SAVE_Hp + STKO_HS + cts_size > SAVE_HpLim) {
 330         if (reenter) {
 331             /*
 332              * Even in the uniprocessor world, we may have to reenter node in case
 333              * node is a selector shorted out by GC.
 334              */
 335             assert(liveness & LIVENESS_R1);
 336             TSO_PC2(CurrentTSO) = EnterNodeCode;
 337             really_reenter_node = 1;
 338         }
 339         ReallyPerformThreadGC(STKO_HS + cts_size, rtsFalse);
 340         old_stko = SAVE_StkO;
 341     }
 342     ALLOC_STK(STKO_HS, cts_size, 0);
 343     new_stko = SAVE_Hp + 1;
 344     SAVE_Hp += STKO_HS + cts_size;
 345     SET_STKO_HDR(new_stko, StkO_info, CCC);
 346
 347     /* Initialize the StkO, as in NewThread */
 348     STKO_SIZE(new_stko) = cts_size + STKO_VHS;
 349     STKO_SpB(new_stko) = STKO_SuB(new_stko) = STKO_BSTK_BOT(new_stko) + BREL(1);
 350     STKO_SpA(new_stko) = STKO_SuA(new_stko) = STKO_ASTK_BOT(new_stko) + AREL(1);
 351     STKO_LINK(new_stko) = old_stko;
 352
 353     STKO_RETURN(new_stko) = SAVE_Ret;
 354
 355 #ifdef PAR
 356
 357     /*
 358      * When we fall off of the top stack segment, we will either be
 359      * returning an algebraic data type, in which case R2 holds a
 360      * valid info ptr, or we will be returning a primitive
 361      * (e.g. int#), in which case R2 is garbage. If we need to perform
 362      * GC to pull in the lower stack segment (this should only happen
 363      * because of task migration), then we need to know the register
 364      * liveness for the algebraic returns.  We get the liveness out of
 365      * the info table.  Now, we could set up the primitive returns
 366      * with a bogus infoptr, which has a NO_LIVENESS field in the info
 367      * table, but that would involve a lot more overhead than the
 368      * current approach. At present, we set up RetReg to point to
 369      * *either* a polymorphic algebraic return point, or a primitive
 370      * return point.
 371      */
 372
 373     SAVE_Ret = is_prim_return ? (P_) PrimUnderflow : (P_) vtbl_Underflow;
 374 #else
 375     SAVE_Ret = (P_) vtbl_Underflow;
 376 #endif
 377
 378     STKO_SpA(old_stko) += AREL(words_of_a);
 379     STKO_SpB(old_stko) += BREL(words_of_b);
 380
 381 #ifdef DO_REDN_COUNTING
 382     /* Record the stack depths in chunks below the new stack object */
 383
 384     STKO_ADEP(new_stko) = STKO_ADEP(old_stko) +
 385       AREL((I_) STKO_ASTK_BOT(old_stko) - (I_) STKO_SpA(old_stko));
 386     STKO_BDEP(new_stko) = STKO_BDEP(old_stko) +
 387       BREL((I_) STKO_BSTK_BOT(old_stko) - (I_) STKO_SpB(old_stko));
 388 #endif
 389
 390     if (STKO_SpB(old_stko) < STKO_BSTK_BOT(old_stko)) {
 391
 392         /*
 393          * This _should_ only happen if PAP_entry fails a stack check and there is
 394          * no update frame on the current stack.  We can deal with this by storing a
 395          * function's argument requirements in its info table, peering into the PAP
 396          * (it had better be in R1) for the function pointer and taking only the
 397          * necessary number of arguments, but this would be hard, so we haven't done
 398          * it.
 399          */
 400         fflush(stdout);
 401         fprintf(stderr, "StackOverflow too deep.  Probably a PAP with no update frame.\n");
 402         abort(); /* an 'abort' may be overkill WDP 95/04 */
 403     }
 404     /* Move A stack words from old StkO to new StkO */
 405     for (i = 1; i <= words_of_a; i++) {
 406         STKO_SpA(new_stko)[-AREL(i)] = STKO_SpA(old_stko)[-AREL(i)];
 407     }
 408     STKO_SpA(new_stko) -= AREL(words_of_a);
 409
 410     /* Move B stack words from old StkO to new StkO */
 411     for (i = 1; i <= words_of_b; i++) {
 412         STKO_SpB(new_stko)[-BREL(i)] = STKO_SpB(old_stko)[-BREL(i)];
 413     }
 414     STKO_SpB(new_stko) -= BREL(words_of_b);
 415
 416     /* Now, handle movement of a single update frame */
 417     /* ToDo: Make this more efficient.  (JSM) */
 418     if (STKO_SpB(old_stko) < STKO_SuB(old_stko)) {
 419         /* Yikes!  PAP_entry stole an update frame.  Fix the world! */
 420         P_ frame = STKO_SuB(new_stko) - BREL(STD_UF_SIZE);
 421
 422         /*
 423          * fprintf(stderr, "Stolen update frame: (old %lx, new %lx) SuA %lx, SuB
 424          * %lx, return %lx\n", old_stko, new_stko, GRAB_SuA(frame), GRAB_SuB(frame),
 425          * GRAB_RET(frame));
 426          */
 427
 428         STKO_SuA(old_stko) = GRAB_SuA(frame);
 429         STKO_SuB(old_stko) = GRAB_SuB(frame);
 430
 431         SAVE_Ret = STKO_RETURN(new_stko);
 432         STKO_RETURN(new_stko) = GRAB_RET(frame);
 433
 434         PUSH_SuA(frame, STKO_SuA(new_stko));
 435         PUSH_SuB(frame, STKO_SuB(new_stko));
 436         PUSH_RET(frame, vtbl_Underflow);
 437
 438         STKO_SuB(new_stko) = frame;
 439     }
 440     SAVE_StkO = new_stko;
 441     return really_reenter_node;
 442 }
 443 \end{code}
 444
 445 Underflow things are all done in the threaded world.  The code is in
 446 main/StgThreads.lhc.
 447
 448 \begin{code}
 449 #endif /* parallel */
 450 \end{code}