Commit 61fe6c68 authored by Abigail's avatar Abigail Committed by Ben Gamari

Take care to not eta-reduce jumps in CorePrep

CorePrep already had a check to prevent it from eta-reducing Ids that
respond true to hasNoBinding (foreign calls, constructors for unboxed
sums and products, and Ids with compulsory unfoldings). It did not,
however, consider join points as ids that 'must be saturated'.

Checking whether the Id responds True to 'isJoinId' should prevent
CorePrep from turning saturated jumps like the following (from #17429)
into undersaturated ones:

      (\ eta_XP ->
         join { mapped_s1vo _ = lvl_s1vs } in jump mapped_s1vo eta_XP)

(cherry picked from commit de6bbdf2)
parent f3560a3a
......@@ -1180,8 +1180,12 @@ tryEtaReducePrep bndrs expr@(App _ _)
ok bndr (Var arg) = bndr == arg
ok _ _ = False
-- We can't eta reduce something which must be saturated.
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
-- We can't eta reduce something which must be saturated.
-- This includes binds which have no binding (respond True to
-- hasNoBinding) and join points (responds True to isJoinId)
-- Eta-reducing join points led to #17429.
ok_to_eta_reduce (Var f) =
not (isJoinId f) && not (hasNoBinding f)
ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
......
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T17429
( zoomAcceptor
) where
type Zoom m = ( m ~ Emitter Int )
zoomAcceptor :: Zoom m => Emitter w a -> m w
zoomAcceptor = fmap id . zoomEmitter
zoomEmitter :: Emitter w a -> Emitter b w
zoomEmitter (Emitter go) =
Emitter $ const ([], fst $ go ())
newtype Emitter w a = Emitter (() -> ([w], [a]))
instance Functor (Emitter w) where
fmap f (Emitter go) = Emitter mapped
where
{-# INLINE mapped #-}
mapped _ = fmap f <$> go ()
......@@ -311,3 +311,4 @@ test('T17140',
test('T17409',
normal,
makefile_test, ['T17409'])
test('T17429', normal, compile, ['-dcore-lint -O2'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment