Implement unboxed sum primitive type
[ghc.git] / rts / StgMiscClosures.cmm
index 5ddc1ac..70d219a 100644 (file)
@@ -22,30 +22,37 @@ import LeaveCriticalSection;
    Stack underflow
    ------------------------------------------------------------------------- */
 
-INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME, P_ unused)
+INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME,
+                W_ info_ptr, P_ unused)
+    /* no args => explicit stack */
 {
     W_ new_tso;
     W_ ret_off;
 
+    SAVE_STGREGS
+
     SAVE_THREAD_STATE();
-    ("ptr" ret_off) = foreign "C" threadStackUnderflow(MyCapability(),
-                                                       CurrentTSO);
+    (ret_off) = foreign "C" threadStackUnderflow(MyCapability() "ptr",
+                                                 CurrentTSO);
     LOAD_THREAD_STATE();
 
-    jump %ENTRY_CODE(Sp(ret_off));
+    RESTORE_STGREGS
+
+    jump %ENTRY_CODE(Sp(ret_off)) [*]; // NB. all registers live!
 }
 
 /* ----------------------------------------------------------------------------
    Restore a saved cost centre
    ------------------------------------------------------------------------- */
 
-INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ cccs)
+INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ info_ptr, W_ cccs)
 {
+    unwind Sp = Sp + WDS(2);
 #if defined(PROFILING)
-    W_[CCCS] = Sp(1);
+    CCCS = Sp(1);
 #endif
     Sp_adj(2);
-    jump %ENTRY_CODE(Sp(0));
+    jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live!
 }
 
 /* ----------------------------------------------------------------------------
@@ -53,10 +60,9 @@ INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ cccs)
    ------------------------------------------------------------------------- */
 
 /* 9 bits of return code for constructors created by the interpreter. */
-stg_interp_constr_entry
+stg_interp_constr_entry (P_ ret)
 {
-    /* R1 points at the constructor */
-    jump %ENTRY_CODE(Sp(0));
+    return (ret);
 }
 
 /* Some info tables to be used when compiled code returns a value to
@@ -94,76 +100,83 @@ stg_interp_constr_entry
 */
 
 INFO_TABLE_RET( stg_ctoi_R1p, RET_BCO)
+    /* explicit stack */
 {
     Sp_adj(-2);
     Sp(1) = R1;
     Sp(0) = stg_enter_info;
-    jump stg_yield_to_interpreter;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is a pointer, but unlifted, in R1 ...
  */
 INFO_TABLE_RET( stg_ctoi_R1unpt, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-2);
     Sp(1) = R1;
-    Sp(0) = stg_gc_unpt_r1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_p_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is a non-pointer in R1 ...
  */
 INFO_TABLE_RET( stg_ctoi_R1n, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-2);
     Sp(1) = R1;
-    Sp(0) = stg_gc_unbx_r1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_n_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is in F1
  */
 INFO_TABLE_RET( stg_ctoi_F1, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-2);
     F_[Sp + WDS(1)] = F1;
-    Sp(0) = stg_gc_f1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_f_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is in D1
  */
 INFO_TABLE_RET( stg_ctoi_D1, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-1) - SIZEOF_DOUBLE;
     D_[Sp + WDS(1)] = D1;
-    Sp(0) = stg_gc_d1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_d_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is in L1
  */
 INFO_TABLE_RET( stg_ctoi_L1, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-1) - 8;
     L_[Sp + WDS(1)] = L1;
-    Sp(0) = stg_gc_l1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_l_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is a void
  */
 INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-1);
-    Sp(0) = stg_gc_void_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_v_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
@@ -172,9 +185,10 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
  * stack.
  */
 INFO_TABLE_RET( stg_apply_interp, RET_BCO )
+    /* explicit stack */
 {
     /* Just in case we end up in here... (we shouldn't) */
-    jump stg_yield_to_interpreter;
+    jump stg_yield_to_interpreter [];
 }
 
 /* ----------------------------------------------------------------------------
@@ -182,12 +196,15 @@ INFO_TABLE_RET( stg_apply_interp, RET_BCO )
    ------------------------------------------------------------------------- */
 
 INFO_TABLE_FUN( stg_BCO, 4, 0, BCO, "BCO", "BCO", ARG_BCO )
+    /* explicit stack */
 {
   /* entering a BCO means "apply it", same as a function */
   Sp_adj(-2);
+  // Skip the stack check; the interpreter will do one before using
+  // the stack anyway.
   Sp(1) = R1;
   Sp(0) = stg_apply_interp_info;
-  jump stg_yield_to_interpreter;
+  jump stg_yield_to_interpreter [];
 }
 
 /* ----------------------------------------------------------------------------
@@ -201,65 +218,44 @@ INFO_TABLE_FUN( stg_BCO, 4, 0, BCO, "BCO", "BCO", ARG_BCO )
    ------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_IND,1,0,IND,"IND","IND")
+#if 0
+/*
+  This version in high-level cmm generates slightly less good code
+  than the low-level version below it. (ToDo)
+*/
+    (P_ node)
+{
+    TICK_ENT_DYN_IND(); /* tick */
+    node = UNTAG(StgInd_indirectee(node));
+    TICK_ENT_VIA_NODE();
+    jump %GET_ENTRY(node) (node);
+}
+#else
+    /* explicit stack */
 {
     TICK_ENT_DYN_IND(); /* tick */
     R1 = UNTAG(StgInd_indirectee(R1));
     TICK_ENT_VIA_NODE();
-    jump %GET_ENTRY(R1);
+    jump %GET_ENTRY(R1) [R1];
 }
+#endif
 
 INFO_TABLE(stg_IND_direct,1,0,IND,"IND","IND")
+    (P_ node)
 {
     TICK_ENT_DYN_IND(); /* tick */
-    R1 = StgInd_indirectee(R1);
+    node = StgInd_indirectee(node);
     TICK_ENT_VIA_NODE();
-    jump %ENTRY_CODE(Sp(0));
+    jump %ENTRY_CODE(Sp(0)) (node);
 }
 
 INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC")
+    /* explicit stack */
 {
     TICK_ENT_STATIC_IND(); /* tick */
     R1 = UNTAG(StgInd_indirectee(R1));
     TICK_ENT_VIA_NODE();
-    jump %GET_ENTRY(R1);
-}
-
-INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
-{
-    /* Don't add INDs to granularity cost */
-
-    /* Don't: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is
-       here only to help profiling */
-
-#if defined(TICKY_TICKY) && !defined(PROFILING)
-    /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than
-       being extra  */
-    TICK_ENT_PERM_IND();
-#endif
-
-    LDV_ENTER(R1);
-
-    /* For ticky-ticky, change the perm_ind to a normal ind on first
-     * entry, so the number of ent_perm_inds is the number of *thunks*
-     * entered again, not the number of subsequent entries.
-     *
-     * Since this screws up cost centres, we die if profiling and
-     * ticky_ticky are on at the same time.  KSW 1999-01.
-     */
-#ifdef TICKY_TICKY
-#  ifdef PROFILING
-#    error Profiling and ticky-ticky do not mix at present!
-#  endif  /* PROFILING */
-    StgHeader_info(R1) = stg_IND_info;
-#endif /* TICKY_TICKY */
-
-    R1 = UNTAG(StgInd_indirectee(R1));
-
-#if defined(TICKY_TICKY) && !defined(PROFILING)
-    TICK_ENT_VIA_NODE();
-#endif
-
-    jump %GET_ENTRY(R1);
+    jump %GET_ENTRY(R1) [R1];
 }
 
 /* ----------------------------------------------------------------------------
@@ -272,16 +268,17 @@ INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
    ------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+    (P_ node)
 {
-    W_ r, p, info, bq, msg, owner, bd;
+    W_ r, info, owner, bd;
+    P_ p, bq, msg;
 
     TICK_ENT_DYN_IND(); /* tick */
 
 retry:
-    p = StgInd_indirectee(R1);
+    p = StgInd_indirectee(node);
     if (GETTAG(p) != 0) {
-        R1 = p;
-        jump %ENTRY_CODE(Sp(0));
+        return (p);
     }
 
     info = StgHeader_info(p);
@@ -296,44 +293,47 @@ retry:
         info == stg_BLOCKING_QUEUE_CLEAN_info ||
         info == stg_BLOCKING_QUEUE_DIRTY_info)
     {
-        ("ptr" msg) = foreign "C" allocate(MyCapability() "ptr",
-                                           BYTES_TO_WDS(SIZEOF_MessageBlackHole)) [R1];
+        ("ptr" msg) = ccall allocate(MyCapability() "ptr",
+                                     BYTES_TO_WDS(SIZEOF_MessageBlackHole));
 
         SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM);
         MessageBlackHole_tso(msg) = CurrentTSO;
-        MessageBlackHole_bh(msg) = R1;
+        MessageBlackHole_bh(msg) = node;
 
-        (r) = foreign "C" messageBlackHole(MyCapability() "ptr", msg "ptr") [R1];
+        (r) = ccall messageBlackHole(MyCapability() "ptr", msg "ptr");
 
         if (r == 0) {
             goto retry;
         } else {
             StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
             StgTSO_block_info(CurrentTSO) = msg;
-            jump stg_block_blackhole;
+            jump stg_block_blackhole(node);
         }
     }
     else
     {
-        R1 = p;
-        ENTER();
+        ENTER(p);
     }
 }
 
-INFO_TABLE(__stg_EAGER_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
-{
-    jump ENTRY_LBL(stg_BLACKHOLE);
-}
-
 // CAF_BLACKHOLE is allocated when entering a CAF.  The reason it is
 // distinct from BLACKHOLE is so that we can tell the difference
 // between an update frame on the stack that points to a CAF under
 // evaluation, and one that points to a closure that is under
-// evaluation by another thread (a BLACKHOLE).  See threadPaused().
+// evaluation by another thread (a BLACKHOLE).  see Note [suspend
+// duplicate work] in ThreadPaused.c
 //
 INFO_TABLE(stg_CAF_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+    (P_ node)
+{
+    jump ENTRY_LBL(stg_BLACKHOLE) (node);
+}
+
+// EAGER_BLACKHOLE exists for the same reason as CAF_BLACKHOLE (see above).
+INFO_TABLE(__stg_EAGER_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+    (P_ node)
 {
-    jump ENTRY_LBL(stg_BLACKHOLE);
+    jump ENTRY_LBL(stg_BLACKHOLE) (node);
 }
 
 INFO_TABLE(stg_BLOCKING_QUEUE_CLEAN,4,0,BLOCKING_QUEUE,"BLOCKING_QUEUE","BLOCKING_QUEUE")
@@ -349,6 +349,7 @@ INFO_TABLE(stg_BLOCKING_QUEUE_DIRTY,4,0,BLOCKING_QUEUE,"BLOCKING_QUEUE","BLOCKIN
    ------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE")
+    (P_ node)
 {
 #if defined(THREADED_RTS)
     W_ info, i;
@@ -356,18 +357,18 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE")
     i = 0;
 loop:
     // spin until the WHITEHOLE is updated
-    info = StgHeader_info(R1);
+    info = StgHeader_info(node);
     if (info == stg_WHITEHOLE_info) {
         i = i + 1;
         if (i == SPIN_COUNT) {
             i = 0;
-            foreign "C" yieldThread() [R1];
+            ccall yieldThread();
         }
         goto loop;
     }
-    jump %ENTRY_CODE(info);
+    jump %ENTRY_CODE(info) (node);
 #else
-    foreign "C" barf("WHITEHOLE object entered!") never returns;
+    ccall barf("WHITEHOLE object entered!") never returns;
 #endif
 }
 
@@ -383,6 +384,9 @@ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO")
 INFO_TABLE(stg_STACK, 0,0, STACK, "STACK", "STACK")
 { foreign "C" barf("STACK object entered!") never returns; }
 
+INFO_TABLE(stg_RUBBISH_ENTRY, 0, 0, THUNK, "RUBBISH_ENTRY", "RUBBISH_ENTRY")
+{ foreign "C" barf("RUBBISH object entered!") never returns; }
+
 /* ----------------------------------------------------------------------------
    Weak pointers
 
@@ -404,6 +408,15 @@ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK")
 { foreign "C" barf("DEAD_WEAK object entered!") never returns; }
 
 /* ----------------------------------------------------------------------------
+   C finalizer lists
+
+   Singly linked lists that chain multiple C finalizers on a weak pointer.
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_C_FINALIZER_LIST,1,4,0,CONSTR,"C_FINALIZER_LIST","C_FINALIZER_LIST")
+{ foreign "C" barf("C_FINALIZER_LIST object entered!") never returns; }
+
+/* ----------------------------------------------------------------------------
    NO_FINALIZER
 
    This is a static nullary constructor (like []) that we use to mark an empty
@@ -439,8 +452,11 @@ INFO_TABLE(stg_MVAR_DIRTY,3,0,MVAR_DIRTY,"MVAR","MVAR")
    STM
    -------------------------------------------------------------------------- */
 
-INFO_TABLE(stg_TVAR, 2, 1, MUT_PRIM, "TVAR", "TVAR")
-{ foreign "C" barf("TVAR object entered!") never returns; }
+INFO_TABLE(stg_TVAR_CLEAN, 2, 1, TVAR, "TVAR", "TVAR")
+{ foreign "C" barf("TVAR_CLEAN object entered!") never returns; }
+
+INFO_TABLE(stg_TVAR_DIRTY, 2, 1, TVAR, "TVAR", "TVAR")
+{ foreign "C" barf("TVAR_DIRTY object entered!") never returns; }
 
 INFO_TABLE(stg_TVAR_WATCH_QUEUE, 3, 0, MUT_PRIM, "TVAR_WATCH_QUEUE", "TVAR_WATCH_QUEUE")
 { foreign "C" barf("TVAR_WATCH_QUEUE object entered!") never returns; }
@@ -509,6 +525,25 @@ INFO_TABLE_CONSTR(stg_END_TSO_QUEUE,0,0,0,CONSTR_NOCAF_STATIC,"END_TSO_QUEUE","E
 CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE);
 
 /* ----------------------------------------------------------------------------
+   GCD_CAF
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_GCD_CAF,0,0,0,CONSTR_NOCAF_STATIC,"GCD_CAF","GCD_CAF")
+{ foreign "C" barf("Evaluated a CAF that was GC'd!") never returns; }
+
+/* ----------------------------------------------------------------------------
+   STM_AWOKEN
+
+   This is a static nullary constructor (like []) that we use to mark a
+   thread waiting on an STM wakeup
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_STM_AWOKEN,0,0,0,CONSTR_NOCAF_STATIC,"STM_AWOKEN","STM_AWOKEN")
+{ foreign "C" barf("STM_AWOKEN object entered!") never returns; }
+
+CLOSURE(stg_STM_AWOKEN_closure,stg_STM_AWOKEN);
+
+/* ----------------------------------------------------------------------------
    Arrays
 
    These come in two basic flavours: arrays of data (StgArrWords) and arrays of
@@ -516,7 +551,7 @@ CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE);
 
    ___________________________
    | Info | No. of | data....
-        |  Ptr | Words  |
+   |  Ptr | Words  |
    ---------------------------
 
    These are *unpointed* objects: i.e. they cannot be entered.
@@ -538,6 +573,18 @@ INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN, 0, 0, MUT_ARR_PTRS_FROZEN, "MUT_ARR_PTRS_FRO
 INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN0, 0, 0, MUT_ARR_PTRS_FROZEN0, "MUT_ARR_PTRS_FROZEN0", "MUT_ARR_PTRS_FROZEN0")
 { foreign "C" barf("MUT_ARR_PTRS_FROZEN0 object entered!") never returns; }
 
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_CLEAN, 0, 0, SMALL_MUT_ARR_PTRS_CLEAN, "SMALL_MUT_ARR_PTRS_CLEAN", "SMALL_MUT_ARR_PTRS_CLEAN")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_CLEAN object entered!") never returns; }
+
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_DIRTY, 0, 0, SMALL_MUT_ARR_PTRS_DIRTY, "SMALL_MUT_ARR_PTRS_DIRTY", "SMALL_MUT_ARR_PTRS_DIRTY")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_DIRTY object entered!") never returns; }
+
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_FROZEN, 0, 0, SMALL_MUT_ARR_PTRS_FROZEN, "SMALL_MUT_ARR_PTRS_FROZEN", "SMALL_MUT_ARR_PTRS_FROZEN")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_FROZEN object entered!") never returns; }
+
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_FROZEN0, 0, 0, SMALL_MUT_ARR_PTRS_FROZEN0, "SMALL_MUT_ARR_PTRS_FROZEN0", "SMALL_MUT_ARR_PTRS_FROZEN0")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_FROZEN0 object entered!") never returns; }
+
 /* ----------------------------------------------------------------------------
    Mutable Variables
    ------------------------------------------------------------------------- */
@@ -556,8 +603,9 @@ INFO_TABLE(stg_MUT_VAR_DIRTY, 1, 0, MUT_VAR_DIRTY, "MUT_VAR_DIRTY", "MUT_VAR_DIR
  * ------------------------------------------------------------------------- */
 
 INFO_TABLE( stg_dummy_ret, 0, 0, CONSTR_NOCAF_STATIC, "DUMMY_RET", "DUMMY_RET")
+    ()
 {
-  jump %ENTRY_CODE(Sp(0));
+    return ();
 }
 CLOSURE(stg_dummy_ret_closure,stg_dummy_ret);
 
@@ -569,6 +617,18 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE
 { foreign "C" barf("MVAR_TSO_QUEUE object entered!") never returns; }
 
 /* ----------------------------------------------------------------------------
+   COMPACT_NFDATA (a blob of data in NF with no outgoing pointers)
+
+   Just return immediately because the structure is in NF already
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE( stg_COMPACT_NFDATA, 0, 0, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA")
+    ()
+{
+    return ();
+}
+
+/* ----------------------------------------------------------------------------
    CHARLIKE and INTLIKE closures.
 
    These are static representations of Chars and small Ints, so that
@@ -576,7 +636,7 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE
    replace them with references to the static objects.
    ------------------------------------------------------------------------- */
 
-#if defined(__PIC__) && defined(mingw32_HOST_OS)
+#if defined(COMPILING_WINDOWS_DLL)
 /*
  * When sticking the RTS in a Windows DLL, we delay populating the
  * Charlike and Intlike tables until load-time, which is only
@@ -601,7 +661,7 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE
  * on the fact that static closures live in the data section.
  */
 
-#if !(defined(__PIC__) && defined(mingw32_HOST_OS))
+#if !(defined(COMPILING_WINDOWS_DLL))
 section "data" {
  stg_CHARLIKE_closure:
     CHARLIKE_HDR(0)
@@ -899,4 +959,4 @@ section "data" {
     INTLIKE_HDR(16)  /* MAX_INTLIKE == 16 */
 }
 
-#endif // !(defined(__PIC__) && defined(mingw32_HOST_OS))
+#endif