+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr )

+  -- When we run out of demands, it means that the call is definitely bottom.

+  -- See (TC2) in Note [Trimming the continuation for bottoming functions]

+  = rebuild env (argInfoExpr fun rev_args) (mkBottomCont env cont)

+    -- NOTE(mangoiv): the env passed to mkBottomCont is only relevant for its static part

+    -- and should not be looked at whatsoever, which is why it should be fine to pass it

+    -- this way. The reason why we deviate from the original patch is that it was done

+    -- after a significant refactor we cannot backport.

+    -- The original patch should be included in `master` as 4a645683ee0bd4421a88cd6ec49b40c6046b041d

+

+Note [Trimming the continuation for bottoming functions]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+Suppose

+   f :: Int -> Int -> Int

+   f x = error "urk"

+

+   foo = f 3 4

+

+f's demand signature say "after one arg I return bottom".  We can drop

+the remaining arguments, thus

+

+   foo = case f 3 of {}

+

+This trimming can also be done with other continuations:

+   * case (error "hello") of { ... }

+   * f (error "Hello") where f is strict

+   etc

+

+We implement the trimming in three parts:

+

+(TC1) In `mkArgInfo`, for a bottoming function, we make a list of `RemainingArgDmds`

+  with a finite list of elements (in the example above, just one).

+

+  For comparison, note that, for non-bottoming functions, the `RemainingArgDmds`

+  always finishes with an infinite list of `topDmd`.

+

+(TC2) In `rebuildCall`, when we run out of `RemainingArgDmds` we discard the

+  remaining continuation.

+

+  After discarding the continuation, the types might not match, in which case

+  we leave behind a (case <hole> of {}) wrapper.  See the call to `mkBottomCont`.

+

+(TC3) In `mkDupableContWithDmds`, we similarly discard the continuation when

+  we run out of `RemainingArgDmds`.

+mkDupableContWithDmds env (dmd : cont_dmds)

+    do  { (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont

+mkDupableContWithDmds env dmds cont

+  -- No more demands => function is definitely bottom

+  --                 => simply trim the continuation

+  -- c.f. the null-demands case in `rebuildCall`

+  -- See (TC3) in Note [Trimming the continuation for bottoming functions]

+  | [] <- dmds = return (emptyFloats env, mkBottomCont env cont)

+        contIsTrivial, contArgs, contIsRhs, mkBottomCont,

+import GHC.Core.TyCo.Compare (eqTypeIgnoringMultiplicity)

+import GHC.Core.Make (mkWildValBinder)

+-------------------

+contStop :: SimplCont -> SimplCont

+-- ^ Get the 'Stop' at the tail of the continuation

+--

+-- Always returns a continuation of form @(Stop ...)@.

+contStop stop@(Stop {})               = stop

+contStop (CastIt { sc_cont = k })     = contStop k

+contStop (StrictBind { sc_cont = k }) = contStop k

+contStop (StrictArg { sc_cont = k })  = contStop k

+contStop (Select { sc_cont = k })     = contStop k

+contStop (ApplyToTy  { sc_cont = k }) = contStop k

+contStop (ApplyToVal { sc_cont = k }) = contStop k

+contStop (TickIt _ k)                 = contStop k

+

+-------------------

+mkBottomCont ::StaticEnv -> SimplCont -> SimplCont

+-- ^ Given a continuation `cont`, return a `cont` /of the same type/,

+-- looking like @(case \<hole\> of {})@.

+--

+-- This is used when we are going to fill in the @<hole>@ with bottom.

+-- See (TC2,3) in Note [Trimming the continuation for bottoming functions]

+--

+-- Don't bother to trim, making a @case <hole> of {}@, if we have only

+-- an essentially-trivial continuation; e.g. @(<hole> \@ty |> co)@.

+mkBottomCont se cont = go cont

+  where

+    go k@(Stop {})                    = k

+    go (TickIt t k')                  = TickIt t (go k')

+    go k@(CastIt    { sc_cont = k' }) = k { sc_cont = go k' }

+    go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' }

+    go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k  -- Optimisation only

+    go k | Stop res_ty _ _ <- stop_cont

+         , hole_ty `eqTypeIgnoringMultiplicity` res_ty

+         = stop_cont

+         | otherwise

+         = Select { sc_alts = []

+                  , sc_bndr = mkWildValBinder OneTy hole_ty

+                  , sc_dup  = OkToDup

+                  , sc_env  = se

+                  , sc_cont = stop_cont }

+         where

+           hole_ty   = contHoleType k

+           stop_cont = contStop k

+

+

+{-# OPTIONS_GHC -fno-full-laziness #-}

+

+module T27261 (foo) where

+

+import T27261_aux (myError)

+

+foo :: [String] -> (() -> Int) -> Int

+foo cs =

+  \ k -> ( case bar of

+             Just str -> let cs2 = case cs of { [] -> cs; _ -> "stack entry" : cs }

+                         in myError cs2 str

+             Nothing -> \ c -> c () )

+         ( \ _ -> k () )

+

+bar :: Maybe String

+bar = Nothing

+{-# NOINLINE bar #-}

+{-# LANGUAGE BangPatterns #-}

+

+module T27261_aux (myError) where

+

+myError :: [String] -> String -> a

+myError !_ _ = undefined

+{-# NOINLINE myError #-}

+test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O'])