X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmBuildInfoTables.hs;h=0ba8cc0c514270cb0d22a8c9bb342a4157dbf10b;hb=b597fa5bd78b96ea1c2f7ed6a6183ea8004fcbeb;hp=c2be8c9d1165381a85f0f1b814a7f26bba49a685;hpb=df5b491ce79b42987363ae96bc98b633cf55cca2;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index c2be8c9..0ba8cc0 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,3 +1,9 @@
+#if __GLASGOW_HASKELL__ >= 611
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+#endif
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmBuildInfoTables
     ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
     , setInfoTableSRT, setInfoTableStackMap
@@ -77,16 +83,35 @@ import ZipDataflow
 
 -- Also, don't forget to stop at the old end of the stack (oldByte),
 -- which may differ depending on whether there is an update frame.
+
+type RegSlotInfo
+   = ( Int	  -- Offset from oldest byte of Old area
+     , LocalReg   -- The register
+     , Int)       -- Width of the register
+
 live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
 live_ptrs oldByte slotEnv areaMap bid =
-  -- pprTrace "live_ptrs for" (ppr bid <+> ppr youngByte <+> ppr liveSlots) $
-  reverse $ slotsToList youngByte liveSlots []
-  where slotsToList n [] results | n == oldByte = results -- at old end of stack frame
+  -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
+  --                           ppr liveSlots) $
+  -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
+  res
+  where res = reverse $ slotsToList youngByte liveSlots []
+ 
+        slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
+        -- n starts at youngByte and is decremented down to oldByte
+	-- Returns a list, one element per word, with 
+	--    (Just r) meaning 'pointer register r is saved here', 
+	--    Nothing  meaning 'non-pointer or empty'
+
+        slotsToList n [] results | n == oldByte = results -- at old end of stack frame
+
         slotsToList n (s : _) _  | n == oldByte =
           pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
                ppr n <+> ppr liveSlots <+> ppr youngByte)
+
         slotsToList n _ _ | n < oldByte =
           panic "stack slots not allocated on word boundaries?"
+
         slotsToList n l@((n', r, w) : rst) results =
           if n == (n' + w) then -- slot's young byte is at n
             ASSERT (not (isPtr r) ||
@@ -97,15 +122,20 @@ live_ptrs oldByte slotEnv areaMap bid =
                            (Nothing : results)
           where next = n - wORD_SIZE
                 stack_rep = if isPtr r then Just r else Nothing
+
         slotsToList n [] results = slotsToList (n - wORD_SIZE) [] (Nothing : results)
+
         non_ptr_younger_than next (n', r, w) =
           n' + w > next &&
             ASSERT (not (isPtr r))
             True
         isPtr = isGcPtrType . localRegType
+
+        liveSlots :: [RegSlotInfo]
         liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
                            (foldFM (\_ -> flip $ foldl add_slot) [] slots)
                     
+        add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
         add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = 
           if off == w && widthInBytes (typeWidth ty) == w then
             (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
@@ -122,6 +152,8 @@ live_ptrs oldByte slotEnv areaMap bid =
           -- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL,
           -- SO IT'S ALL GOING IN THE SAME DIRECTION.
           -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
+
+        slots :: SubAreaSet	 -- The SubAreaSet for 'bid'
         slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
         youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid))