IR corresponding to the test case in https://github.com/rrnewton/haskell-lockfree/issues/28

GHC_763_core.hs

Result size of Tidy Core = {terms: 49, types: 76, coercions: 69}

main2 :: [Char]
[GblId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, WorkFree=False, Expandable=False,
         Guidance=IF_ARGS [] 180 0}]
main2 =
  unpackCString#
    "Pattern match failure in do expression at Issue28.hs:10:3-11"

main3 :: [Char]
[GblId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, WorkFree=False, Expandable=False,
         Guidance=IF_ARGS [] 40 0}]
main3 = unpackCString# "bye"

main4 :: [Char]
[GblId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, WorkFree=False, Expandable=False,
         Guidance=IF_ARGS [] 40 0}]
main4 = unpackCString# "hi"

main1 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=IF_ARGS [0] 125 90}]
main1 =
  \ (eta_Xe :: State# RealWorld) ->
    case newMutVar# @ [Char] @ RealWorld main4 eta_Xe
    of _ { (# ipv_alQ, ipv1_alR #) ->
    case (readMutVar#
            @ (Any *)
            @ (Any *)
            (ipv1_alR
             `cast` (MutVar#
                       (UnsafeCo RealWorld (Any *)) (UnsafeCo [Char] (Any *))
                     :: MutVar# RealWorld [Char] ~# MutVar# (Any *) (Any *)))
            (ipv_alQ
             `cast` (State# (UnsafeCo RealWorld (Any *))
                     :: State# RealWorld ~# State# (Any *))))
         `cast` ((# State# (UnsafeCo (Any *) RealWorld),
                    UnsafeCo (Any *) (Ticket [Char]) #)
                 :: (# State# (Any *), Any * #)
                      ~#
                    (# State# RealWorld, Ticket [Char] #))
    of _ { (# ipv2_Xmg, ipv3_Xmi #) ->
    case ({__pkg_ccall_GC atomic-primops-0.6.0.2 stg_casMutVar2zh MutVar#
                                                          RealWorld ()
                                                        -> Any (* -> *) ()
                                                        -> Any (* -> *) ()
                                                        -> State# RealWorld
                                                        -> (# State# RealWorld,
                                                              Int#,
                                                              Any (* -> *) () #)}_am6
            (ipv1_alR
             `cast` (MutVar# <RealWorld> (UnsafeCo [Char] ())
                     :: MutVar# RealWorld [Char] ~# MutVar# RealWorld ()))
            (ipv3_Xmi
             `cast` (UnsafeCo (Ticket [Char]) (Any (* -> *) ())
                     :: Ticket [Char] ~# Any (* -> *) ()))
            (main3
             `cast` (UnsafeCo [Char] (Ticket [Char]) ; UnsafeCo
                                                         (Ticket [Char]) (Any (* -> *) ())
                     :: [Char] ~# Any (* -> *) ()))
            ipv2_Xmg)
         `cast` ((# <State# RealWorld>,
                    <Int#>,
                    UnsafeCo (Any (* -> *) ()) (Ticket [Char]) #)
                 :: (# State# RealWorld, Int#, Any (* -> *) () #)
                      ~#
                    (# State# RealWorld, Int#, Ticket [Char] #))
    of _ { (# ipv4_am9, ipv5_ama, _ #) ->
    case ipv5_ama of _ {
      __DEFAULT ->
        ((failIO @ () main2)
         `cast` (<NTCo:IO <()>>
                 :: IO () ~# (State# RealWorld -> (# State# RealWorld, () #))))
          ipv4_am9;
      0 -> (# ipv4_am9, () #)
    }
    }
    }
    }

main :: IO ()
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
main =
  main1
  `cast` (Sym <(NTCo:IO <()>)>
          :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ())

main5 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=IF_ARGS [0] 30 0}]
main5 =
  \ (eta_Xh :: State# RealWorld) ->
    runMainIO1
      @ ()
      (main1
       `cast` (Sym <(NTCo:IO <()>)>
               :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ()))
      eta_Xh

main :: IO ()
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
main =
  main5
  `cast` (Sym <(NTCo:IO <()>)>
          :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ())

GHC_782_core.hs

==================== Tidy Core ====================
2014-04-13 01:43:54.456316 UTC

Result size of Tidy Core = {terms: 53, types: 83, coercions: 69}

main2 :: [Char]
[GblId,
 Str=DmdType,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, WorkFree=False, Expandable=False,
         Guidance=IF_ARGS [] 180 0}]
main2 =
  unpackCString#
    "Pattern match failure in do expression at Issue28.hs:10:3-11"#

main3 :: [Char]
[GblId,
 Str=DmdType,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, WorkFree=False, Expandable=False,
         Guidance=IF_ARGS [] 40 0}]
main3 = unpackCString# "hi"#

main1 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType <L,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=IF_ARGS [0] 169 90}]
main1 =
  \ (eta_Xe :: State# RealWorld) ->
    case newMutVar# @ [Char] @ RealWorld main3 eta_Xe
    of _ [Occ=Dead] { (# ipv_aTR, ipv1_aTS #) ->
    case (readMutVar#
            @ Any
            @ Any
            (ipv1_aTS
             `cast` ((MutVar#
                        (UnivCo nominal RealWorld Any)
                        (UnivCo representational [Char] Any))_R
                     :: MutVar# RealWorld [Char] ~# MutVar# Any Any))
            (ipv_aTR
             `cast` ((State# (UnivCo nominal RealWorld Any))_R
                     :: State# RealWorld ~# State# Any)))
         `cast` ((# (State# (UnivCo nominal Any RealWorld))_R, Any_R #)_R
                 :: (# State# Any, Any #) ~# (# State# RealWorld, Any #))
    of _ [Occ=Dead] { (# ipv2_XUb, ipv3_XUd #) ->
    case ipv3_XUd of tick_aQr { __DEFAULT ->
    case unpackCString# "bye"# of new1_aQs { __DEFAULT ->
    case (casMutVar#
            @ Any
            @ Any
            (ipv1_aTS
             `cast` ((MutVar#
                        (UnivCo nominal RealWorld Any)
                        (UnivCo representational [Char] Any))_R
                     :: MutVar# RealWorld [Char] ~# MutVar# Any Any))
            (tick_aQr `cast` (Any_R :: Any ~# Any))
            (new1_aQs
             `cast` (UnivCo representational [] Any (UnivCo nominal Char [Char]
                                                     ; UnivCo nominal (* -> *) *)
                     :: [Char] ~# Any *))
            (ipv2_XUb
             `cast` ((State# (UnivCo nominal RealWorld Any))_R
                     :: State# RealWorld ~# State# Any)))
         `cast` ((# (State# (UnivCo nominal Any RealWorld))_R,
                    <Int#>_R,
                    Any_R #)_R
                 :: (# State# Any, Int#, Any #)
                      ~#
                    (# State# RealWorld, Int#, Any #))
    of _ [Occ=Dead] { (# ipv4_aQz, ipv5_aQA, ipv6_aQB #) ->
    case ==# ipv5_aQA 0 of _ [Occ=Dead] {
      __DEFAULT -> (# ipv4_aQz, () #);
      0 ->
        ((failIO @ () main2)
         `cast` (NTCo:IO[0] <()>_R
                 :: IO () ~# (State# RealWorld -> (# State# RealWorld, () #))))
          ipv4_aQz
    }
    }
    }
    }
    }
    }

main :: IO ()
[GblId,
 Arity=1,
 Str=DmdType <L,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
main =
  main1
  `cast` (Sym (NTCo:IO[0] <()>_R)
          :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ())

main4 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType <L,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
main4 =
  \ (eta_Xh :: State# RealWorld) ->
    runMainIO1
      @ ()
      (main1
       `cast` (Sym (NTCo:IO[0] <()>_R)
               :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ()))
      eta_Xh

main :: IO ()
[GblId,
 Arity=1,
 Str=DmdType <L,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
main =
  main4
  `cast` (Sym (NTCo:IO[0] <()>_R)
          :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ())