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