diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 2a0eaf9da7bdd956551fd921485af3a4688ab1a8..488a0e05bcdfc1448d8f9a8c87bfbe3c78416673 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 a4327c4064cda06467b218c3b32563b8542822fe..22f6ec103dddf32a84663d2a707fb2b016cace44 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 50112f1ef8058239e945e6e8ac875aea3b0448c8..b1218201a678231e74fa19a47fbf94fb2a659892 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