catch SIGHUP and SIGTERM and raise an exception (#3656)

[ghc-hetmet.git] / compiler / utils / UniqFM.lhs

diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 4081017..9a3d606 100644 (file)
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -15,14 +15,17 @@ Basically, the things need to be in class @Uniquable@, and we use the
 \begin{code}
 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
 module UniqFM (
+       -- * Unique-keyed mappings
        UniqFM(..),     -- abstract type
                        -- (de-abstracted for MachRegs.trivColorable optimisation BL 2007/09)
 
+        -- ** Manipulating those mappings
        emptyUFM,
        unitUFM,
        unitDirectlyUFM,
        listToUFM,
        listToUFM_Directly,
+       listToUFM_C,
        addToUFM,addToUFM_C,addToUFM_Acc,
        addListToUFM,addListToUFM_C,
        addToUFM_Directly,
@@ -45,7 +48,7 @@ module UniqFM (
        isNullUFM,
        lookupUFM, lookupUFM_Directly,
        lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
-       eltsUFM, keysUFM,
+       eltsUFM, keysUFM, splitUFM,
        ufmToList 
     ) where
 
@@ -74,6 +77,9 @@ unitDirectlyUFM -- got the Unique already
 listToUFM      :: Uniquable key => [(key,elt)] -> UniqFM elt
 listToUFM_Directly
                :: [(Unique, elt)] -> UniqFM elt
+listToUFM_C     :: Uniquable key => (elt -> elt -> elt) 
+                           -> [(key, elt)] 
+                           -> UniqFM elt
 
 addToUFM       :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt
 addListToUFM   :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
@@ -124,6 +130,8 @@ hashUFM             :: UniqFM elt -> Int
 elemUFM                :: Uniquable key => key -> UniqFM elt -> Bool
 elemUFM_Directly:: Unique -> UniqFM elt -> Bool
 
+splitUFM        :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
+                  -- Splits a UFM into things less than, equal to, and greater than the key
 lookupUFM      :: Uniquable key => UniqFM elt -> key -> Maybe elt
 lookupUFM_Directly  -- when you've got the Unique already
                :: UniqFM elt -> Unique -> Maybe elt
@@ -131,7 +139,6 @@ lookupWithDefaultUFM
                :: Uniquable key => UniqFM elt -> elt -> key -> elt
 lookupWithDefaultUFM_Directly
                :: UniqFM elt -> elt -> Unique -> elt
-
 keysUFM                :: UniqFM elt -> [Unique]       -- Get the keys
 eltsUFM                :: UniqFM elt -> [elt]
 ufmToList      :: UniqFM elt -> [(Unique, elt)]
@@ -196,11 +203,11 @@ This code is explained in the paper:
 %*                                                                     *
 %************************************************************************
 
-@UniqFM a@ is a mapping from Unique to a.
-
 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
 
 \begin{code}
+-- | @UniqFM a@ is a mapping from Unique to @a@. DO NOT use these constructors
+-- directly unless you live in this module!
 data UniqFM ele
   = EmptyUFM
   | LeafUFM !FastInt ele
@@ -243,6 +250,9 @@ listToUFM key_elt_pairs
 
 listToUFM_Directly uniq_elt_pairs
   = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
+
+listToUFM_C combiner key_elt_pairs
+  = addListToUFM_C combiner EmptyUFM key_elt_pairs
 \end{code}
 
 Now ways of adding things to UniqFMs.
@@ -349,7 +359,7 @@ plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
                        (mix_trees t2 t2')
                -- Now the 4 different other ways; all like this:
                --
-               -- Given j >^ j' (and, say,  j > j')
+ -- Given j >^ j' (and, say,  j > j')
                --
                --        j             j'                       j
                --       / \    +      / \      ==>             / \
@@ -599,6 +609,25 @@ lookUp fm i            = lookup_tree fm
          | otherwise   = lookup_tree t2
 
        lookup_tree EmptyUFM = panic "lookup Failed"
+
+-------------------
+splitUFM fm key = split fm (getKeyFastInt (getUnique key))
+
+split :: UniqFM a -> FastInt -> (UniqFM a, Maybe a, UniqFM a)
+-- Splits a UFM into things less than, equal to, and greater than the key
+split EmptyUFM _ = (EmptyUFM, Nothing, EmptyUFM)
+split fm i       = go fm
+  where
+    go (LeafUFM j b) | i <# j    = (EmptyUFM,    Nothing, LeafUFM j b)
+                            | i ># j    = (LeafUFM j b, Nothing, EmptyUFM)
+                     | otherwise = (EmptyUFM,    Just b,  EmptyUFM)
+                            
+    go (NodeUFM j p t1 t2) 
+      | j ># i 
+      , (lt, eq, gt) <- go t1 = (lt, eq, mkSLNodeUFM (NodeUFMData j p) gt t2)
+      | (lt, eq, gt) <- go t2 = (mkLSNodeUFM (NodeUFMData j p) t1 lt, eq, gt)
+
+    go EmptyUFM = panic "splitUFM failed"
 \end{code}
 
 folds are *wonderful* things.
@@ -634,7 +663,9 @@ functionality, but may do a few needless evaluations.
 
 \begin{code}
 mkLeafUFM :: FastInt -> a -> UniqFM a
-mkLeafUFM i a    = LeafUFM i a
+mkLeafUFM i a =
+  ASSERT (iBox i >= 0) -- Note [Uniques must be positive]
+  LeafUFM i a
 
 -- The *ONLY* ways of building a NodeUFM.
 
@@ -792,8 +823,8 @@ getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
   | p <# p2    = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
   | otherwise  = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
   where
-    j  = i  `quotFastInt` (shiftL1 p)
-    j2 = i2 `quotFastInt` (shiftL1 p2)
+    !j  = i  `quotFastInt` (shiftL1 p)
+    !j2 = i2 `quotFastInt` (shiftL1 p2)
 
     getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
 
@@ -839,3 +870,21 @@ use_snd :: a -> b -> b
 use_snd _ b = b
 \end{code}
 
+{- Note [Uniques must be positive]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The getCommonNodeUFMData function assumes that the nodes use
+positive uniques. Specifically, the inner `loop' shifts the
+low bits out of two uniques until the shifted uniques are the same.
+At the same time, it computes a new delta, by shifting
+to the left.
+
+The failure case I (JPD) encountered:
+If one of the uniques is negative, the shifting may continue
+until all 64 bits have been shifted out, resulting in a new delta
+of 0, which is wrong and can trigger later assertion failures.
+
+Where do the negative uniques come from? Both Simom M and
+I have run into this problem when hashing a data structure.
+In both cases, we have avoided the problem by ensuring that
+the hashes remain positive.
+-}