Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

8 files changed, 81 insertions, 70 deletions

diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 98c7e21332..9e5bc52a79 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -994,26 +994,27 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
     dflags <- getDynFlags
     -- Assign the arguments to temporaries so the code generator can
     -- calculate liveness for us.
-    src <- assignTemp_ src0
-    src_off <- assignTemp_ src_off0
-    dst <- assignTemp_ dst0
-    dst_off <- assignTemp_ dst_off0
     n <- assignTemp_ n0
+    emitIf (cmmNeWord dflags n (CmmLit (mkIntCLit dflags 0))) $ do
+        src <- assignTemp_ src0
+        src_off <- assignTemp_ src_off0
+        dst <- assignTemp_ dst0
+        dst_off <- assignTemp_ dst_off0
 
-    -- Set the dirty bit in the header.
-    stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+        -- Set the dirty bit in the header.
+        stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 
-    dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
-    dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off
-    src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
-    bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags (wORD_SIZE dflags)))
+        dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
+        dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off
+        src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
+        bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags (wORD_SIZE dflags)))
 
-    copy src dst dst_p src_p bytes live
+        copy src dst dst_p src_p bytes live
 
-    -- The base address of the destination card table
-    dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
+        -- The base address of the destination card table
+        dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
 
-    emitSetCards dst_off dst_cards_p n live
+        emitSetCards dst_off dst_cards_p n live
 
 -- | Takes an info table label, a register to return the newly
 -- allocated array in, a source array, an offset in the source array,
@@ -1065,14 +1066,16 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
 
 -- | Takes and offset in the destination array, the base address of
 -- the card table, and the number of elements affected (*not* the
--- number of cards).  Marks the relevant cards as dirty.
+-- number of cards). The number of elements may not be zero.
+-- Marks the relevant cards as dirty.
 emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
 emitSetCards dst_start dst_cards_start n live = do
     dflags <- getDynFlags
     start_card <- assignTemp $ card dflags dst_start
+    let end_card = card dflags (cmmAddWord dflags dst_start n)
     emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
         (CmmLit (mkIntCLit dflags 1))
-        (cardRoundUp dflags n)
+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (CmmLit (mkIntCLit dflags 1)))
         (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte)
         live
 
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 97104ce4a2..4e7a48264a 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -1069,27 +1069,30 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
               -> FCode ()
 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
     dflags <- getDynFlags
-    -- Passed as arguments (be careful)
-    src     <- assignTempE src0
-    src_off <- assignTempE src_off0
-    dst     <- assignTempE dst0
-    dst_off <- assignTempE dst_off0
     n       <- assignTempE n0
+    nonzero <- getCode $ do
+        -- Passed as arguments (be careful)
+        src     <- assignTempE src0
+        src_off <- assignTempE src_off0
+        dst     <- assignTempE dst0
+        dst_off <- assignTempE dst_off0
+
+        -- Set the dirty bit in the header.
+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 
-    -- Set the dirty bit in the header.
-    emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
+        src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
+        bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags))
 
-    dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
-    dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
-    src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
-    bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags))
+        copy src dst dst_p src_p bytes
 
-    copy src dst dst_p src_p bytes
+        -- The base address of the destination card table
+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
 
-    -- The base address of the destination card table
-    dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
+        emitSetCards dst_off dst_cards_p n
 
-    emitSetCards dst_off dst_cards_p n
+    emit =<< mkCmmIfThen (cmmNeWord dflags n (mkIntExpr dflags 0)) nonzero
 
 -- | Takes an info table label, a register to return the newly
 -- allocated array in, a source array, an offset in the source array,
@@ -1137,14 +1140,16 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
 
 -- | Takes and offset in the destination array, the base address of
 -- the card table, and the number of elements affected (*not* the
--- number of cards).  Marks the relevant cards as dirty.
+-- number of cards). The number of elements may not be zero.
+-- Marks the relevant cards as dirty.
 emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 emitSetCards dst_start dst_cards_start n = do
     dflags <- getDynFlags
     start_card <- assignTempE $ card dflags dst_start
+    let end_card = card dflags (cmmSubWord dflags (cmmAddWord dflags dst_start n) (mkIntExpr dflags 1))
     emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
         (mkIntExpr dflags 1)
-        (cardRoundUp dflags n)
+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))
         (mkIntExpr dflags 1) -- no alignment (1 byte)
 
 -- Convert an element index to a card index
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 0a20f59061..3409d77397 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -630,7 +630,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
     occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing))
                                  | a <- all_avails, n <- availNames a]
       where
-        -- we know that (1) there are at most entries for one name, (2) their
+        -- we know that (1) there are at most 2 entries for one name, (2) their
         -- first component is identical, (3) they are for tys/cls, and (4) one
         -- entry has the name in its parent position (the other doesn't)
         combine (name, AvailTC p1 subs1, Nothing)
diff --git a/includes/Cmm.h b/includes/Cmm.h
index afe08a26a3..805806b309 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -247,8 +247,8 @@
 // because LDV profiling relies on entering closures to mark them as
 // "used".
 
-#define LOAD_INFO \
-    info = %INFO_PTR(UNTAG(P1));
+#define LOAD_INFO(ret,x)                        \
+    info = %INFO_PTR(UNTAG(x));
 
 #define MAYBE_UNTAG(x) UNTAG(x);
 
@@ -346,11 +346,13 @@
    ------------------------------------------------------------------------- */
 
 #if defined(PROFILING)
-#define PROF_HDR_FIELDS(w_)                     \
-  w_ prof_hdr_1,                                \
-  w_ prof_hdr_2,
+#define PROF_HDR_FIELDS(w_) PROF_HDR_FIELDS_(w_,prof_hdr_1,prof_hdr_2)
+#define PROF_HDR_FIELDS_(w_,hdr1,hdr2)          \
+  w_ hdr1,                                      \
+  w_ hdr2,
 #else
 #define PROF_HDR_FIELDS(w_) /* nothing */
+#define PROF_HDR_FIELDS_(w_,hdr1,hdr2) /* nothing */
 #endif
 
 /* -------------------------------------------------------------------------
diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm
index 08adf45b02..1375216646 100644
--- a/rts/HeapStackCheck.cmm
+++ b/rts/HeapStackCheck.cmm
@@ -216,7 +216,7 @@ stg_gc_prim_n (W_ arg)
 /* The stg_enter_checkbh frame has the same shape as an update frame: */
 
 INFO_TABLE_RET ( stg_enter_checkbh, RET_SMALL,
-                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,updatee))
+                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,ccs,updatee))
     return (P_ ret)
 {
     foreign "C" checkBlockingQueues(MyCapability() "ptr",
diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm
index 0b69a9a279..bd2b3df178 100644
--- a/rts/StgStdThunks.cmm
+++ b/rts/StgStdThunks.cmm
@@ -28,14 +28,11 @@
    -------------------------------------------------------------------------- */
 
 #ifdef PROFILING
-#define RET_FIELDS(w_,info_ptr,ccs)             \
-  w_ info_ptr,                                  \
-  w_ ccs
-#define GET_SAVED_CCCS  CCCS = ccs
+#define SAVE_CCS        W_ saved_ccs; saved_ccs = CCCS;
+#define RESTORE_CCS     CCCS = saved_ccs;
 #else
-#define RET_FIELDS(w_,info_ptr,ccs)             \
-  w_ info_ptr
-#define GET_SAVED_CCCS  /* empty */
+#define SAVE_CCS        /* nothing */
+#define RESTORE_CCS     /* nothing */
 #endif
 
 /*
@@ -69,11 +66,13 @@
       STK_CHK_NP(node);                                                 \
       UPD_BH_UPDATABLE(node);                                           \
       LDV_ENTER(node);                                                  \
-      ENTER_CCS_THUNK(node);                                            \
       selectee = StgThunk_payload(node,0);                              \
-      push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info,node)) {           \
+      push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info,CCCS,node)) {      \
+        ENTER_CCS_THUNK(node);                                          \
         if (NEED_EVAL(selectee)) {                                      \
+          SAVE_CCS;                                                     \
           (P_ constr) = call %GET_ENTRY(selectee) (selectee);           \
+          RESTORE_CCS;                                                  \
           selectee = constr;                                            \
         }                                                               \
         field = StgClosure_payload(UNTAG(selectee),offset);             \
@@ -111,10 +110,12 @@ SELECTOR_CODE_UPD(15)
       STK_CHK_NP(node);                                                 \
       UPD_BH_UPDATABLE(node);                                           \
       LDV_ENTER(node);                                                  \
-      ENTER_CCS_THUNK(node);                                            \
       selectee = StgThunk_payload(node,0);                              \
       if (NEED_EVAL(selectee)) {                                        \
+          ENTER_CCS_THUNK(node);                                        \
+          SAVE_CCS;                                                     \
           (P_ constr) = call %GET_ENTRY(selectee) (selectee);           \
+          RESTORE_CCS;                                                  \
           selectee = constr;                                            \
       }                                                                 \
       field = StgClosure_payload(UNTAG(selectee),offset);               \
@@ -164,8 +165,8 @@ INFO_TABLE(stg_ap_1_upd,1,0,THUNK_1_0,"stg_ap_1_upd_info","stg_ap_1_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+        ENTER_CCS_THUNK(node);
         jump stg_ap_0_fast
             (StgThunk_payload(node,0));
     }
@@ -178,8 +179,8 @@ INFO_TABLE(stg_ap_2_upd,2,0,THUNK_2_0,"stg_ap_2_upd_info","stg_ap_2_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+        ENTER_CCS_THUNK(node);
         jump stg_ap_p_fast
             (StgThunk_payload(node,0),
              StgThunk_payload(node,1));
@@ -193,8 +194,8 @@ INFO_TABLE(stg_ap_3_upd,3,0,THUNK,"stg_ap_3_upd_info","stg_ap_3_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+        ENTER_CCS_THUNK(node);
         jump stg_ap_pp_fast
             (StgThunk_payload(node,0),
              StgThunk_payload(node,1),
@@ -209,8 +210,8 @@ INFO_TABLE(stg_ap_4_upd,4,0,THUNK,"stg_ap_4_upd_info","stg_ap_4_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+        ENTER_CCS_THUNK(node);
         jump stg_ap_ppp_fast
             (StgThunk_payload(node,0),
              StgThunk_payload(node,1),
@@ -226,8 +227,8 @@ INFO_TABLE(stg_ap_5_upd,5,0,THUNK,"stg_ap_5_upd_info","stg_ap_5_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+        ENTER_CCS_THUNK(node);
         jump stg_ap_pppp_fast
             (StgThunk_payload(node,0),
              StgThunk_payload(node,1),
@@ -244,8 +245,8 @@ INFO_TABLE(stg_ap_6_upd,6,0,THUNK,"stg_ap_6_upd_info","stg_ap_6_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+        ENTER_CCS_THUNK(node);
         jump stg_ap_ppppp_fast
             (StgThunk_payload(node,0),
              StgThunk_payload(node,1),
@@ -263,8 +264,8 @@ INFO_TABLE(stg_ap_7_upd,7,0,THUNK,"stg_ap_7_upd_info","stg_ap_7_upd_info")
     STK_CHK_NP(node);
     UPD_BH_UPDATABLE(node);
     LDV_ENTER(node);
-    ENTER_CCS_THUNK(node);
-    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, node)) {
+    push (UPDATE_FRAME_FIELDS(,,stg_upd_frame_info, CCCS, node)) {
+      ENTER_CCS_THUNK(node);
       jump stg_ap_pppppp_fast
           (StgThunk_payload(node,0),
            StgThunk_payload(node,1),
diff --git a/rts/Updates.cmm b/rts/Updates.cmm
index 2bc21ec332..bd6060f142 100644
--- a/rts/Updates.cmm
+++ b/rts/Updates.cmm
@@ -26,7 +26,7 @@
  * we don't mind duplicating this jump.
  */
 INFO_TABLE_RET ( stg_upd_frame, UPDATE_FRAME,
-                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,updatee) )
+                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,_ccs,updatee) )
     return (P_ ret) /* the closure being returned */
 {
     /* ToDo: it might be a PAP, so we should check... */
@@ -42,7 +42,7 @@ INFO_TABLE_RET ( stg_upd_frame, UPDATE_FRAME,
  * another thread in the meantime.
  */
 INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME,
-                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,updatee) )
+                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,_ccs,updatee) )
     return (P_ ret) /* the closure being returned */
 {
     W_ v, i, tso, link;
@@ -77,11 +77,11 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME,
  * high watermark.
  */
 INFO_TABLE_RET ( stg_bh_upd_frame, UPDATE_FRAME,
-                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,updatee) )
+                 UPDATE_FRAME_FIELDS(W_,P_,info_ptr,ccs,updatee) )
     return (P_ ret) /* the closure being returned */
 {
     // This all compiles away to a single jump instruction (sigh)
     jump RET_LBL(stg_marked_upd_frame)
-        ( UPDATE_FRAME_FIELDS(,,info_ptr,updatee) )
+        ( UPDATE_FRAME_FIELDS(,,info_ptr,ccs,updatee) )
         (ret);
 }
diff --git a/rts/Updates.h b/rts/Updates.h
index 0205e6e763..c65af9ace6 100644
--- a/rts/Updates.h
+++ b/rts/Updates.h
@@ -35,9 +35,9 @@
  */
 #ifdef CMINUSMINUS
 
-#define UPDATE_FRAME_FIELDS(w_,p_,info_ptr,updatee)     \
+#define UPDATE_FRAME_FIELDS(w_,p_,info_ptr,ccs,updatee) \
                  w_ info_ptr,                           \
-                 PROF_HDR_FIELDS(w_)                    \
+                 PROF_HDR_FIELDS_(w_,ccs,_unused_)      \
                  p_ updatee