Stop the specialiser generating loopy code

This patch fixes a bad bug in the specialiser, which showed up as
Trac #13429.  When specialising an imported DFun, the specialiser could
generate a recusive loop where none existed in the original program.

It's all rather tricky, and I've documented it at some length in
   Note [Avoiding loops]

We'd encoutered exactly this before (Trac #3591) but I had failed
to realise that the very same thing could happen for /imported/
DFuns.

I did quite a bit of refactoring.

The compiler seems to get a tiny bit faster on
   deriving/perf/T10858
but almost all the gain had occurred before now; this
patch just pushed it over the line.

11 files changed, 700 insertions, 289 deletions

diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index 66301a5290..a1ee94c59e 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -17,18 +17,21 @@ import Coercion( Coercion )
 import CoreMonad
 import qualified CoreSubst
 import CoreUnfold
+import Var              ( isLocalVar )
 import VarSet
 import VarEnv
 import CoreSyn
 import Rules
 import CoreOpt          ( collectBindersPushingCo )
 import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )
-import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList )
+import CoreFVs
+import FV               ( InterestingVarFun )
 import CoreArity        ( etaExpandToJoinPointRule )
 import UniqSupply
 import Name
 import MkId             ( voidArgId, voidPrimId )
 import Maybes           ( catMaybes, isJust )
+import MonadUtils       ( foldlM )
 import BasicTypes
 import HscTypes
 import Bag
@@ -38,7 +41,6 @@ import Outputable
 import FastString
 import State
 import UniqDFM
-import TrieMap
 
 import Control.Monad
 #if __GLASGOW_HASKELL__ > 710
@@ -585,16 +587,11 @@ specProgram guts@(ModGuts { mg_module = this_mod
        ; hpt_rules <- getRuleBase
        ; let rule_base = extendRuleBaseList hpt_rules local_rules
        ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet
-                                                [] rule_base (ud_calls uds)
-
-             -- Don't forget to wrap the specialized bindings with bindings
-             -- for the needed dictionaries.
-             -- See Note [Wrap bindings returned by specImports]
-       ; let spec_binds' = wrapDictBinds (ud_binds uds) spec_binds
+                                                [] rule_base uds
 
        ; let final_binds
-               | null spec_binds' = binds'
-               | otherwise        = Rec (flattenBinds spec_binds') : binds'
+               | null spec_binds = binds'
+               | otherwise       = Rec (flattenBinds spec_binds) : binds'
                    -- Note [Glom the bindings if imported functions are specialised]
 
        ; return (guts { mg_binds = final_binds
@@ -644,26 +641,41 @@ specImports :: DynFlags
             -> [Id]             -- Stack of imported functions being specialised
             -> RuleBase         -- Rules from this module and the home package
                                 -- (but not external packages, which can change)
-            -> CallDetails      -- Calls for imported things, and floating bindings
+            -> UsageDetails     -- Calls for imported things, and floating bindings
             -> CoreM ( [CoreRule]   -- New rules
                      , [CoreBind] ) -- Specialised bindings
                                     -- See Note [Wrapping bindings returned by specImports]
-specImports dflags this_mod top_env done callers rule_base cds
+specImports dflags this_mod top_env done callers rule_base
+            (MkUD { ud_binds = dict_binds, ud_calls = calls })
   -- See Note [Disabling cross-module specialisation]
-  | not $ gopt Opt_CrossModuleSpecialise dflags =
-    return ([], [])
+  | not $ gopt Opt_CrossModuleSpecialise dflags
+  = return ([], [])
 
-  | otherwise =
-    do { let import_calls = dVarEnvElts cds
+  | otherwise
+  = do { let import_calls = dVarEnvElts calls
        ; (rules, spec_binds) <- go rule_base import_calls
-       ; return (rules, spec_binds) }
+
+             -- Don't forget to wrap the specialized bindings with
+             -- bindings for the needed dictionaries.
+             -- See Note [Wrap bindings returned by specImports]
+       ; let spec_binds' = wrapDictBinds dict_binds spec_binds
+
+       ; return (rules, spec_binds') }
   where
     go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
     go _ [] = return ([], [])
-    go rb (cis@(CIS fn _calls_for_fn) : other_calls)
-      = do { (rules1, spec_binds1) <- specImport dflags this_mod top_env
-                                                 done callers rb fn $
-                                      ciSetToList cis
+    go rb (cis@(CIS fn _) : other_calls)
+      = do { let ok_calls = filterCalls cis dict_binds
+                     -- Drop calls that (directly or indirectly) refer to fn
+                     -- See Note [Avoiding loops]
+--           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn
+--                                                       , text "calls" <+> ppr cis
+--                                                       , text "ud_binds =" <+> ppr dict_binds
+--                                                       , text "dump set =" <+> ppr dump_set
+--                                                       , text "filtered calls =" <+> ppr ok_calls ])
+           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env
+                                                 done callers rb fn ok_calls
+
            ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
 
@@ -698,9 +710,10 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn
        ; let full_rb = unionRuleBase rb (eps_rule_base eps)
              rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn
 
-       ; (rules1, spec_pairs, uds) <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $
-                                      runSpecM dflags this_mod $
-              specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs
+       ; (rules1, spec_pairs, uds)
+             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $
+                runSpecM dflags this_mod $
+                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs
        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
              -- After the rules kick in we may get recursion, but
              -- we rely on a global GlomBinds to sort that out later
@@ -712,13 +725,9 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn
                                               (extendVarSet done fn)
                                               (fn:callers)
                                               (extendRuleBaseList rb rules1)
-                                              (ud_calls uds)
+                                              uds
 
-             -- Don't forget to wrap the specialized bindings with bindings
-             -- for the needed dictionaries
-             -- See Note [Wrap bindings returned by specImports]
-       ; let final_binds = wrapDictBinds (ud_binds uds)
-                                         (spec_binds2 ++ spec_binds1)
+       ; let final_binds = spec_binds2 ++ spec_binds1
 
        ; return (rules2 ++ rules1, final_binds) }
 
@@ -1043,24 +1052,24 @@ specBind rhs_env (NonRec fn rhs) body_uds
                         -- so put the latter first
 
              combined_uds = body_uds1 `plusUDs` rhs_uds
-                -- This way round a call in rhs_uds of a function f
-                -- at type T will override a call of f at T in body_uds1; and
-                -- that is good because it'll tend to keep "earlier" calls
-                -- See Note [Specialisation of dictionary functions]
 
              (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
-                -- See Note [From non-recursive to recursive]
 
              final_binds :: [DictBind]
+             -- See Note [From non-recursive to recursive]
              final_binds
-               | isEmptyBag dump_dbs = [mkDB $ NonRec b r | (b,r) <- pairs]
-               | otherwise = [flattenDictBinds dump_dbs pairs]
+               | not (isEmptyBag dump_dbs)
+               , not (null spec_defns)
+               = [recWithDumpedDicts pairs dump_dbs]
+               | otherwise
+               = [mkDB $ NonRec b r | (b,r) <- pairs]
+                 ++ bagToList dump_dbs
 
-         ; if float_all then
+       ; if float_all then
              -- Rather than discard the calls mentioning the bound variables
-             -- we float this binding along with the others
+             -- we float this (dictionary) binding along with the others
               return ([], free_uds `snocDictBinds` final_binds)
-           else
+         else
              -- No call in final_uds mentions bound variables,
              -- so we can just leave the binding here
               return (map fst final_binds, free_uds) }
@@ -1084,13 +1093,13 @@ specBind rhs_env (Rec pairs) body_uds
                         ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }
 
        ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3
-             bind = flattenDictBinds dumped_dbs
-                                     (spec_defns3 ++ zip bndrs3 rhss')
+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')
+                                             dumped_dbs
 
        ; if float_all then
-              return ([], final_uds `snocDictBind` bind)
-           else
-              return ([fst bind], final_uds) }
+              return ([], final_uds `snocDictBind` final_bind)
+         else
+              return ([fst final_bind], final_uds) }
 
 
 ---------------------------
@@ -1141,18 +1150,20 @@ specDefn env body_uds fn rhs
 specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn
                                -- Nothing        =>  specialising local fn
           -> SpecEnv
-          -> [CoreRule]                 -- Existing RULES for the fn
+          -> [CoreRule]        -- Existing RULES for the fn
           -> [CallInfo]
           -> OutId -> InExpr
-          -> SpecM ([CoreRule],         -- New RULES for the fn
-                    [(Id,CoreExpr)],    -- Extra, specialised bindings
-                    UsageDetails)       -- New usage details from the specialised RHSs
+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details
 
 -- This function checks existing rules, and does not create
 -- duplicate ones. So the caller does not need to do this filtering.
 -- See 'already_covered'
 
-specCalls mb_mod env rules_for_me calls_for_me fn rhs
+type SpecInfo = ( [CoreRule]       -- Specialisation rules
+                , [(Id,CoreExpr)]  -- Specialised definition
+                , UsageDetails )   -- Usage details from specialised RHSs
+
+specCalls mb_mod env existing_rules calls_for_me fn rhs
         -- The first case is the interesting one
   |  rhs_tyvars `lengthIs`      n_tyvars -- Rhs of fn's defn has right number of big lambdas
   && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args
@@ -1165,10 +1176,8 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
 --      See Note [Inline specialisation] for why we do not
 --      switch off specialisation for inline functions
 
-  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $
-    do { stuff <- mapM spec_call calls_for_me
-       ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff)
-       ; return (spec_rules, spec_defns, plusUDList spec_uds) }
+  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
+    foldlM spec_call ([], [], emptyUDs) calls_for_me
 
   | otherwise   -- No calls or RHS doesn't fit our preconceptions
   = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,
@@ -1202,12 +1211,15 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
     body                       = mkLams rhs_bndrs2 rhs_body
                                  -- Glue back on the non-dict lambdas
 
-    already_covered :: DynFlags -> [CoreExpr] -> Bool
-    already_covered dflags args      -- Note [Specialisations already covered]
-       = isJust (lookupRule dflags
-                            (CoreSubst.substInScope (se_subst env), realIdUnfolding)
-                            (const True)
-                            fn args rules_for_me)
+    in_scope = CoreSubst.substInScope (se_subst env)
+
+    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool
+    already_covered dflags new_rules args      -- Note [Specialisations already covered]
+       = isJust (lookupRule dflags (in_scope, realIdUnfolding)
+                            (const True) fn args
+                            (new_rules ++ existing_rules))
+         -- NB: we look both in the new_rules (generated by this invocation
+         --     of specCalls), and in existing_rules (passed in to specCalls)
 
     mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
     mk_ty_args [] poly_tvs
@@ -1220,11 +1232,11 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
 
     ----------------------------------------------------------
         -- Specialise to one particular call pattern
-    spec_call :: CallInfo                         -- Call instance
-              -> SpecM (Maybe ((Id,CoreExpr),     -- Specialised definition
-                               UsageDetails,      -- Usage details from specialised body
-                               CoreRule))         -- Info for the Id's SpecEnv
-    spec_call (CI { ci_key = CallKey call_ts, ci_args = call_ds })
+    spec_call :: SpecInfo                         -- Accumulating parameter
+              -> CallInfo                         -- Call instance
+              -> SpecM SpecInfo
+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)
+              (CI { ci_key = CallKey call_ts, ci_args = call_ds })
       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
 
         -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
@@ -1263,8 +1275,8 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
                  rule_bndrs = poly_tyvars ++ ev_bndrs
 
            ; dflags <- getDynFlags
-           ; if already_covered dflags rule_args then
-                return Nothing
+           ; if already_covered dflags rules_acc rule_args
+             then return spec_acc
              else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids
                   --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)
                   --                           , ppr dx_binds ]) $
@@ -1313,14 +1325,14 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
                                   rule_args
                                   (mkVarApps (Var spec_f) app_args)
 
-                spec_env_rule
+                spec_rule
                   = case isJoinId_maybe fn of
                       Just join_arity -> etaExpandToJoinPointRule join_arity
                                                                   rule_wout_eta
                       Nothing -> rule_wout_eta
 
                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
-                final_uds = foldr consDictBind rhs_uds dx_binds
+                spec_uds = foldr consDictBind rhs_uds dx_binds
 
                 --------------------------------------
                 -- Add a suitable unfolding if the spec_inl_prag says so
@@ -1350,7 +1362,10 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
                                         `setIdUnfolding`  spec_unf
                                         `asJoinId_maybe`  spec_join_arity
 
-           ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } }
+           ; return ( spec_rule                  : rules_acc
+                    , (spec_f_w_arity, spec_rhs) : pairs_acc
+                    , spec_uds           `plusUDs` uds_acc
+                    ) } }
 
 {- Note [Account for casts in binding]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1462,27 +1477,42 @@ Even in the non-recursive case, if any dict-binds depend on 'fn' we might
 have built a recursive knot
 
       f a d x = <blah>
-      MkUD { ud_binds = d7 = MkD ..f..
+      MkUD { ud_binds = NonRec d7  (MkD ..f..)
            , ud_calls = ...(f T d7)... }
 
 The we generate
 
-      Rec { fs x = <blah>[T/a, d7/d]
-            f a d x = <blah>
+     Rec { fs x = <blah>[T/a, d7/d]
+           f a d x = <blah>
                RULE f T _ = fs
-            d7 = ...f... }
+           d7 = ...f... }
 
 Here the recursion is only through the RULE.
 
+However we definitely should /not/ make the Rec in this wildly common
+case:
+      d = ...
+      MkUD { ud_binds = NonRec d7 (...d...)
+           , ud_calls = ...(f T d7)... }
+
+Here we want simply to add d to the floats, giving
+      MkUD { ud_binds = NonRec d (...)
+                        NonRec d7 (...d...)
+           , ud_calls = ...(f T d7)... }
+
+In general, we need only make this Rec if
+  - there are some specialisations (spec_binds non-empty)
+  - there are some dict_binds that depend on f (dump_dbs non-empty)
 
-Note [Specialisation of dictionary functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is a nasty example that bit us badly: see Trac #3591
+Note [Avoiding loops]
+~~~~~~~~~~~~~~~~~~~~~
+When specialising /dictionary functions/ we must be very careful to
+avoid building loops. Here is an example that bit us badly: Trac #3591
 
      class Eq a => C a
      instance Eq [a] => C [a]
 
----------------
+This translates to
      dfun :: Eq [a] -> C [a]
      dfun a d = MkD a d (meth d)
 
@@ -1511,7 +1541,53 @@ placed below 'dfun', and thus unavailable to it when specialising
 discarded.  On the other hand, the call (dfun T d4) is fine, assuming
 d4 doesn't mention dfun.
 
-But look at this:
+Solution:
+  Discard all calls that mention dictionaries that depend
+  (directly or indirectly) on the dfun we are specialising.
+  This is done by 'filterCalls'
+
+--------------
+Here's another example, this time for an imported dfun, so the call
+to filterCalls is in specImports (Trac #13429). Suppose we have
+  class Monoid v => C v a where ...
+
+We start with a call
+   f @ [Integer] @ Integer $fC[]Integer
+
+Specialising call to 'f' gives dict bindings
+   $dMonoid_1 :: Monoid [Integer]
+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer
+
+   $dC_1 :: C [Integer] (Node [Integer] Integer)
+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+
+...plus a recursive call to
+   f @ [Integer] @ (Node [Integer] Integer) $dC_1
+
+Specialising that call gives
+   $dMonoid_2  :: Monoid [Integer]
+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1
+
+   $dC_2 :: C [Integer] (Node [Integer] Integer)
+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2
+
+Now we have two calls to the imported function
+  M.$fCvNode :: Monoid v => C v a
+  M.$fCvNode @v @a m = C m some_fun
+
+But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)
+for specialisation, else we get:
+
+  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1
+  $s$fCvNode = C $dMonoid_2 ...
+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode
+
+Now use the rule to rewrite the call in the RHS of $dC_1
+and we get a loop!
+
+--------------
+Here's yet another example
 
   class C a where { foo,bar :: [a] -> [a] }
 
@@ -1547,11 +1623,6 @@ Note that, because of its RULE, r_bar joins the recursive
 group.  (In this case it'll unravel a short moment later.)
 
 
-Conclusion: we catch the nasty case using filter_dfuns in
-callsForMe. To be honest I'm not 100% certain that this is 100%
-right, but it works.  Sigh.
-
-
 Note [Specialising a recursive group]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1745,29 +1816,56 @@ INLINABLE.  See Trac #4874.
 
 data UsageDetails
   = MkUD {
-        ud_binds :: !(Bag DictBind),
-                        -- Floated dictionary bindings
-                        -- The order is important;
-                        -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
-                        -- (Remember, Bags preserve order in GHC.)
+      ud_binds :: !(Bag DictBind),
+               -- See Note [Floated dictionary bindings]
+               -- The order is important;
+               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+               -- (Remember, Bags preserve order in GHC.)
 
-        ud_calls :: !CallDetails
+      ud_calls :: !CallDetails
 
-        -- INVARIANT: suppose bs = bindersOf ud_binds
-        -- Then 'calls' may *mention* 'bs',
-        -- but there should be no calls *for* bs
+      -- INVARIANT: suppose bs = bindersOf ud_binds
+      -- Then 'calls' may *mention* 'bs',
+      -- but there should be no calls *for* bs
     }
 
+-- | A 'DictBind' is a binding along with a cached set containing its free
+-- variables (both type variables and dictionaries)
+type DictBind = (CoreBind, VarSet)
+
+{- Note [Floated dictionary bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We float out dictionary bindings for the reasons described under
+"Dictionary floating" above.  But not /just/ dictionary bindings.
+Consider
+
+   f :: Eq a => blah
+   f a d = rhs
+
+   $c== :: T -> T -> Bool
+   $c== x y = ...
+
+   $df :: Eq T
+   $df = Eq $c== ...
+
+   gurgle = ...(f @T $df)...
+
+We gather the call info for (f @T $df), and we don't want to drop it
+when we come across the binding for $df.  So we add $df to the floats
+and continue.  But then we have to add $c== to the floats, and so on.
+These all float above the binding for 'f', and and now we can
+successfullly specialise 'f'.
+
+So the DictBinds in (ud_binds :: Bag DictBind) may contain
+non-dictionary bindings too.
+-}
+
 instance Outputable UsageDetails where
   ppr (MkUD { ud_binds = dbs, ud_calls = calls })
         = text "MkUD" <+> braces (sep (punctuate comma
                 [text "binds" <+> equals <+> ppr dbs,
                  text "calls" <+> equals <+> ppr calls]))
 
--- | A 'DictBind' is a binding along with a cached set containing its free
--- variables (both type variables and dictionaries)
-type DictBind = (CoreBind, VarSet)
-
 emptyUDs :: UsageDetails
 emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }
 
@@ -1780,6 +1878,8 @@ type CallDetails  = DIdEnv CallInfoSet
 data CallInfoSet = CIS Id (Bag CallInfo)
   -- The list of types and dictionaries is guaranteed to
   -- match the type of f
+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)
+  -- These dups are eliminated by already_covered in specCalls
 
 data CallInfo
   = CI { ci_key  :: CallKey     -- Type arguments
@@ -1794,58 +1894,6 @@ newtype CallKey   = CallKey [Maybe Type]
 
 type DictExpr = CoreExpr
 
-
-{-
-Note [CallInfoSet determinism]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-CallInfoSet holds a Bag of (CallKey, [DictExpr], VarSet) triplets for a given
-Id. They represent the types that the function is instantiated at along with
-the dictionaries and free variables.
-
-We use this information to generate specialized versions of a given function.
-CallInfoSet used to be defined as:
-
-  data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet))
-
-Unfortunately this was not deterministic. The Ord instance of CallKey was
-defined in terms of nonDetCmpType which is not deterministic.
-See Note [nonDetCmpType nondeterminism].
-The end result was that if the function had multiple specializations they would
-be generated in arbitrary order.
-
-We need a container that:
-a) when turned into a list has only one element per each CallKey and the list
-has deterministic order
-b) supports union
-c) supports singleton
-d) supports filter
-
-We can't use UniqDFM here because there's no one Unique that we can key on.
-
-The current approach is to implement the set as a Bag with duplicates.
-This makes b), c), d) trivial and pushes a) towards the end. The deduplication
-is done by using a TrieMap for membership tests on CallKey. This lets us delete
-the nondeterministic Ord CallKey instance.
-
-An alternative approach would be to augment the Map the same way that UniqDFM
-is augmented, by keeping track of insertion order and using it to order the
-resulting lists. It would mean keeping the nondeterministic Ord CallKey
-instance making it easy to reintroduce nondeterminism in the future.
--}
-
-ciSetToList :: CallInfoSet -> [CallInfo]
-ciSetToList (CIS _ b) = snd $ foldrBag combine (emptyTM, []) b
-  where
-  -- This is where we eliminate duplicates, recording the CallKeys we've
-  -- already seen in the TrieMap. See Note [CallInfoSet determinism].
-  combine :: CallInfo -> (CallKeySet, [CallInfo]) -> (CallKeySet, [CallInfo])
-  combine ci@(CI { ci_key = CallKey key }) (set, acc)
-    | Just _ <- lookupTM key set = (set, acc)
-    | otherwise = (insertTM key () set, ci:acc)
-
-type CallKeySet = ListMap (MaybeMap TypeMap) ()
-  -- We only use it in ciSetToList to check for membership
-
 ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
 ciSetFilter p (CIS id a) = CIS id (filterBag p a)
 
@@ -2036,9 +2084,6 @@ plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
   = MkUD { ud_binds = db1    `unionBags`   db2
          , ud_calls = calls1 `unionCalls`  calls2 }
 
-plusUDList :: [UsageDetails] -> UsageDetails
-plusUDList = foldr plusUDs emptyUDs
-
 -----------------------------
 _dictBindBndrs :: Bag DictBind -> [Id]
 _dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
@@ -2056,17 +2101,28 @@ bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
                              rhs_fvs = unionVarSets (map pair_fvs prs)
 
 pair_fvs :: (Id, CoreExpr) -> VarSet
-pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
-        -- Don't forget variables mentioned in the
-        -- rules of the bndr.  C.f. OccAnal.addRuleUsage
-        -- Also tyvars mentioned in its type; they may not appear in the RHS
+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
+                       `unionVarSet` idFreeVars bndr
+        -- idFreeVars: don't forget variables mentioned in
+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage
+        -- Also tyvars mentioned in its type; they may not appear
+        -- in the RHS
         --      type T a = Int
         --      x :: T a = 3
-
--- | Flatten a set of 'DictBind's and some other binding pairs into a single
--- recursive binding, including some additional bindings.
-flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> DictBind
-flattenDictBinds dbs pairs
+  where
+    interesting :: InterestingVarFun
+    interesting v = isLocalVar v || (isId v && isDFunId v)
+        -- Very important: include DFunIds /even/ if it is imported
+        -- Reason: See Note [Avoiding loops], the second exmaple
+        --         involving an imported dfun.  We must know whether
+        --         a dictionary binding depends on an imported dfun,
+        --         in case we try to specialise that imported dfun
+        --         Trac #13429 illustrates
+
+-- | Flatten a set of "dumped" 'DictBind's, and some other binding
+-- pairs, into a single recursive binding.
+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind
+recWithDumpedDicts pairs dbs
   = (Rec bindings, fvs)
   where
     (bindings, fvs) = foldrBag add
@@ -2080,8 +2136,7 @@ flattenDictBinds dbs pairs
 snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
 -- Add ud_binds to the tail end of the bindings in uds
 snocDictBinds uds dbs
-  = uds { ud_binds = ud_binds uds `unionBags`
-                     foldr consBag emptyBag dbs }
+  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }
 
 consDictBind :: DictBind -> UsageDetails -> UsageDetails
 consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }
@@ -2120,7 +2175,11 @@ dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
                                                     -- no calls for any of the dicts in dump_dbs
 
 dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
--- Used at a lambda or case binder; just dump anything mentioning the binder
+-- Used at a let(rec) binding.
+-- We return a boolean indicating whether the binding itself is mentioned
+-- is mentioned, directly or indirectly, by any of the ud_calls; in that
+-- case we want to float the binding itself;
+-- See Note [Floated dictionary bindings]
 dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
   = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
     (free_uds, dump_dbs, float_all)
@@ -2145,18 +2204,26 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
                           , ud_calls = delDVarEnv orig_calls fn }
     calls_for_me = case lookupDVarEnv orig_calls fn of
                         Nothing -> []
-                        Just cis -> filter_dfuns (ciSetToList cis)
+                        Just cis -> filterCalls cis orig_dbs
+         -- filterCalls: drop calls that (directly or indirectly)
+         -- refer to fn.  See Note [Avoiding loops]
 
-    dep_set = foldlBag go (unitVarSet fn) orig_dbs
-    go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set
-                        = extendVarSetList dep_set (bindersOf db)
-                        | otherwise = dep_set
+----------------------
+filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
+-- See Note [Avoiding loops]
+filterCalls (CIS fn call_bag) dbs
+  = filter ok_call (bagToList call_bag)
+  where
+    dump_set = foldlBag go (unitVarSet fn) dbs
+      -- This dump-set could also be computed by splitDictBinds
+      --   (_,_,dump_set) = splitDictBinds dbs {fn}
+      -- But this variant is shorter
 
-        -- Note [Specialisation of dictionary functions]
-    filter_dfuns | isDFunId fn = filter ok_call
-                 | otherwise   = \cs -> cs
+    go so_far (db,fvs) | fvs `intersectsVarSet` so_far
+                       = extendVarSetList so_far (bindersOf db)
+                       | otherwise = so_far
 
-    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dep_set)
+    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)
 
 ----------------------
 splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
diff --git a/testsuite/tests/deriving/perf/all.T b/testsuite/tests/deriving/perf/all.T
index a711a50855..240571b4a2 100644
--- a/testsuite/tests/deriving/perf/all.T
+++ b/testsuite/tests/deriving/perf/all.T
@@ -1,11 +1,13 @@
 test('T10858',
      [compiler_stats_num_field('bytes allocated',
-          [(wordsize(64), 241242968, 8) ]),
+          [(wordsize(64), 221895064, 8) ]),
           # Initial:    222312440
           # 2016-12-19  247768192  Join points (#19288)
           # 2017-02-12  304094944  Type-indexed Typeable
           # 2017-02-25  275357824  Early inline patch
           # 2017-03-28  241242968  Run Core Lint less
+          # 2017-06-07  221895064  Apparently been reducing for some time
+          #                        Today it crossed the boundary; good
       only_ways(['normal'])],
      compile,
      ['-O'])
diff --git a/testsuite/tests/simplCore/should_compile/T13429.hs b/testsuite/tests/simplCore/should_compile/T13429.hs
deleted file mode 100644
index cc9b4d20e9..0000000000
--- a/testsuite/tests/simplCore/should_compile/T13429.hs
+++ /dev/null
@@ -1,114 +0,0 @@
-{-# LANGUAGE BangPatterns          #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE UndecidableInstances  #-}
-module Loop (Array(..), Image(..), X, promote, correlate) where
-import           Data.Maybe (fromMaybe)
-
-data Kernel e = Kernel Int Int !(Vector (Int, Int, e)) deriving (Show)
-
-
-toKernel :: Array X e => Image X e -> Kernel e
-toKernel img =
-  Kernel m2 n2 $ filter (\(_, _, x) -> x /= 0) $ imap addIx $ toVector img
-  where
-    (m, n) = dims img
-    (m2, n2) = (m `div` 2, n `div` 2)
-    addIx k (PixelX x) =
-      let (i, j) = toIx n k
-      in (i - m2, j - n2, x)
-
-correlate :: Array cs e => Image X e -> Image cs e -> Image cs e
-correlate kernelImg imgM = makeImage (dims imgM) stencil
-  where
-    !(Kernel kM2 kN2 kernelV) = toKernel kernelImg
-    kLen = length kernelV
-    stencil (i, j) =
-      loop 0 (promote 0) $ \ k acc ->
-        let (iDelta, jDelta, x) = kernelV !! k
-            imgPx = index imgM (i + iDelta, j + jDelta)
-        in liftPx2 (+) acc (liftPx (x *) imgPx)
-    loop init' initAcc f = go init' initAcc
-      where
-        go step acc =
-          if step < kLen
-            then go (step + 1) (f step acc)
-            else acc
-{-# INLINE correlate #-}
-
-
-
--- | A Pixel family with a color space and a precision of elements.
-data family Pixel cs e :: *
-
-
-class (Eq e, Num e) => ColorSpace cs e where
-  promote :: e -> Pixel cs e
-  liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e
-  liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e
-
-
-
-data family Image cs e :: *
-
-class ColorSpace cs e => Array cs e where
-  dims :: Image cs e -> (Int, Int)
-  makeImage :: (Int, Int) -> ((Int, Int) -> Pixel cs e) -> Image cs e
-  toVector :: Image cs e -> Vector (Pixel cs e)
-  index :: Image cs e -> (Int, Int) -> Pixel cs e
-
-fromIx :: Int -> (Int, Int) -> Int
-fromIx n (i, j) = n * i + j
-
-toIx :: Int -> Int -> (Int, Int)
-toIx n k = divMod k n
-
-instance (Show (Pixel cs e), ColorSpace cs e, Array cs e) =>
-         Show (Image cs e) where
-  show img =
-    let (m, n) = dims img
-    in "<Image " ++ show m ++ "x" ++ show n ++ ">: " ++ show (toVector img)
-
-
-data X = X
-
-newtype instance Pixel X e = PixelX e
-
-instance Show e => Show (Pixel X e) where
-  show (PixelX e) = "Pixel: " ++ show e
-
-
-instance (Eq e, Num e) => ColorSpace X e where
-  promote = PixelX
-  liftPx f (PixelX g) = PixelX (f g)
-  liftPx2 f (PixelX g1) (PixelX g2) = PixelX (f g1 g2)
-
-
-data instance Image X e = VImage Int Int (Vector (Pixel X e))
-
-instance ColorSpace X e => Array X e where
-  dims (VImage m n _) = (m, n)
-  makeImage (m, n) f = VImage m n $ generate (m * n) (f . toIx n)
-  toVector (VImage _ _ v) = v
-  index (VImage _ n v) ix = fromMaybe (promote 0) (v !? (fromIx n ix))
-
-
--- Vector emulation
-
-type Vector a = [a]
-
-imap :: (Num a, Enum a) => (a -> b -> c) -> [b] -> [c]
-imap f = zipWith f [0..]
-
-(!?) :: [a] -> Int -> Maybe a
-(!?) ls i
-  | i < 0 || i >= length ls = Nothing
-  | otherwise = Just (ls !! i)
-
-generate :: (Ord t, Num t) => t -> (t -> a) -> [a]
-generate n f = go (n-1) [] where
-  go i acc | i < 0 = acc
-           | otherwise = go (i-1) (f i : acc)
-
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index f4f22b9dc5..b7c8b04c5c 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -253,7 +253,6 @@ test('T13338', only_ways(['optasm']), compile, ['-dcore-lint'])
 test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367'])
 test('T13417', normal, compile, ['-O'])
 test('T13413', normal, compile, [''])
-test('T13429', normal, compile, [''])
 test('T13410', normal, compile, ['-O2'])
 test('T13468',
      normal,
diff --git a/testsuite/tests/simplCore/should_run/T13429.hs b/testsuite/tests/simplCore/should_run/T13429.hs
new file mode 100644
index 0000000000..de918da03f
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13429.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Main (main) where
+
+import T13429a
+
+import Data.Foldable (Foldable(..))
+import Data.Monoid (Monoid(..))
+
+main :: IO ()
+main = print $ prop_mappend z z
+  where
+    z :: Seq Integer
+    z = deep (Four 1 2 3 4) Empty (Four 1 2 3 4)
+
+infix 4 ~=
+
+(~=) :: Eq a => Maybe a -> a -> Bool
+(~=) = maybe (const False) (==)
+
+-- Partial conversion of an output sequence to a list.
+toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]
+toList' xs
+  | valid xs = Just (toList xs)
+  | otherwise = Nothing
+
+prop_mappend :: Seq Integer -> Seq Integer -> Bool
+prop_mappend xs ys =
+    toList' (mappend xs ys) ~= toList xs ++ toList ys
+
+------------------------------------------------------------------------
+-- Valid trees
+------------------------------------------------------------------------
+
+class Valid a where
+    valid :: a -> Bool
+
+instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where
+    valid Empty = True
+    valid (Single x) = valid x
+    valid (Deep s pr m sf) =
+        s == measure pr `mappend` measure m `mappend` measure sf &&
+        valid pr && valid m && valid sf
+
+instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where
+    valid node = measure node == foldMap measure node && all valid node
+
+instance Valid a => Valid (Digit a) where
+    valid = all valid
+
+instance Valid Integer where
+    valid = const True
+
+------------------------------------------------------------------------
+-- Use list of elements as the measure
+------------------------------------------------------------------------
+
+type Seq a = FingerTree [a] a
+
+instance Measured [Integer] Integer where
+    measure x = [x]
diff --git a/testsuite/tests/simplCore/should_run/T13429.stdout b/testsuite/tests/simplCore/should_run/T13429.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13429.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/simplCore/should_run/T13429_2.hs b/testsuite/tests/simplCore/should_run/T13429_2.hs
new file mode 100644
index 0000000000..45b3e9c34d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13429_2.hs
@@ -0,0 +1,10 @@
+-- This one come from lehins, between comment:22 and 23 of Trac #13429
+module Main where
+
+import T13429_2a as Array
+
+arr2 :: Array D Int Int -> Array D Int Int
+arr2 arr = Array.map (*2) arr
+
+main :: IO ()
+main = print $ arr2 $ makeArray 1600 id
diff --git a/testsuite/tests/simplCore/should_run/T13429_2.stdout b/testsuite/tests/simplCore/should_run/T13429_2.stdout
new file mode 100644
index 0000000000..7bc74aee9e
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13429_2.stdout
@@ -0,0 +1 @@
+<Array 1600>
diff --git a/testsuite/tests/simplCore/should_run/T13429_2a.hs b/testsuite/tests/simplCore/should_run/T13429_2a.hs
new file mode 100644
index 0000000000..1accc337c2
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13429_2a.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module T13429_2a where
+
+data D
+
+data Array r ix e = Array { _size :: ix
+                          , _index :: ix -> e }
+
+class Show ix => Index ix
+
+instance Index Int
+
+class Index ix => Massiv r ix e where
+  size :: Array r ix e -> ix
+  makeArray :: ix -> (ix -> e) -> Array r ix e
+  index :: Array r ix e -> ix -> e
+
+
+instance Massiv r ix e => Show (Array r ix e) where
+  show arr = "<Array " ++ show (size arr) ++ ">"
+
+
+instance Index ix => Massiv D ix e where
+  size = _size
+  makeArray = Array
+  index = _index
+
+
+-- | Map a function over an array (restricted return type)
+map :: Massiv r' ix e' => (e' -> e) -> Array r' ix e' -> Array D ix e
+map = mapG
+{-# INLINE map #-}
+
+-- | Map a function over an array (general)
+mapG :: (Massiv r' ix e', Massiv r ix e) => (e' -> e) -> Array r' ix e' -> Array r ix e
+mapG f arr = makeArray (size arr) (f . index arr)
diff --git a/testsuite/tests/simplCore/should_run/T13429a.hs b/testsuite/tests/simplCore/should_run/T13429a.hs
new file mode 100644
index 0000000000..6a838cb79c
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13429a.hs
@@ -0,0 +1,343 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T13429a where -- Orignally FingerTree.hs from the ticket
+
+class (Monoid v) => Measured v a | a -> v where
+    measure :: a -> v
+
+instance (Measured v a) => Measured v (Digit a) where
+    measure = foldMap measure
+
+instance (Monoid v) => Measured v (Node v a) where
+    measure (Node2 v _ _)    =  v
+    measure (Node3 v _ _ _)  =  v
+
+instance (Measured v a) => Measured v (FingerTree v a) where
+    measure Empty           =  mempty
+    measure (Single x)      =  measure x
+    measure (Deep v _ _ _)  =  v
+
+data FingerTree v a
+    = Empty
+    | Single a
+    | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)
+  deriving Show
+
+instance Foldable (FingerTree v) where
+    foldMap _ Empty = mempty
+    foldMap f (Single x) = f x
+    foldMap f (Deep _ pr m sf) =
+        foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf
+
+instance Measured v a => Monoid (FingerTree v a) where
+    mempty = empty
+    mappend = (><)
+
+empty :: Measured v a => FingerTree v a
+empty = Empty
+
+infixr 5 ><
+infixr 5 <|
+infixl 5 |>
+
+(<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a
+a <| Empty              =  Single a
+a <| Single b           =  deep (One a) Empty (One b)
+a <| Deep v (Four b c d e) m sf = m `seq`
+    Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf
+a <| Deep v pr m sf     =
+    Deep (measure a `mappend` v) (consDigit a pr) m sf
+
+consDigit :: a -> Digit a -> Digit a
+consDigit a (One b) = Two a b
+consDigit a (Two b c) = Three a b c
+consDigit a (Three b c d) = Four a b c d
+consDigit _ (Four _ _ _ _) = illegal_argument "consDigit"
+
+(|>) :: (Measured v a) => FingerTree v a -> a -> FingerTree v a
+Empty |> a              =  Single a
+Single a |> b           =  deep (One a) Empty (One b)
+Deep v pr m (Four a b c d) |> e = m `seq`
+    Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e)
+Deep v pr m sf |> x     =
+    Deep (v `mappend` measure x) pr m (snocDigit sf x)
+
+snocDigit :: Digit a -> a -> Digit a
+snocDigit (One a) b = Two a b
+snocDigit (Two a b) c = Three a b c
+snocDigit (Three a b c) d = Four a b c d
+snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit"
+
+(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
+(><) =  appendTree0
+
+appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
+appendTree0 Empty xs =
+    xs
+appendTree0 xs Empty =
+    xs
+appendTree0 (Single x) xs =
+    x <| xs
+appendTree0 xs (Single x) =
+    xs |> x
+appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =
+    deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2
+
+addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits0 m1 (One a) (One b) m2 =
+    appendTree1 m1 (node2 a b) m2
+addDigits0 m1 (One a) (Two b c) m2 =
+    appendTree1 m1 (node3 a b c) m2
+addDigits0 m1 (One a) (Three b c d) m2 =
+    appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (One a) (Four b c d e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Two a b) (One c) m2 =
+    appendTree1 m1 (node3 a b c) m2
+addDigits0 m1 (Two a b) (Two c d) m2 =
+    appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (Two a b) (Three c d e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Two a b) (Four c d e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Three a b c) (One d) m2 =
+    appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (Three a b c) (Two d e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Three a b c) (Three d e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Three a b c) (Four d e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits0 m1 (Four a b c d) (One e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Four a b c d) (Two e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Four a b c d) (Three e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+
+appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a
+appendTree1 Empty a xs =
+    a <| xs
+appendTree1 xs a Empty =
+    xs |> a
+appendTree1 (Single x) a xs =
+    x <| a <| xs
+appendTree1 xs a (Single x) =
+    xs |> a |> x
+appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =
+    deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
+
+addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits1 m1 (One a) b (One c) m2 =
+    appendTree1 m1 (node3 a b c) m2
+addDigits1 m1 (One a) b (Two c d) m2 =
+    appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits1 m1 (One a) b (Three c d e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (One a) b (Four c d e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Two a b) c (One d) m2 =
+    appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits1 m1 (Two a b) c (Two d e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (Two a b) c (Three d e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Two a b) c (Four d e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Three a b c) d (One e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (Three a b c) d (Two e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Three a b c) d (Three e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits1 m1 (Four a b c d) e (One f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Four a b c d) e (Two f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+
+appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a
+appendTree2 Empty a b xs =
+    a <| b <| xs
+appendTree2 xs a b Empty =
+    xs |> a |> b
+appendTree2 (Single x) a b xs =
+    x <| a <| b <| xs
+appendTree2 xs a b (Single x) =
+    xs |> a |> b |> x
+appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =
+    deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
+
+addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits2 m1 (One a) b c (One d) m2 =
+    appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits2 m1 (One a) b c (Two d e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits2 m1 (One a) b c (Three d e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (One a) b c (Four d e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Two a b) c d (One e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits2 m1 (Two a b) c d (Two e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (Two a b) c d (Three e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Three a b c) d e (One f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (Three a b c) d e (Two f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits2 m1 (Four a b c d) e f (One g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+
+appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a
+appendTree3 Empty a b c xs =
+    a <| b <| c <| xs
+appendTree3 xs a b c Empty =
+    xs |> a |> b |> c
+appendTree3 (Single x) a b c xs =
+    x <| a <| b <| c <| xs
+appendTree3 xs a b c (Single x) =
+    xs |> a |> b |> c |> x
+appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =
+    deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
+
+addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits3 m1 (One a) b c d (One e) m2 =
+    appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits3 m1 (One a) b c d (Two e f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits3 m1 (One a) b c d (Three e f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (One a) b c d (Four e f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Two a b) c d e (One f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits3 m1 (Two a b) c d e (Two f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Three a b c) d e f (One g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits3 m1 (Four a b c d) e f g (One h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+
+appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a
+appendTree4 Empty a b c d xs =
+    a <| b <| c <| d <| xs
+appendTree4 xs a b c d Empty =
+    xs |> a |> b |> c |> d
+appendTree4 (Single x) a b c d xs =
+    x <| a <| b <| c <| d <| xs
+appendTree4 xs a b c d (Single x) =
+    xs |> a |> b |> c |> d |> x
+appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =
+    deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
+
+addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
+addDigits4 m1 (One a) b c d e (One f) m2 =
+    appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits4 m1 (One a) b c d e (Two f g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits4 m1 (One a) b c d e (Three f g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Two a b) c d e f (One g) m2 =
+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Three a b c) d e f g (One h) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
+
+deep ::  (Measured v a) =>
+     Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
+deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf
+
+data Digit a
+    = One a
+    | Two a a
+    | Three a a a
+    | Four a a a a
+    deriving Show
+
+instance Foldable Digit where
+    foldMap f (One a) = f a
+    foldMap f (Two a b) = f a `mappend` f b
+    foldMap f (Three a b c) = f a `mappend` f b `mappend` f c
+    foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d
+
+data Node v a = Node2 !v a a | Node3 !v a a a
+    deriving Show
+
+instance Foldable (Node v) where
+    foldMap f (Node2 _ a b) = f a `mappend` f b
+    foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c
+
+node2        ::  (Measured v a) => a -> a -> Node v a
+node2 a b    =   Node2 (measure a `mappend` measure b) a b
+
+node3        ::  (Measured v a) => a -> a -> a -> Node v a
+node3 a b c  =   Node3 (measure a `mappend` measure b `mappend` measure c) a b c
+
+mappendVal :: (Measured v a) => v -> FingerTree v a -> v
+mappendVal v Empty = v
+mappendVal v t = v `mappend` measure t
+
+illegal_argument :: String -> a
+illegal_argument name =
+    error $ "Logic error: " ++ name ++ " called with illegal argument"
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 1ff71d8171..bf9686e9a4 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -74,3 +74,5 @@ test('T12689a', normal, compile_and_run, [''])
 test('T13172', only_ways(['optasm']), compile_and_run, ['-dcore-lint'])
 test('T13227', normal, compile_and_run, [''])
 test('T13733', expect_broken(13733), compile_and_run, [''])
+test('T13429', normal, compile_and_run, [''])
+test('T13429_2', normal, compile_and_run, [''])