Opened 8 years ago

Closed 8 years ago

#5341 closed bug (fixed)

signals004(profasm) core lint error

Reported by: igloo Owned by: simonpj
Priority: highest Milestone: 7.2.1
Component: Compiler Version: 7.0.3
Keywords: Cc:
Operating System: Unknown/Multiple Architecture: Unknown/Multiple
Type of failure: None/Unknown Test Case:
Blocked By: Blocking:
Related Tickets: Differential Rev(s):
Wiki Page:

Description (last modified by igloo)

signals004(profasm) is giving a core lint error. Here's a slightly cut down version:

import Control.Concurrent
import System.Posix
import Control.Monad

main :: IO ()
main = do
  c <- newChan
  m <- newEmptyMVar
  _ <- forkIO $ do replicateM_ 1000 (install c); putMVar m ()
  return ()

install :: Chan () -> IO Handler
install c = do
  _ <- installHandler sigUSR1 (Catch (writeChan c ())) Nothing
  return undefined
ghc -fforce-recomp -c -O -prof -auto-all -dcore-lint -dcmm-lint signals004.hs
*** Core Lint errors : in result of Simplifier ***
<no location info>:
    [RHS of a_s1DC :: GHC.Prim.Int#
                      -> GHC.Prim.State# GHC.Prim.RealWorld
                      -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)]
    Demand type has  2  arguments, rhs has  0 arguments,  a_s1DC
    Binder's strictness signature: DmdType LL
*** Offending Program ***
a_s1jF
  :: GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[LclId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
a_s1jF =
  \ (s_a1jg [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    __scc {main main:Main !} (# s_a1jg, GHC.Unit.() #)

a_s1jk
  :: GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld,
           System.Posix.Signals.Handler #)
[LclId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
a_s1jk =
  \ (s_a1jg [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    __scc {install main:Main !}
    (# s_a1jg, GHC.Err.undefined @ System.Posix.Signals.Handler #)

lvl_s1j7 :: GHC.Types.Int
[LclId,
 Str=DmdType m,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=IF_ARGS [] 10 110}]
lvl_s1j7 = __scc {main main:Main !} GHC.Types.I# 1000

a_s1lB
  :: Control.Concurrent.Chan.Chan ()
     -> GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[LclId,
 Arity=2,
 Str=DmdType LL,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
         ConLike=True, Cheap=True, Expandable=True, Guidance=NEVER}]
a_s1lB =
  \ (c_alj [Dmd=Just L] :: Control.Concurrent.Chan.Chan ())
    (s_a1jv [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    letrec {
      a_s1DC [Occ=LoopBreaker]
        :: GHC.Prim.Int#
           -> GHC.Prim.State# GHC.Prim.RealWorld
           -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
      [LclId,
       Str=DmdType LL,
       Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=True,
               ConLike=True, Cheap=False, Expandable=False,
               Guidance=IF_ARGS [] 354 60}]
      a_s1DC =
        __scc {main main:Main !}
        let {
          lvl_s1DH :: System.Posix.Signals.Handler
          [LclId,
           Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=True,
                   ConLike=True, Cheap=True, Expandable=True,
                   Guidance=IF_ARGS [] 70 110}]
          lvl_s1DH =
            __scc {install main:Main !}
            System.Posix.Signals.Catch
              ((\ (w_a1BE [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
                  case c_alj
                  of _
                  { Control.Concurrent.Chan.Chan ww_a1BA [Dmd=Just A]
                                                 ww_a1BB [Dmd=Just L] ->
                  Control.Concurrent.Chan.$wa4 @ () ww_a1BB GHC.Unit.() w_a1BE
                  })
               `cast` (Sym (GHC.Types.NTCo:IO <()>)
                       :: (GHC.Prim.State# GHC.Prim.RealWorld
                           -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
                            ~
                          GHC.Types.IO ())) } in
        let {
          lvl_s1DG :: System.Posix.Signals.Handler
          [LclId,
           Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=True,
                   ConLike=True, Cheap=True, Expandable=True,
                   Guidance=IF_ARGS [] 70 110}]
          lvl_s1DG =
            __scc {install main:Main !}
            System.Posix.Signals.Catch
              ((\ (w_a1BE [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
                  case c_alj
                  of _
                  { Control.Concurrent.Chan.Chan ww_a1BA [Dmd=Just A]
                                                 ww_a1BB [Dmd=Just L] ->
                  Control.Concurrent.Chan.$wa4 @ () ww_a1BB GHC.Unit.() w_a1BE
                  })
               `cast` (Sym (GHC.Types.NTCo:IO <()>)
                       :: (GHC.Prim.State# GHC.Prim.RealWorld
                           -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
                            ~
                          GHC.Types.IO ())) } in
        \ (m_a1D7 [Dmd=Just L] :: GHC.Prim.Int#)
          (eta_B1 [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
          case GHC.Prim.<=# m_a1D7 1 of _ {
            GHC.Types.False ->
              case __scc {install main:Main}
                   case System.Posix.Signals.$wa
                          (System.Posix.Signals.sigUSR3
                           `cast` (Sym (Foreign.C.Types.NTCo:CInt)
                                   :: GHC.Int.Int32 ~ Foreign.C.Types.CInt))
                          lvl_s1DG
                          eta_B1
                   of _ { (# new_s_a1jy [Dmd=Just L], _ #) ->
                   (__scc {install main:Main !} a_s1jk) new_s_a1jy
                   }
              of _ { (# new_s_a1jy [Dmd=Just L], _ #) ->
              a_s1DC (GHC.Prim.-# m_a1D7 1) new_s_a1jy
              };
            GHC.Types.True ->
              case __scc {install main:Main}
                   case System.Posix.Signals.$wa
                          (System.Posix.Signals.sigUSR3
                           `cast` (Sym (Foreign.C.Types.NTCo:CInt)
                                   :: GHC.Int.Int32 ~ Foreign.C.Types.CInt))
                          lvl_s1DH
                          eta_B1
                   of _ { (# new_s_a1jy [Dmd=Just L], _ #) ->
                   (__scc {install main:Main !} a_s1jk) new_s_a1jy
                   }
              of _ { (# new_s_a1jy [Dmd=Just L], _ #) ->
              (# new_s_a1jy, GHC.Unit.() #)
              }
          }; } in
    __scc {main main:Main !}
    case GHC.Prim.newMVar# @ GHC.Prim.RealWorld @ () s_a1jv
    of _ { (# s2#_a1jM [Dmd=Just L], svar#_a1jN [Dmd=Just L] #) ->
    case GHC.Prim.fork#
           @ (GHC.Types.IO ())
           ((\ (eta_a1jR [Dmd=Just L]
                  :: GHC.Prim.State# GHC.Prim.RealWorld) ->
               GHC.Prim.catch#
                 @ ()
                 @ GHC.Exception.SomeException
                 (\ (s_X1k8 [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
                    case lvl_s1j7 of _ { GHC.Types.I# ww_a1CQ [Dmd=Just L] ->
                    case GHC.Prim.<=# ww_a1CQ 0 of _ {
                      GHC.Types.False ->
                        case a_s1DC ww_a1CQ s_X1k8
                        of _ { (# new_s_X1kd [Dmd=Just L], _ #) ->
                        case GHC.Prim.putMVar#
                               @ GHC.Prim.RealWorld @ () svar#_a1jN GHC.Unit.() new_s_X1kd
                        of s2#_a1lv [Dmd=Just L] { __DEFAULT ->
                        (# s2#_a1lv, GHC.Unit.() #)
                        }
                        };
                      GHC.Types.True ->
                        case GHC.Prim.putMVar#
                               @ GHC.Prim.RealWorld @ () svar#_a1jN GHC.Unit.() s_X1k8
                        of s2#_a1lv [Dmd=Just L] { __DEFAULT ->
                        (# s2#_a1lv, GHC.Unit.() #)
                        }
                    }
                    })
                 GHC.Conc.Sync.forkIO2
                 eta_a1jR)
            `cast` (Sym (GHC.Types.NTCo:IO <()>)
                    :: (GHC.Prim.State# GHC.Prim.RealWorld
                        -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
                         ~
                       GHC.Types.IO ()))
           s2#_a1jM
    of _ { (# s1_a1lh [Dmd=Just L], _ #) ->
    (__scc {main main:Main !} a_s1jF) s1_a1lh
    }
    }

a_s1m6
  :: GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[LclId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=IF_ARGS [0] 144 0}]
a_s1m6 =
  \ (s_a1jv [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    __scc {main main:Main}
    case GHC.Prim.newMVar#
           @ GHC.Prim.RealWorld @ (Control.Concurrent.Chan.ChItem ()) s_a1jv
    of _ { (# s2#_a1lK [Dmd=Just L], svar#_a1lL [Dmd=Just L] #) ->
    case GHC.Prim.newMVar#
           @ GHC.Prim.RealWorld
           @ (GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ()))
           s2#_a1lK
    of _ { (# s2#1_a1lQ [Dmd=Just L], svar#1_a1lR [Dmd=Just L] #) ->
    let {
      hole_a1lP :: GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ())
      [LclId,
       Str=DmdType m,
       Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=True,
               ConLike=True, Cheap=True, Expandable=True,
               Guidance=IF_ARGS [] 10 110}]
      hole_a1lP =
        GHC.MVar.MVar @ (Control.Concurrent.Chan.ChItem ()) svar#_a1lL } in
    case GHC.Prim.putMVar#
           @ GHC.Prim.RealWorld
           @ (GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ()))
           svar#1_a1lR
           hole_a1lP
           s2#1_a1lQ
    of s2#2_a1lT [Dmd=Just L] { __DEFAULT ->
    case GHC.Prim.newMVar#
           @ GHC.Prim.RealWorld
           @ (GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ()))
           s2#2_a1lT
    of _ { (# s2#3_a1lW [Dmd=Just L], svar#2_a1lX [Dmd=Just L] #) ->
    case GHC.Prim.putMVar#
           @ GHC.Prim.RealWorld
           @ (GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ()))
           svar#2_a1lX
           hole_a1lP
           s2#3_a1lW
    of s2#4_a1lZ [Dmd=Just L] { __DEFAULT ->
    a_s1lB
      (Control.Concurrent.Chan.Chan
         @ ()
         (GHC.MVar.MVar
            @ (GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ())) svar#1_a1lR)
         (GHC.MVar.MVar
            @ (GHC.MVar.MVar (Control.Concurrent.Chan.ChItem ())) svar#2_a1lX))
      s2#4_a1lZ
    }
    }
    }
    }
    }

a_s1iV
  :: GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[LclId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=IF_ARGS [0] 30 0}]
a_s1iV =
  \ (eta_B1 [Dmd=Just L] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    GHC.TopHandler.runMainIO1
      @ ()
      (a_s1m6
       `cast` (Sym (GHC.Types.NTCo:IO <()>)
               :: (GHC.Prim.State# GHC.Prim.RealWorld
                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
                    ~
                  GHC.Types.IO ()))
      eta_B1

Main.main :: GHC.Types.IO ()
[LclIdX,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.main =
  a_s1m6
  `cast` (Sym (GHC.Types.NTCo:IO <()>)
          :: (GHC.Prim.State# GHC.Prim.RealWorld
              -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
               ~
             GHC.Types.IO ())

:Main.main :: GHC.Types.IO ()
[LclIdX,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
:Main.main =
  a_s1iV
  `cast` (Sym (GHC.Types.NTCo:IO <()>)
          :: (GHC.Prim.State# GHC.Prim.RealWorld
              -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
               ~
             GHC.Types.IO ())

*** End of Offense ***

Change History (4)

comment:1 Changed 8 years ago by igloo

Description: modified (diff)

comment:2 Changed 8 years ago by simonpj@…

commit 4e72e09348c11b44103ee29990262d44ee86df50

Author: Simon Peyton Jones <simonpj@microsoft.com>
Date:   Wed Jul 27 06:25:45 2011 +0100

    Fix let-floating out of Rec blocks
    
    This fixes Trac #5341 and #5342.  The question is about
    what to do when floating out of the RHS of a Rec-bound
    function, when there's a FloatCase involved.  For FloatLets
    they can join the Rec block, but FloatCases can't.  But
    we don't want to mess with the arity (that was the bug).
    So in this (rather exotic case) we push the FloatCase
    back inside any lambdas.
    
    See Note [Floating out of Rec rhss]. It's a slightly ugly fix, but I
    can't think of anything better, and I don't think it has any practical
    impact.

 compiler/simplCore/FloatOut.lhs |   49 ++++++++++++++++++++++++++++++++++++--
 1 files changed, 46 insertions(+), 3 deletions(-)

comment:3 Changed 8 years ago by simonpj

Status: newmerge

Fixed!

comment:4 Changed 8 years ago by igloo

Resolution: fixed
Status: mergeclosed
Note: See TracTickets for help on using tickets.