[GHC] #7460: Double literals generated bad core

[GHC]

#7460: Double literals generated bad core
------------------------------------+---------------------------------------
Reporter:  tibbe                    |          Owner:                  
    Type:  bug                      |         Status:  new             
Priority:  normal                   |      Component:  Compiler        
 Version:  7.4.2                    |       Keywords:                  
      Os:  Unknown/Multiple         |   Architecture:  Unknown/Multiple
 Failure:  Runtime performance bug  |      Blockedby:                  
Blocking:                           |        Related:                  
------------------------------------+---------------------------------------
 The following code results in core containing expression like
 `doubleFromInteger (wordToInteger sc_s2pw)`:

 {{{
 {-# LANGUAGE CPP, BangPatterns #-}
 module Main (main) where

 #define VDIM 100
 #define VNUM 100000

 import Data.Array.Base
 import Data.Array.ST
 import Data.Array.Unboxed
 import Control.Monad.ST
 import GHC.Word
 import Control.Monad
 import Data.Bits

 prng :: Word -> Word
 prng w = w'
   where
     !w1 = w `xor` (w `shiftL` 13)
     !w2 = w1 `xor` (w1 `shiftR` 7)
     !w' = w2 `xor` (w2 `shiftL` 17)

 type Vec s = STUArray s Int Double

 kahan :: Vec s -> Vec s -> ST s ()
 kahan s c = do
     let inner w j
             | j < VDIM  = do
                 !cj <- unsafeRead c j
                 !sj <- unsafeRead s j
                 let !y = fromIntegral w - cj
                     !t = sj + y
                     !w' = prng w
                 unsafeWrite c j ((t-sj)-y)
                 unsafeWrite s j t
                 inner w' (j+1)
             | otherwise = return ()
         outer i | i < VNUM = inner i 0 >> outer (i + 1)
                 | otherwise = return ()
     outer 0

 calc :: ST s (Vec s)
 calc = do
     s <- newArray (0,VDIM-1) 0
     c <- newArray (0,VDIM-1) 0
     kahan s c
     return s

 main :: IO ()
 main = print . elems $ runSTUArray calc
 }}}

-- 
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7460>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler