[GHC] #7944: GHC goes into an apparently infinite loop at -O2

[GHC]

#7944: GHC goes into an apparently infinite loop at -O2
-------------------------------------+-------------------------------------
        Reporter:  bos               |                   Owner:
            Type:  bug               |                  Status:  new
        Priority:  normal            |               Milestone:
       Component:  Compiler          |                 Version:  7.9
      Resolution:                    |                Keywords:
Operating System:  Unknown/Multiple  |            Architecture:  x86_64
 Type of failure:  Compile-time      |  (amd64)
  crash                              |               Test Case:
      Blocked By:                    |                Blocking:
 Related Tickets:  #5550 #8852       |  Differential Revisions:
-------------------------------------+-------------------------------------

Comment (by thomie):

 `-fno-spec-constr` indeed fixes the problem.

 I reduced the test code some more, but it still requires `vector`.

 {{{
 $ cabal install vector  # cabal gave me vector-0.10.12.3
 $ ghc-7.10.2 -O2 --make Repro.hs  # also fails with ghc-7.11.20150711
 }}}

 {{{#!haskell
 module Repro where

 import qualified Data.Vector as V
 import qualified IntMap as I

 constructMap :: V.Vector (Int, [Int]) -> I.IntMap [Int]
 constructMap = V.foldl' go I.empty
     where go m (k,v) = snd $ I.insertWith (++) k v m
 }}}

 {{{#!haskell
 module IntMap where

 import Data.Bits ((.&.), complement, xor)
 import GHC.Num (Num(..))
 import GHC.Real (fromIntegral)

 type Nat = Word

 natFromInt :: Key -> Nat
 natFromInt i = fromIntegral i

 intFromNat :: Nat -> Key
 intFromNat w = fromIntegral w

 data IntMap a = Nil | Tip Key a | Bin Prefix Mask (IntMap a) (IntMap a)

 type Prefix = Int
 type Mask   = Int
 type Key    = Int

 empty :: IntMap a
 empty = Nil

 insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
 insertWith f k x t = case t of
     Bin p m l r
         | nomatch k p m -> (Nothing, join k (Tip k x) p t)
         | zero k m      -> let (found, l') = insertWith f k x l
                            in (found, Bin p m l' r)
         | otherwise     -> let (found, r') = insertWith f k x r
                            in (found, Bin p m l r')
     Tip ky y
         | k == ky       -> (Just y, Tip k (f x y))
         | otherwise     -> (Nothing, join k (Tip k x) ky t)
     Nil                 -> (Nothing, Tip k x)

 join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
 join p1 t1 p2 t2
   | zero p1 m = Bin p m t1 t2
   | otherwise = Bin p m t2 t1
   where
     m = branchMask p1 p2
     p = mask p1 m

 zero :: Key -> Mask -> Bool
 zero i m = (natFromInt i) .&. (natFromInt m) == 0

 nomatch :: Key -> Prefix -> Mask -> Bool
 nomatch i p m = (mask i m) /= p

 mask :: Key -> Mask -> Prefix
 mask i m = maskW (natFromInt i) (natFromInt m)

 maskW :: Nat -> Nat -> Prefix
 maskW i m = intFromNat (i .&. (complement (m-1) `xor` m))

 branchMask :: Prefix -> Prefix -> Mask
 branchMask p1 p2 = intFromNat (highestBitMask (natFromInt p1))

 highestBitMask :: Nat -> Nat
 highestBitMask x1 = x1
 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/7944#comment:7>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler