Costs of laziness: Compiling a simple strict function over maybes

__OrigProg.hs

{-# LANGUAGE BangPatterns #-}
module Main where

{- Here we look at what happens to the caling conventions when a strictness 
   annotation is added. Is the body of `foo` able to assume the argument is 
   already in WHNF (caller-enforces the !x) or must the body of `foo` do the work 
   (callee-enforces !x)?
   
   Based on the generated STG and CMM code, it seems that the latter is 
   currently the case.
-}

{-# NOINLINE foo #-}
foo :: Maybe Int -> Int
foo !x =
  case x of
   Just y -> y

main :: IO ()
main = print (foo (Just 3))

_OptimizedCMM.c

// RRN: Below is the body of foo.  Here I believe it should
// be possible to omit everything before the "c3aO" label,
// IFF foo can assume its argument is already in WHNF.

==================== Optimised Cmm ====================
2015-10-23 00:34:34.031857 UTC

foo_entry() //  [R2]
        { [(c3aO,
            block_c3aO_info:
                const S3aD_srt-block_c3aO_info+8;
                const 0;
                const 4294967328;),
           (c3aY,
            foo_info:
                const S3aD_srt-foo_info+8;
                const 4294967301;
                const 0;
                const 12884901903;)]
        }
    {offset
      c3aY:
          if ((Sp + -8) < SpLim) goto c3aZ; else goto c3b0;
      c3aZ:
          // nop
          R1 = PicBaseReg + foo_closure;
          call (I64[BaseReg - 8])(R2, R1) args: 8, res: 0, upd: 8;
      c3b0:
          I64[Sp - 8] = PicBaseReg + block_c3aO_info;
          R1 = R2;
          Sp = Sp - 8;
          if (R1 & 7 != 0) goto c3aO; else goto c3aP;
      c3aP:
          call (I64[R1])(R1) returns to c3aO, args: 8, res: 8, upd: 8;
      c3aO:
          if (R1 & 7 >= 2) goto c3aW; else goto c3aX;
      c3aW:
          R1 = P64[R1 + 6] & (-8);
          Sp = Sp + 8;
          call (I64[R1])(R1) args: 8, res: 0, upd: 8;
      c3aX:
          R1 = PicBaseReg + lvl_r39S_closure;
          Sp = Sp + 8;
          call (I64[R1])(R1) args: 8, res: 0, upd: 8;
    }
}

CoreSimpl.hs

==================== Tidy Core ====================
2015-10-23 00:34:33.918129 UTC

Result size of Tidy Core = {terms: 45, types: 45, coercions: 9}

lvl_r39S :: Int
[GblId, Str=DmdType b]
lvl_r39S = patError @ Int "CostOfLaziness.hs:(9,3)-(10,14)|case"#

foo [InlPrag=NOINLINE] :: Maybe Int -> Int
[GblId, Arity=1, Str=DmdType <S,1*U>]
foo =
  \ (x_amZ :: Maybe Int) ->
    case x_amZ of _ [Occ=Dead] {
      Nothing -> lvl_r39S;
      Just y_an0 -> y_an0
    }

main4 :: Int
[GblId,
 Caf=NoCafRefs,
 Str=DmdType,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
main4 = I# 3

main3 :: Maybe Int
[GblId,
 Caf=NoCafRefs,
 Str=DmdType,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
main3 = Just @ Int main4

main2 :: String
[GblId,
 Str=DmdType,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 90 30}]
main2 =
  case foo main3 of _ [Occ=Dead] { I# ww3_a38B ->
  case $wshowSignedInt 0 ww3_a38B ([] @ Char)
  of _ [Occ=Dead] { (# ww5_a38F, ww6_a38G #) ->
  : @ Char ww5_a38F ww6_a38G
  }
  }

main1 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType <L,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 40 0}]
main1 =
  \ (eta_aRQ [OS=OneShot] :: State# RealWorld) ->
    hPutStr2 stdout main2 True eta_aRQ

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

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

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

STG.hs

==================== STG syntax: ====================
2015-10-23 00:34:33.935719 UTC

lvl_r39S :: Int
[GblId, Str=DmdType b] =
    \u srt:SRT:[0e :-> patError] []
        patError "CostOfLaziness.hs:(9,3)-(10,14)|case"#;
foo [InlPrag=NOINLINE] :: Maybe Int -> Int
[GblId, Arity=1, Str=DmdType <S,1*U>, Unf=OtherCon []] =
    \r srt:SRT:[r39S :-> lvl_r39S] [x_s3a1]
        case x_s3a1 of _ [Occ=Dead] {
          Nothing -> lvl_r39S;
          Just y_s3a3 [Occ=Once] -> y_s3a3;
        };
main4 :: Int
[GblId, Caf=NoCafRefs, Str=DmdType, Unf=OtherCon []] =
    NO_CCS I#! [3];
main3 :: Maybe Int
[GblId, Caf=NoCafRefs, Str=DmdType, Unf=OtherCon []] =
    NO_CCS Just! [main4];
main2 :: String
[GblId, Str=DmdType] =
    \u srt:SRT:[rkj :-> foo] []
        case foo main3 of _ [Occ=Dead] {
          I# ww3_s3a5 [Occ=Once] ->
              case $wshowSignedInt 0 ww3_s3a5 [] of _ [Occ=Dead] {
                (#,#) ww5_s3a7 [Occ=Once] ww6_s3a8 [Occ=Once] ->
                    : [ww5_s3a7 ww6_s3a8];
              };
        };
main1 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId, Arity=1, Str=DmdType <L,U>, Unf=OtherCon []] =
    \r srt:SRT:[rnK :-> hPutStr2, roT :-> stdout,
                r39O :-> main2] [eta_s3a9]
        hPutStr2 stdout main2 True eta_s3a9;
main :: IO ()
[GblId, Arity=1, Str=DmdType <L,U>, Unf=OtherCon []] =
    \r srt:SRT:[r38i :-> main1] [eta_B1] main1 eta_B1;
main5 :: State# RealWorld -> (# State# RealWorld, () #)
[GblId, Arity=1, Str=DmdType, Unf=OtherCon []] =
    \r srt:SRT:[rJG :-> runMainIO1, r38i :-> main1] [eta_B1]
        runMainIO1 main1 eta_B1;
main :: IO ()
[GblId, Arity=1, Str=DmdType, Unf=OtherCon []] =
    \r srt:SRT:[r39R :-> main5] [eta_B1] main5 eta_B1;