Merge remote-tracking branch 'origin/master' into newcg

Conflicts:
	compiler/cmm/CmmLint.hs
	compiler/cmm/OldCmm.hs
	compiler/codeGen/CgMonad.lhs
	compiler/main/CodeOutput.lhs

5 files changed, 109 insertions, 82 deletions

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index bfddf5b322..feb4be50c1 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -76,6 +76,7 @@ import Foreign
 import Data.Array
 import Data.IORef
 import Data.Char                ( ord, chr )
+import Data.Time
 import Data.Typeable
 #if __GLASGOW_HASKELL__ >= 701
 import Data.Typeable.Internal
@@ -488,6 +489,23 @@ instance (Binary a, Binary b) => Binary (Either a b) where
                              0 -> do a <- get bh ; return (Left a)
                              _ -> do b <- get bh ; return (Right b)
 
+instance Binary UTCTime where
+    put_ bh u = do put_ bh (utctDay u)
+                   put_ bh (utctDayTime u)
+    get bh = do day <- get bh
+                dayTime <- get bh
+                return $ UTCTime { utctDay = day, utctDayTime = dayTime }
+
+instance Binary Day where
+    put_ bh d = put_ bh (toModifiedJulianDay d)
+    get bh = do i <- get bh
+                return $ ModifiedJulianDay { toModifiedJulianDay = i }
+
+instance Binary DiffTime where
+    put_ bh dt = put_ bh (toRational dt)
+    get bh = do r <- get bh
+                return $ fromRational r
+
 #if defined(__GLASGOW_HASKELL__) || 1
 --to quote binary-0.3 on this code idea,
 --
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index c029e4a8e0..ee7e616305 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -30,6 +30,7 @@ module IOEnv (
         atomicUpdMutVar, atomicUpdMutVar'
   ) where
 
+import DynFlags
 import Exception
 import Panic
 
@@ -88,6 +89,10 @@ instance Show IOEnvFailure where
 
 instance Exception IOEnvFailure
 
+instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
+    getDynFlags = do env <- getEnv
+                     return $ extractDynFlags env
+
 ----------------------------------------------------------------------
 -- Fundmantal combinators specific to the monad
 ----------------------------------------------------------------------
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index d7bbc54cc7..c506e23410 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -22,7 +22,7 @@ module Outputable (
         empty, nest,
         char,
         text, ftext, ptext,
-        int, integer, float, double, rational,
+        int, intWithCommas, integer, float, double, rational,
         parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets,
         semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
@@ -48,7 +48,7 @@ module Outputable (
         renderWithStyle,
 
         pprInfixVar, pprPrefixVar,
-        pprHsChar, pprHsString, pprHsInfix, pprHsVar,
+        pprHsChar, pprHsString, 
         pprFastFilePath,
 
         -- * Controlling the style in which output is printed
@@ -745,6 +745,11 @@ data BindingSite = LambdaBind | CaseBind | LetBind
 class Outputable a => OutputableBndr a where
    pprBndr :: BindingSite -> a -> SDoc
    pprBndr _b x = ppr x
+
+   pprPrefixOcc, pprInfixOcc :: a -> SDoc
+      -- Print an occurrence of the name, suitable either in the 
+      -- prefix position of an application, thus   (f a b) or  ((+) x)
+      -- or infix position,                 thus   (a `f` b) or  (x + y)
 \end{code}
 
 %************************************************************************
@@ -779,27 +784,6 @@ pprInfixVar is_operator pp_v
   | otherwise   = char '`' <> pp_v <> char '`'
 
 ---------------------
--- pprHsVar and pprHsInfix use the gruesome isOperator, which
--- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
--- Reason: it means that pprHsVar doesn't need a NamedThing context,
---         which none of the HsSyn printing functions do
-pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
-pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
-             where pp_v = ppr v
-pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
-             where pp_v = ppr v
-
-isOperator :: SDoc -> Bool
-isOperator ppr_v
-  = case showSDocUnqual ppr_v of
-        ('(':_)   -> False              -- (), (,) etc
-        ('[':_)   -> False              -- []
-        ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
-        (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
-        ('_':_)   -> False              -- Not an operator
-        (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
-        _         -> False
-
 pprFastFilePath :: FastString -> SDoc
 pprFastFilePath path = text $ normalise $ unpackFS path
 \end{code}
@@ -848,6 +832,15 @@ quotedListWithOr xs = quotedList xs
 %************************************************************************
 
 \begin{code}
+intWithCommas :: Integral a => a -> SDoc
+-- Prints a big integer with commas, eg 345,821
+intWithCommas n
+  | n < 0     = char '-' <> intWithCommas (-n)
+  | q == 0    = int (fromIntegral r)
+  | otherwise = intWithCommas q <> comma <> int (fromIntegral r)
+  where
+    (q,r) = n `quotRem` 1000
+
 -- | Converts an integer to a verbal index:
 --
 -- > speakNth 1 = text "first"
diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs
index 7253af1274..66f51e64e6 100644
--- a/compiler/utils/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -14,14 +14,13 @@ module Platform (
 
 where
 
-import Panic
-
 -- | Contains enough information for the native code generator to emit
 --      code for this platform.
 data Platform
         = Platform {
               platformArch                     :: Arch,
               platformOS                       :: OS,
+              platformWordSize                 :: {-# UNPACK #-} !Int,
               platformHasGnuNonexecStack       :: Bool,
               platformHasIdentDirective        :: Bool,
               platformHasSubsectionsViaSymbols :: Bool
@@ -55,8 +54,10 @@ data OS
         | OSSolaris2
         | OSMinGW32
         | OSFreeBSD
+        | OSDragonFly
         | OSOpenBSD
         | OSNetBSD
+        | OSKFreeBSD
         deriving (Read, Show, Eq)
 
 -- | ARM Instruction Set Architecture and Extensions
@@ -77,24 +78,21 @@ data ArmISAExt
 
 
 target32Bit :: Platform -> Bool
-target32Bit p = case platformArch p of
-                ArchUnknown -> panic "Don't know if ArchUnknown is 32bit"
-                ArchX86     -> True
-                ArchX86_64  -> False
-                ArchPPC     -> True
-                ArchPPC_64  -> False
-                ArchSPARC   -> True
-                ArchARM _ _ -> True
-
+target32Bit p = platformWordSize p == 4
 
 -- | This predicates tells us whether the OS supports ELF-like shared libraries.
 osElfTarget :: OS -> Bool
-osElfTarget OSLinux    = True
-osElfTarget OSFreeBSD  = True
-osElfTarget OSOpenBSD  = True
-osElfTarget OSNetBSD   = True
-osElfTarget OSSolaris2 = True
-osElfTarget OSDarwin   = False
-osElfTarget OSMinGW32  = False
-osElfTarget OSUnknown  = panic "Don't know if OSUnknown is elf"
-
+osElfTarget OSLinux     = True
+osElfTarget OSFreeBSD   = True
+osElfTarget OSDragonFly = True
+osElfTarget OSOpenBSD   = True
+osElfTarget OSNetBSD    = True
+osElfTarget OSSolaris2  = True
+osElfTarget OSDarwin    = False
+osElfTarget OSMinGW32   = False
+osElfTarget OSKFreeBSD  = True
+osElfTarget OSUnknown   = False
+ -- Defaulting to False is safe; it means don't rely on any
+ -- ELF-specific functionality.  It is important to have a default for
+ -- portability, otherwise we have to answer this question for every
+ -- new platform we compile on (even unreg).
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 0720eae113..d09a1ad345 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -1,17 +1,11 @@
 %
 % (c) The University of Glasgow 2006
-% (c) The University of Glasgow 1992-2002
 %
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 -- | Highly random utility functions
+--
 module Util (
         -- * Flags dependent on the compiler build
         ghciSupported, debugIsOn, ncgDebugIsOn,
@@ -21,13 +15,13 @@ module Util (
         -- * General list processing
         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
         zipLazy, stretchZipWith,
-        
+
         unzipWith,
-        
+
         mapFst, mapSnd,
         mapAndUnzip, mapAndUnzip3,
         nOfThem, filterOut, partitionWith, splitEithers,
-        
+
         foldl1', foldl2, count, all2,
 
         lengthExceeds, lengthIs, lengthAtLeast,
@@ -51,13 +45,13 @@ module Util (
         nTimes,
 
         -- * Sorting
-        sortLe, sortWith, minWith, on, 
+        sortLe, sortWith, minWith, on,
 
         -- * Comparisons
         isEqual, eqListBy, eqMaybeBy,
         thenCmp, cmpList,
         removeSpaces,
-        
+
         -- * Edit distance
         fuzzyMatch, fuzzyLookup,
 
@@ -82,6 +76,7 @@ module Util (
         -- * IO-ish utilities
         createDirectoryHierarchy,
         doesDirNameExist,
+        getModificationUTCTime,
         modificationTimeIfExists,
 
         global, consIORef, globalM,
@@ -119,7 +114,6 @@ import System.IO.Error as IO ( isDoesNotExistError )
 import System.Directory ( doesDirectoryExist, createDirectory,
                           getModificationTime )
 import System.FilePath
-import System.Time      ( ClockTime )
 
 import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit )
 import Data.Ratio       ( (%) )
@@ -128,6 +122,12 @@ import Data.Bits
 import Data.Word
 import qualified Data.IntMap as IM
 
+import Data.Time
+#if __GLASGOW_HASKELL__ < 705
+import Data.Time.Clock.POSIX
+import System.Time
+#endif
+
 infixr 9 `thenCmp`
 \end{code}
 
@@ -219,9 +219,9 @@ nTimes n f = f . nTimes (n-1) f
 \end{code}
 
 \begin{code}
-fstOf3   :: (a,b,c) -> a    
-sndOf3   :: (a,b,c) -> b    
-thirdOf3 :: (a,b,c) -> c    
+fstOf3   :: (a,b,c) -> a
+sndOf3   :: (a,b,c) -> b
+thirdOf3 :: (a,b,c) -> c
 fstOf3      (a,_,_) =  a
 sndOf3      (_,b,_) =  b
 thirdOf3    (_,_,c) =  c
@@ -759,8 +759,8 @@ restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
     else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1
 
 restrictedDamerauLevenshteinDistance'
-  :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int
-restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 
+  :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int
+restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
   | [] <- str1 = n
   | otherwise  = extractAnswer $
                  foldl' (restrictedDamerauLevenshteinDistanceWorker
@@ -772,7 +772,7 @@ restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
     extractAnswer (_, _, _, _, distance) = distance
 
 restrictedDamerauLevenshteinDistanceWorker
-      :: (Bits bv) => IM.IntMap bv -> bv -> bv
+      :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv
       -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
 restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask
                                            (pm, d0, vp, vn, distance) char2
@@ -782,26 +782,26 @@ restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask
     (pm', d0', vp', vn', distance'')
   where
     pm' = IM.findWithDefault 0 (ord char2) str1_mvs
-    
+
     d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm)
       .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn
           -- No need to mask the shiftL because of the restricted range of pm
 
     hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)
     hn' = d0' .&. vp
-    
+
     hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask
     hn'_shift = (hn' `shiftL` 1) .&. vector_mask
     vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)
     vn' = d0' .&. hp'_shift
-    
+
     distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance
     distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
 
 sizedComplement :: Bits bv => bv -> bv -> bv
 sizedComplement vector_mask vect = vector_mask `xor` vect
 
-matchVectors :: Bits bv => String -> IM.IntMap bv
+matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv
 matchVectors = snd . foldl' go (0 :: Int, IM.empty)
   where
     go (ix, im) char = let ix' = ix + 1
@@ -843,16 +843,16 @@ fuzzyLookup user_entered possibilites
                                             poss_str user_entered
                        , distance <= fuzzy_threshold ]
   where
-    -- Work out an approriate match threshold: 
-    -- We report a candidate if its edit distance is <= the threshold, 
+    -- Work out an approriate match threshold:
+    -- We report a candidate if its edit distance is <= the threshold,
     -- The threshhold is set to about a quarter of the # of characters the user entered
-    -- 	 Length    Threshold
-    --	   1	     0		-- Don't suggest *any* candidates
-    --	   2	     1		-- for single-char identifiers
-    -- 	   3	     1
-    --	   4	     1
-    --	   5	     1
-    --	   6	     2
+    --   Length    Threshold
+    --     1         0          -- Don't suggest *any* candidates
+    --     2         1          -- for single-char identifiers
+    --     3         1
+    --     4         1
+    --     5         1
+    --     6         2
     --
     fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational)
     mAX_RESULTS = 3
@@ -1035,12 +1035,24 @@ doesDirNameExist fpath = case takeDirectory fpath of
                          "" -> return True -- XXX Hack
                          _  -> doesDirectoryExist (takeDirectory fpath)
 
+-----------------------------------------------------------------------------
+-- Backwards compatibility definition of getModificationTime
+
+getModificationUTCTime :: FilePath -> IO UTCTime
+#if __GLASGOW_HASKELL__ < 705
+getModificationUTCTime f = do
+    TOD secs _ <- getModificationTime f
+    return $ posixSecondsToUTCTime (realToFrac secs)
+#else
+getModificationUTCTime = getModificationTime
+#endif
+
 -- --------------------------------------------------------------
 -- check existence & modification time at the same time
 
-modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
+modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)
 modificationTimeIfExists f = do
-  (do t <- getModificationTime f; return (Just t))
+  (do t <- getModificationUTCTime f; return (Just t))
         `catchIO` \e -> if isDoesNotExistError e
                         then return Nothing
                         else ioError e
@@ -1129,14 +1141,15 @@ abstractDataType n = mkDataType n [abstractConstr n]
 
 \begin{code}
 charToC :: Word8 -> String
-charToC w = 
+charToC w =
   case chr (fromIntegral w) of
-	'\"' -> "\\\""
-	'\'' -> "\\\'"
-	'\\' -> "\\\\"
-	c | c >= ' ' && c <= '~' -> [c]
+        '\"' -> "\\\""
+        '\'' -> "\\\'"
+        '\\' -> "\\\\"
+        c | c >= ' ' && c <= '~' -> [c]
           | otherwise -> ['\\',
                          chr (ord '0' + ord c `div` 64),
                          chr (ord '0' + ord c `div` 8 `mod` 8),
                          chr (ord '0' + ord c         `mod` 8)]
 \end{code}
+