Commit 2b74bd9d authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 92a4f908
This diff is collapsed.
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'])
{-# 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)
......@@ -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,
......
{-# 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]
-- 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
{-# 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)
{-# 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 =