Skip to content

GitLab

Closed
Opened by Ian Lynagh <igloo@earth.li>@trac-igloo

signals004(profasm) core lint error

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 ***
Edited by Ian Lynagh <igloo@earth.li>