[commit: ghc] master: Fix incorrect loop condition in inline array allocation (c1d74ab)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c1d74ab96df7607529596d01223bc8654abf71b9/ghc

>---------------------------------------------------------------

commit c1d74ab96df7607529596d01223bc8654abf71b9
Author: Johan Tibell <johan.tibell at gmail.com>
Date:   Tue Mar 11 13:54:29 2014 +0100

    Fix incorrect loop condition in inline array allocation
    
    Also make sure allocHeapClosure updates profiling counters with the
    memory allocated.


>---------------------------------------------------------------

c1d74ab96df7607529596d01223bc8654abf71b9
 compiler/codeGen/StgCmmHeap.hs  |    5 +++--
 compiler/codeGen/StgCmmPrim.hs  |   11 ++++++-----
 compiler/codeGen/StgCmmTicky.hs |    4 +++-
 3 files changed, 12 insertions(+), 8 deletions(-)

diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 2a0eaf9..488a0e0 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 a4327c4..22f6ec1 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 50112f1..b121820 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