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.

9 files changed, 457 insertions, 115 deletions

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, [''])