Zap Call Arity info in the simplifier
authorJoachim Breitner <mail@joachim-breitner.de>
Tue, 28 Mar 2017 20:19:16 +0000 (16:19 -0400)
committerJoachim Breitner <mail@joachim-breitner.de>
Tue, 28 Mar 2017 23:35:31 +0000 (19:35 -0400)
As #13479 shows, there are corner cases where the simplifier decides to
not eta-expand a function as much as its call arity would suggest, but
instead transforms the code that the call arity annotation becomes a
lie.

As the call arity information is only meant to be used by the
immediatelly following simplifier run, it makes sense to simply zap the
information there.

Differential Revision: https://phabricator.haskell.org/D3390

compiler/basicTypes/IdInfo.hs
compiler/simplCore/Simplify.hs

index f29fba7..bd6ec8f 100644 (file)
@@ -29,7 +29,7 @@ module IdInfo (
         -- ** Zapping various forms of Info
         zapLamInfo, zapFragileInfo,
         zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
-        zapTailCallInfo,
+        zapTailCallInfo, zapCallArityInfo,
 
         -- ** The ArityInfo type
         ArityInfo,
@@ -553,6 +553,9 @@ zapTailCallInfo info
         where
           safe_occ = occ { occ_tail = NoTailCallInfo }
 
+zapCallArityInfo :: IdInfo -> IdInfo
+zapCallArityInfo info = setCallArityInfo info 0
+
 {-
 ************************************************************************
 *                                                                      *
index 1b89f3e..43006f8 100644 (file)
@@ -803,7 +803,12 @@ completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs
                   | otherwise
                   = info2
 
-            final_id = new_bndr `setIdInfo` info3
+              -- Zap call arity info. We have used it by now (via
+              -- `tryEtaExpandRhs`), and the simplifier can invalidate this
+              -- information, leading to broken code later (e.g. #13479)
+            info4 = zapCallArityInfo info3
+
+            final_id = new_bndr `setIdInfo` info4
 
       ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
         return (addNonRec env final_id final_rhs) } }