Skip to content

Redundant duplicate case in optimized core

Take this example code:

{-# LANGUAGE MultiWayIf #-}
import System.Environment

data Input = A | B | C | D | E deriving (Eq, Read)

main = do
  x : _ <- getArgs
  if | read x == A -> print "Hello"
     | read x == B -> print "This"
     | read x == C -> print "Is"
     | read x == D -> print "A"
     | otherwise   -> print "Test"

It produces the following suboptimal:

main1
  = \ s_a2ki ->
      case ((allocaBytesAligned
               $fStorableBool7 $fStorableBool7 (getArgs1 `cast` <Co:7>))
            `cast` <Co:3>)
             s_a2ki
      of
      { (# ipv_a2kk, ipv1_a2kl #) ->
      case ipv1_a2kl of {
        [] -> raiseIO# main19 ipv_a2kk;
        : x_a1bk ds_d2i2 ->
          case readEither8 (run main18 x_a1bk) of {
            [] -> case main17 of wild2_00 { };
            : x1_a2PE ds2_a2PF ->
              case ds2_a2PF of {
                [] ->
                  join {
                    $j_s2RB
                      = case x1_a2PE of {
                          __DEFAULT ->
                            ((hPutStr' stdout main14 True) `cast` <Co:2>) ipv_a2kk;
                          B -> ((hPutStr' stdout main11 True) `cast` <Co:2>) ipv_a2kk;
                          C -> ((hPutStr' stdout main8 True) `cast` <Co:2>) ipv_a2kk;
                          D -> ((hPutStr' stdout main6 True) `cast` <Co:2>) ipv_a2kk
                        } } in
                  case x1_a2PE of {
                    A -> ((hPutStr' stdout main3 True) `cast` <Co:2>) ipv_a2kk;
                    B -> jump $j_s2RB;
                    C -> jump $j_s2RB;
                    D -> jump $j_s2RB;
                    E -> jump $j_s2RB
                  };
                : ipv2_a2QF ipv3_a2QG -> case main2 of wild3_00 { }
              }
          }
      }
      }

I would have expected a single case:

                  case x1_a2PE of {
                    A -> ((hPutStr' stdout main3  True) `cast` <Co:2>) ipv_a2kk;
                    B -> ((hPutStr' stdout main11 True) `cast` <Co:2>) ipv_a2kk;
                    C -> ((hPutStr' stdout main8  True) `cast` <Co:2>) ipv_a2kk;
                    D -> ((hPutStr' stdout main6  True) `cast` <Co:2>) ipv_a2kk;
                    E -> ((hPutStr' stdout main14 True) `cast` <Co:2>) ipv_a2kk
                  };

Optional:

  • GHC version: 8.10.7
Edited by Jaro Reinders
To upload designs, you'll need to enable LFS and have an admin enable hashed storage. More information