X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmStackLayout.hs;h=17a819f92750bce604b4ad23991e39365571026b;hb=547bf6827f1fc3f2fb31bc6323cc0d33b445f32a;hp=60f4b5c99a56dcbde84d7f7ae8ecbfb25a66ee2e;hpb=dc6a72b94f1c2de24cf51a2ca8f44ada6db17ab9;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 60f4b5c..17a819f 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -57,7 +57,7 @@ import ZipDataflow
 -- a single slot, on insertion.
 
 slotLattice :: DataflowLattice SubAreaSet
-slotLattice = DataflowLattice "live slots" emptyFM add True
+slotLattice = DataflowLattice "live slots" emptyFM add False
   where add new old = case foldFM addArea (False, old) new of
                         (True,  x) -> aTx  x
                         (False, x) -> noTx x
@@ -94,7 +94,8 @@ liveGen s set = liveGen' s set []
           a == a' && hi >= hi' && hi - w <= hi' - w'
 
 liveKill :: SubArea -> [SubArea] -> [SubArea]
-liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' set []
+liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $
+                          liveKill' set []
   where liveKill' [] z = z
         liveKill' (s'@(a', hi', w') : rst) z =
           if a /= a' || hi < lo' || lo > hi' then    -- no overlap
@@ -136,12 +137,20 @@ liveLastIn env l = liveInSlots (liveLastOut env l) l
 
 -- Don't forget to keep the outgoing parameters in the CallArea live,
 -- as well as the update frame.
+-- Note: We have to keep the update frame live at a call because of the
+-- case where the function doesn't return -- in that case, there won't
+-- be a return to keep the update frame live. We'd still better keep the
+-- info pointer in the update frame live at any call site;
+-- otherwise we could screw up the garbage collector.
 liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
 liveLastOut env l =
   case l of
-    LastCall _ Nothing  n _ -> 
+    LastCall _ Nothing n _ -> 
       add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
-    LastCall _ (Just k) n _ -> add_area (CallArea (Young k)) n out
+    LastCall _ (Just k) n (Just _) ->
+      add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
+    LastCall _ (Just k) n Nothing ->
+      add_area (CallArea (Young k)) n out
     _ -> out
   where out = joinOuts slotLattice env l
         add_area _ n live | n == 0 = live
@@ -277,7 +286,7 @@ allocSlotFrom ig areaSize from areaMap area =
 -- Note: The stack pointer only has to be younger than the youngest live stack slot
 -- at proc points. Otherwise, the stack pointer can point anywhere.
 layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap
-layout procPoints env g@(LGraph _ entrySp _) =
+layout procPoints env g =
   let builder = areaBuilder
       ig = (igraph builder env g, builder)
       env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
@@ -301,7 +310,8 @@ layout procPoints env g@(LGraph _ entrySp _) =
             start = case returnOff stackInfo of Just b  -> max b young
                                                 Nothing -> young
             z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id))
-        in pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) z
+        in -- pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) 
+           z
       allocCallSlot areaMap _ = areaMap
       -- mid foreign calls need to have info tables placed on the stack
       allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
@@ -318,10 +328,11 @@ layout procPoints env g@(LGraph _ entrySp _) =
         where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
               layout areaMap (ZLast _)   = allocCallSlot areaMap b
       areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g)
-  in pprTrace "ProcPoints" (ppr procPoints) $
-       pprTrace "Area SizeMap" (ppr areaSize) $
-         pprTrace "Entry SP" (ppr entrySp) $
-           pprTrace "Area Map" (ppr areaMap) $ areaMap
+  in -- pprTrace "ProcPoints" (ppr procPoints) $
+       -- pprTrace "Area SizeMap" (ppr areaSize) $
+         -- pprTrace "Entry SP" (ppr entrySp) $
+           -- pprTrace "Area Map" (ppr areaMap) $
+     areaMap
 
 -- After determining the stack layout, we can:
 -- 1. Replace references to stack Areas with addresses relative to the stack
@@ -337,7 +348,7 @@ manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap ->
 manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
   liftM (LGraph entry args) blocks'
   where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
-        slot a = pprTrace "slot" (ppr a) $
+        slot a = -- pprTrace "slot" (ppr a) $
                    lookupFM areaMap a `orElse` panic "unallocated Area"
         slot' (Just id) = slot $ CallArea (Young id)
         slot' Nothing   = slot $ CallArea Old
@@ -361,8 +372,8 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
         replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
         replB blocks (Block id o t) =
           do bs <- replTail (Block id o) spIn t
-             pprTrace "spIn" (ppr id <+> ppr spIn)$
-              liftM (flip (foldr insertBlock) bs) blocks
+             -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
+             liftM (flip (foldr insertBlock) bs) blocks
           where spIn = sp_on_entry id
         replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> 
                     FuelMonad ([CmmBlock])
@@ -375,7 +386,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
         middle spOff m = mapExpDeepMiddle (replSlot spOff) m
         last   spOff l = mapExpDeepLast   (replSlot spOff) l
         replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
-        replSlot spOff (CmmLit CmmHighStackMark) = -- replacing the high water mark
+        replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
           CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
         replSlot _ e = e
         -- The block must establish the SP expected at each successsor.
@@ -384,7 +395,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
         fixSp h spOff l@(LastBranch k) =
           let succSp = sp_on_entry k in
           if succSp /= spOff then
-               pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
+               -- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
                updSp h spOff succSp l
           else return $ [h (ZLast (LastOther (last spOff l)))]
         fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
@@ -408,7 +419,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
 maxSlot :: (Area -> Int) -> CmmGraph -> Int
 maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g
   where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
-        add z (a, i, w) = max z (slotOff a + i)
+        add z (a, i, _) = max z (slotOff a + i)
 
 -----------------------------------------------------------------------------
 -- | Sanity check: stub pointers immediately after they die