Commit 8bcf8238 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 19ef492a
......@@ -1184,7 +1184,11 @@ tryEtaReducePrep bndrs expr@(App _ _)
ok _ _ = False
-- We can't eta reduce something which must be saturated.
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
-- 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
......
{-# 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 ()
......@@ -331,3 +331,4 @@ test('T16978', normal, compile, ['-O'])
test('T16978A', normal, compile, ['-O'])
test('T16979a', normal, compile, ['-O'])
test('T16979b', normal, compile, ['-O'])
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