Fix incorrect loop condition in inline array allocation

Also make sure allocHeapClosure updates profiling counters with the
memory allocated.

3 files changed, 12 insertions, 8 deletions

diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 2a0eaf9da7..488a0e05bc 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -99,7 +99,6 @@ allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
   -- SAY WHAT WE ARE ABOUT TO DO
   let rep = cit_rep info_tbl
   tickyDynAlloc mb_id rep lf_info
-  profDynAlloc rep use_cc
   let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))
   allocHeapClosure rep info_ptr use_cc amodes_w_offsets
 
@@ -112,6 +111,8 @@ allocHeapClosure
   -> [(CmmExpr,ByteOff)]              -- ^ payload
   -> FCode CmmExpr                    -- ^ returns the address of the object
 allocHeapClosure rep info_ptr use_cc payload = do
+  profDynAlloc rep use_cc
+
   virt_hp <- getVirtHp
 
   -- Find the offset of the info-ptr word
@@ -122,7 +123,7 @@ allocHeapClosure rep info_ptr use_cc payload = do
             -- ie 1 *before* the info-ptr word of new object.
 
   base <- getHpRelOffset info_offset
-  emitComment $ mkFastString "allocDynClosure"
+  emitComment $ mkFastString "allocHeapClosure"
   emitSetDynHdr base info_ptr use_cc
 
   -- Fill in the fields
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index a4327c4064..22f6ec103d 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -1535,14 +1535,14 @@ doNewArrayOp res_r n init = do
     dflags <- getDynFlags
 
     let info_ptr = mkLblExpr mkMAP_DIRTY_infoLabel
+        rep = arrPtrsRep dflags (fromIntegral n)
 
-    -- ToDo: this probably isn't right (card size?)
     tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))
-        (mkIntExpr dflags (fromInteger n * wORD_SIZE dflags))
+        (mkIntExpr dflags (wordsToBytes dflags (heapClosureSizeW dflags rep)))
         (zeroExpr dflags)
 
-    let rep = arrPtrsRep dflags (fromIntegral n)
-        hdr_size = fixedHdrSize dflags * wORD_SIZE dflags
+    let hdr_size = wordsToBytes dflags (fixedHdrSize dflags)
+
     base <- allocHeapClosure rep info_ptr curCCS
                      [ (mkIntExpr dflags (fromInteger n),
                         hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
@@ -1563,7 +1563,8 @@ doNewArrayOp res_r n init = do
             , mkBranch for ]
     emit =<< mkCmmIfThen
         (cmmULtWord dflags (CmmReg (CmmLocal p))
-         (cmmOffsetW dflags (CmmReg arr) (fromInteger n)))
+         (cmmOffsetW dflags (CmmReg arr)
+          (arrPtrsHdrSizeW dflags + fromInteger n)))
         (catAGraphs loopBody)
 
     emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 50112f1ef8..b1218201a6 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -485,7 +485,9 @@ tickyAllocHeap genuine hp
 
 -- the units are bytes
 
-tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
+               -> CmmExpr  -- ^ size of the payload, in bytes
+               -> CmmExpr -> FCode ()
 tickyAllocPrim _hdr _goods _slop = ifTicky $ do
   bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")
   bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr