diff --git a/containers-tests/benchmarks/Map.hs b/containers-tests/benchmarks/Map.hs
index 780b905f9..b53a4914d 100644
--- a/containers-tests/benchmarks/Map.hs
+++ b/containers-tests/benchmarks/Map.hs
@@ -21,6 +21,7 @@ main = do
         m_even = M.fromAscList elems_even :: M.Map Int Int
         m_odd = M.fromAscList elems_odd :: M.Map Int Int
     evaluate $ rnf [m, m_even, m_odd]
+    evaluate $ rnf elems_rev
     defaultMain
         [ bench "lookup absent" $ whnf (lookup evens) m_odd
         , bench "lookup present" $ whnf (lookup evens) m_even
@@ -90,6 +91,9 @@ main = do
         , bench "fromList-desc" $ whnf M.fromList (reverse elems)
         , bench "fromAscList" $ whnf M.fromAscList elems
         , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems
+        , bench "fromDistinctAscList:fusion" $ whnf (\n -> M.fromDistinctAscList [(i,i) | i <- [1..n]]) bound
+        , bench "fromDistinctDescList" $ whnf M.fromDistinctDescList elems_rev
+        , bench "fromDistinctDescList:fusion" $ whnf (\n -> M.fromDistinctDescList [(i,i) | i <- [n,n-1..1]]) bound
         , bench "minView" $ whnf (\m' -> case M.minViewWithKey m' of {Nothing -> 0; Just ((k,v),m'') -> k+v+M.size m''}) (M.fromAscList $ zip [1..10::Int] [100..110::Int])
         ]
   where
@@ -97,6 +101,7 @@ main = do
     elems = zip keys values
     elems_even = zip evens evens
     elems_odd = zip odds odds
+    elems_rev = reverse elems
     keys = [1..bound]
     evens = [2,4..bound]
     odds = [1,3..bound]
diff --git a/containers-tests/benchmarks/Set.hs b/containers-tests/benchmarks/Set.hs
index 89873362f..f65e2a620 100644
--- a/containers-tests/benchmarks/Set.hs
+++ b/containers-tests/benchmarks/Set.hs
@@ -14,6 +14,7 @@ main = do
         s_odd = S.fromAscList elems_odd :: S.Set Int
         strings_s = S.fromList strings
     evaluate $ rnf [s, s_even, s_odd]
+    evaluate $ rnf elems_rev
     defaultMain
         [ bench "member" $ whnf (member elems) s
         , bench "insert" $ whnf (ins elems) S.empty
@@ -34,6 +35,9 @@ main = do
         , bench "fromList-desc" $ whnf S.fromList (reverse elems)
         , bench "fromAscList" $ whnf S.fromAscList elems
         , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems
+        , bench "fromDistinctAscList:fusion" $ whnf (\n -> S.fromDistinctAscList [1..n]) bound
+        , bench "fromDistinctDescList" $ whnf S.fromDistinctDescList elems_rev
+        , bench "fromDistinctDescList:fusion" $ whnf (\n -> S.fromDistinctDescList [n,n-1..1]) bound
         , bench "disjoint:false" $ whnf (S.disjoint s) s_even
         , bench "disjoint:true" $ whnf (S.disjoint s_odd) s_even
         , bench "null.intersection:false" $ whnf (S.null. S.intersection s) s_even
@@ -53,9 +57,11 @@ main = do
         , bench "member.powerSet (18)" $ whnf (\ s -> all (flip S.member s) s) (S.powerSet (S.fromList [1..18]))
         ]
   where
-    elems = [1..2^12]
-    elems_even = [2,4..2^12]
-    elems_odd = [1,3..2^12]
+    bound = 2^12
+    elems = [1..bound]
+    elems_even = [2,4..bound]
+    elems_odd = [1,3..bound]
+    elems_rev = reverse elems
     strings = map show elems
 
 member :: [Int] -> S.Set Int -> Int
diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs
index bed8d2b7e..e836adc17 100644
--- a/containers-tests/tests/map-properties.hs
+++ b/containers-tests/tests/map-properties.hs
@@ -187,6 +187,7 @@ main = defaultMain $ testGroup "map-properties"
          , testProperty "mergeWithKey model"   prop_mergeWithKeyModel
          , testProperty "mergeA effects"       prop_mergeA_effects
          , testProperty "fromAscList"          prop_ordered
+         , testProperty "fromDistinctAscList"  prop_fromDistinctAscList
          , testProperty "fromDescList"         prop_rev_ordered
          , testProperty "fromDistinctDescList" prop_fromDistinctDescList
          , testProperty "fromList then toList" prop_list
@@ -1243,10 +1244,13 @@ prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <-
 prop_descList :: [Int] -> Bool
 prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])])
 
-prop_fromDistinctDescList :: Int -> [A] -> Property
-prop_fromDistinctDescList top lst = valid converted .&&. (toList converted === reverse original) where
-  original = zip [top, (top-1)..0] lst
-  converted = fromDistinctDescList original
+prop_fromDistinctDescList :: [(Int, A)] -> Property
+prop_fromDistinctDescList xs =
+    valid t .&&.
+    toList t === nub_sort_xs
+  where
+    t = fromDistinctDescList (reverse nub_sort_xs)
+    nub_sort_xs = List.map List.head $ List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) xs
 
 prop_ascDescList :: [Int] -> Bool
 prop_ascDescList xs = toAscList m == reverse (toDescList m)
@@ -1256,10 +1260,16 @@ prop_fromList :: [Int] -> Bool
 prop_fromList xs
   = case fromList (zip xs xs) of
       t -> t == fromAscList (zip sort_xs sort_xs) &&
-           t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&
            t == List.foldr (uncurry insert) empty (zip xs xs)
   where sort_xs = sort xs
-        nub_sort_xs = List.map List.head $ List.group sort_xs
+
+prop_fromDistinctAscList :: [(Int, A)] -> Property
+prop_fromDistinctAscList xs =
+    valid t .&&.
+    toList t === nub_sort_xs
+  where
+    t = fromDistinctAscList nub_sort_xs
+    nub_sort_xs = List.map List.head $ List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) xs
 
 ----------------------------------------------------------------
 
diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs
index cbb053c18..637d772ad 100644
--- a/containers-tests/tests/set-properties.hs
+++ b/containers-tests/tests/set-properties.hs
@@ -67,7 +67,9 @@ main = defaultMain $ testGroup "set-properties"
                    , testProperty "prop_DescList" prop_DescList
                    , testProperty "prop_AscDescList" prop_AscDescList
                    , testProperty "prop_fromList" prop_fromList
+                   , testProperty "prop_fromDistinctAscList" prop_fromDistinctAscList
                    , testProperty "prop_fromListDesc" prop_fromListDesc
+                   , testProperty "prop_fromDistinctDescList" prop_fromDistinctDescList
                    , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
                    , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
                    , testProperty "prop_isSubsetOf" prop_isSubsetOf
@@ -514,11 +516,17 @@ prop_AscDescList xs = toAscList s == reverse (toDescList s)
 prop_fromList :: [Int] -> Property
 prop_fromList xs =
            t === fromAscList sort_xs .&&.
-           t === fromDistinctAscList nub_sort_xs .&&.
            t === List.foldr insert empty xs
   where t = fromList xs
         sort_xs = sort xs
-        nub_sort_xs = List.map List.head $ List.group sort_xs
+
+prop_fromDistinctAscList :: [Int] -> Property
+prop_fromDistinctAscList xs =
+    valid t .&&.
+    toList t === nub_sort_xs
+  where
+    t = fromDistinctAscList nub_sort_xs
+    nub_sort_xs = List.map List.head $ List.group $ sort xs
 
 prop_fromListDesc :: [Int] -> Property
 prop_fromListDesc xs =
@@ -529,6 +537,14 @@ prop_fromListDesc xs =
         sort_xs = reverse (sort xs)
         nub_sort_xs = List.map List.head $ List.group sort_xs
 
+prop_fromDistinctDescList :: [Int] -> Property
+prop_fromDistinctDescList xs =
+    valid t .&&.
+    toList t === nub_sort_xs
+  where
+    t = fromDistinctDescList (reverse nub_sort_xs)
+    nub_sort_xs = List.map List.head $ List.group $ sort xs
+
 {--------------------------------------------------------------------
   Set operations are like IntSet operations
 --------------------------------------------------------------------}
diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs
index f801b1ae9..b7d352f69 100644
--- a/containers/src/Data/Map/Internal.hs
+++ b/containers/src/Data/Map/Internal.hs
@@ -355,8 +355,15 @@ module Data.Map.Internal (
     , link
     , link2
     , glue
+    , fromDistinctAscList_linkTop
+    , fromDistinctAscList_linkAll
+    , fromDistinctDescList_linkTop
+    , fromDistinctDescList_linkAll
     , MaybeS(..)
     , Identity(..)
+    , FromDistinctMonoState(..)
+    , Stack(..)
+    , foldl'Stack
 
     -- Used by Map.Merge.Lazy
     , mapWhenMissing
@@ -3410,8 +3417,7 @@ instance (Ord k) => GHCExts.IsList (Map k v) where
 -- If the list contains more than one value for the same key, the last value
 -- for the key is retained.
 --
--- If the keys of the list are ordered, linear-time implementation is used,
--- with the performance equal to 'fromDistinctAscList'.
+-- If the keys of the list are ordered, a linear-time implementation is used.
 --
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
@@ -3701,22 +3707,26 @@ fromDescListWithKey f xs
 
 -- For some reason, when 'singleton' is used in fromDistinctAscList or in
 -- create, it is not inlined, so we inline it manually.
+
+-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.
 fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList [] = Tip
-fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
+fromDistinctAscList = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)
   where
-    go !_ t [] = t
-    go s l ((kx, x) : xs) = case create s xs of
-                                (r :*: ys) -> let !t' = link kx x l r
-                                              in go (s `shiftL` 1) t' ys
-
-    create !_ [] = (Tip :*: [])
-    create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')
-      | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_ :*: []) -> res
-                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (r :*: zs) -> (link ky y l r :*: zs)
+    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a
+    next (State0 stk) (!kx, x) = fromDistinctAscList_linkTop (Bin 1 kx x Tip Tip) stk
+    next (State1 l stk) (kx, x) = State0 (Push kx x l stk)
+{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion
+
+fromDistinctAscList_linkTop :: Map k a -> Stack k a -> FromDistinctMonoState k a
+fromDistinctAscList_linkTop r@(Bin rsz _ _ _ _) (Push kx x l@(Bin lsz _ _ _ _) stk)
+  | rsz == lsz = fromDistinctAscList_linkTop (bin kx x l r) stk
+fromDistinctAscList_linkTop l stk = State1 l stk
+{-# INLINABLE fromDistinctAscList_linkTop #-}
+
+fromDistinctAscList_linkAll :: FromDistinctMonoState k a -> Map k a
+fromDistinctAscList_linkAll (State0 stk)    = foldl'Stack (\r kx x l -> link kx x l r) Tip stk
+fromDistinctAscList_linkAll (State1 r0 stk) = foldl'Stack (\r kx x l -> link kx x l r) r0 stk
+{-# INLINABLE fromDistinctAscList_linkAll #-}
 
 -- | \(O(n)\). Build a map from a descending list of distinct elements in linear time.
 -- /The precondition is not checked./
@@ -3729,22 +3739,39 @@ fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
 
 -- For some reason, when 'singleton' is used in fromDistinctDescList or in
 -- create, it is not inlined, so we inline it manually.
+
+-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.
 fromDistinctDescList :: [(k,a)] -> Map k a
-fromDistinctDescList [] = Tip
-fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0
+fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada)
+  where
+    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a
+    next (State0 stk) (!kx, x) = fromDistinctDescList_linkTop (Bin 1 kx x Tip Tip) stk
+    next (State1 r stk) (kx, x) = State0 (Push kx x r stk)
+{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion
+
+fromDistinctDescList_linkTop :: Map k a -> Stack k a -> FromDistinctMonoState k a
+fromDistinctDescList_linkTop l@(Bin lsz _ _ _ _) (Push kx x r@(Bin rsz _ _ _ _) stk)
+  | lsz == rsz = fromDistinctDescList_linkTop (bin kx x l r) stk
+fromDistinctDescList_linkTop r stk = State1 r stk
+{-# INLINABLE fromDistinctDescList_linkTop #-}
+
+fromDistinctDescList_linkAll :: FromDistinctMonoState k a -> Map k a
+fromDistinctDescList_linkAll (State0 stk)    = foldl'Stack (\l kx x r -> link kx x l r) Tip stk
+fromDistinctDescList_linkAll (State1 l0 stk) = foldl'Stack (\l kx x r -> link kx x l r) l0 stk
+{-# INLINABLE fromDistinctDescList_linkAll #-}
+
+data FromDistinctMonoState k a
+  = State0 !(Stack k a)
+  | State1 !(Map k a) !(Stack k a)
+
+data Stack k a = Push !k a !(Map k a) !(Stack k a) | Nada
+
+foldl'Stack :: (b -> k -> a -> Map k a -> b) -> b -> Stack k a -> b
+foldl'Stack f = go
   where
-     go !_ t [] = t
-     go s r ((kx, x) : xs) = case create s xs of
-                               (l :*: ys) -> let !t' = link kx x l r
-                                             in go (s `shiftL` 1) t' ys
-
-     create !_ [] = (Tip :*: [])
-     create s xs@(x' : xs')
-       | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')
-       | otherwise = case create (s `shiftR` 1) xs of
-                       res@(_ :*: []) -> res
-                       (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                         (l :*: zs) -> (link ky y l r :*: zs)
+    go !z Nada = z
+    go z (Push kx x t stk) = go (f z kx x t) stk
+{-# INLINE foldl'Stack #-}
 
 {-
 -- Functions very similar to these were used to implement
diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs
index 18a829397..81b4127bb 100644
--- a/containers/src/Data/Map/Strict/Internal.hs
+++ b/containers/src/Data/Map/Strict/Internal.hs
@@ -328,6 +328,12 @@ import Data.Map.Internal
   , filterAMissing
   , merge
   , mergeA
+  , fromDistinctAscList_linkTop
+  , fromDistinctAscList_linkAll
+  , fromDistinctDescList_linkTop
+  , fromDistinctDescList_linkAll
+  , FromDistinctMonoState (..)
+  , Stack (..)
   , (!)
   , (!?)
   , (\\)
@@ -1489,8 +1495,7 @@ fromArgSet (Set.Bin sz (Arg x v) l r) = v `seq` Bin sz x v (fromArgSet l) (fromA
 -- If the list contains more than one value for the same key, the last value
 -- for the key is retained.
 --
--- If the keys of the list are ordered, linear-time implementation is used,
--- with the performance equal to 'fromDistinctAscList'.
+-- If the keys of the list are ordered, a linear-time implementation is used.
 --
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
@@ -1697,23 +1702,15 @@ fromDescListWithKey f xs
 
 -- For some reason, when 'singleton' is used in fromDistinctAscList or in
 -- create, it is not inlined, so we inline it manually.
+
+-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.
 fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList [] = Tip
-fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
+fromDistinctAscList = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)
   where
-    go !_ t [] = t
-    go s l ((kx, x) : xs) =
-      case create s xs of
-        (r :*: ys) -> x `seq` let !t' = link kx x l r
-                           in go (s `shiftL` 1) t' ys
-
-    create !_ [] = (Tip :*: [])
-    create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')
-      | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_ :*: []) -> res
-                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (r :*: zs) -> y `seq` (link ky y l r :*: zs)
+    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a
+    next (State0 stk) (!kx, !x) = fromDistinctAscList_linkTop (Bin 1 kx x Tip Tip) stk
+    next (State1 l stk) (kx, x) = State0 (Push kx x l stk)
+{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion
 
 -- | \(O(n)\). Build a map from a descending list of distinct elements in linear time.
 -- /The precondition is not checked./
@@ -1724,20 +1721,12 @@ fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip T
 
 -- For some reason, when 'singleton' is used in fromDistinctDescList or in
 -- create, it is not inlined, so we inline it manually.
+
+-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.
 fromDistinctDescList :: [(k,a)] -> Map k a
-fromDistinctDescList [] = Tip
-fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
+fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada)
   where
-    go !_ t [] = t
-    go s r ((kx, x) : xs) =
-      case create s xs of
-        (l :*: ys) -> x `seq` let !t' = link kx x l r
-                              in go (s `shiftL` 1) t' ys
-
-    create !_ [] = (Tip :*: [])
-    create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')
-      | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_ :*: []) -> res
-                      (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (l :*: zs) -> y `seq` (link ky y l r :*: zs)
+    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a
+    next (State0 stk) (!kx, !x) = fromDistinctDescList_linkTop (Bin 1 kx x Tip Tip) stk
+    next (State1 r stk) (kx, x) = State0 (Push kx x r stk)
+{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion
diff --git a/containers/src/Data/Set/Internal.hs b/containers/src/Data/Set/Internal.hs
index 4501c087f..c132e1f93 100644
--- a/containers/src/Data/Set/Internal.hs
+++ b/containers/src/Data/Set/Internal.hs
@@ -1085,8 +1085,7 @@ foldlFB = foldl
 
 -- | \(O(n \log n)\). Create a set from a list of elements.
 --
--- If the elements are ordered, a linear-time implementation is used,
--- with the performance equal to 'fromDistinctAscList'.
+-- If the elements are ordered, a linear-time implementation is used.
 
 -- For some reason, when 'singleton' is used in fromList or in
 -- create, it is not inlined, so we inline it manually.
@@ -1172,46 +1171,67 @@ combineEq (x : xs) = combineEq' x xs
 
 -- For some reason, when 'singleton' is used in fromDistinctAscList or in
 -- create, it is not inlined, so we inline it manually.
+
+-- See Note [fromDistinctAscList implementation]
 fromDistinctAscList :: [a] -> Set a
-fromDistinctAscList [] = Tip
-fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+fromDistinctAscList = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)
   where
-    go !_ t [] = t
-    go s l (x : xs) = case create s xs of
-                        (r :*: ys) -> let !t' = link x l r
-                                      in go (s `shiftL` 1) t' ys
-
-    create !_ [] = (Tip :*: [])
-    create s xs@(x : xs')
-      | s == 1 = (Bin 1 x Tip Tip :*: xs')
-      | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_ :*: []) -> res
-                      (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of
-                        (r :*: zs) -> (link y l r :*: zs)
+    next :: FromDistinctMonoState a -> a -> FromDistinctMonoState a
+    next (State0 stk) !x = fromDistinctAscList_linkTop (Bin 1 x Tip Tip) stk
+    next (State1 l stk) x = State0 (Push x l stk)
+{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion
+
+fromDistinctAscList_linkTop :: Set a -> Stack a -> FromDistinctMonoState a
+fromDistinctAscList_linkTop r@(Bin rsz _ _ _) (Push x l@(Bin lsz _ _ _) stk)
+  | rsz == lsz = fromDistinctAscList_linkTop (bin x l r) stk
+fromDistinctAscList_linkTop l stk = State1 l stk
+{-# INLINABLE fromDistinctAscList_linkTop #-}
+
+fromDistinctAscList_linkAll :: FromDistinctMonoState a -> Set a
+fromDistinctAscList_linkAll (State0 stk)    = foldl'Stack (\r x l -> link x l r) Tip stk
+fromDistinctAscList_linkAll (State1 r0 stk) = foldl'Stack (\r x l -> link x l r) r0 stk
+{-# INLINABLE fromDistinctAscList_linkAll #-}
 
 -- | \(O(n)\). Build a set from a descending list of distinct elements in linear time.
 -- /The precondition (input list is strictly descending) is not checked./
+--
+-- @since 0.5.8
 
 -- For some reason, when 'singleton' is used in fromDistinctDescList or in
 -- create, it is not inlined, so we inline it manually.
---
--- @since 0.5.8
+
+-- See Note [fromDistinctAscList implementation]
 fromDistinctDescList :: [a] -> Set a
-fromDistinctDescList [] = Tip
-fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada)
   where
-    go !_ t [] = t
-    go s r (x : xs) = case create s xs of
-                        (l :*: ys) -> let !t' = link x l r
-                                      in go (s `shiftL` 1) t' ys
-
-    create !_ [] = (Tip :*: [])
-    create s xs@(x : xs')
-      | s == 1 = (Bin 1 x Tip Tip :*: xs')
-      | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_ :*: []) -> res
-                      (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of
-                        (l :*: zs) -> (link y l r :*: zs)
+    next :: FromDistinctMonoState a -> a -> FromDistinctMonoState a
+    next (State0 stk) !x = fromDistinctDescList_linkTop (Bin 1 x Tip Tip) stk
+    next (State1 r stk) x = State0 (Push x r stk)
+{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion
+
+fromDistinctDescList_linkTop :: Set a -> Stack a -> FromDistinctMonoState a
+fromDistinctDescList_linkTop l@(Bin lsz _ _ _) (Push x r@(Bin rsz _ _ _) stk)
+  | lsz == rsz = fromDistinctDescList_linkTop (bin x l r) stk
+fromDistinctDescList_linkTop r stk = State1 r stk
+{-# INLINABLE fromDistinctDescList_linkTop #-}
+
+fromDistinctDescList_linkAll :: FromDistinctMonoState a -> Set a
+fromDistinctDescList_linkAll (State0 stk)    = foldl'Stack (\l x r -> link x l r) Tip stk
+fromDistinctDescList_linkAll (State1 l0 stk) = foldl'Stack (\l x r -> link x l r) l0 stk
+{-# INLINABLE fromDistinctDescList_linkAll #-}
+
+data FromDistinctMonoState a
+  = State0 !(Stack a)
+  | State1 !(Set a) !(Stack a)
+
+data Stack a = Push !a !(Set a) !(Stack a) | Nada
+
+foldl'Stack :: (b -> a -> Set a -> b) -> b -> Stack a -> b
+foldl'Stack f = go
+  where
+    go !z Nada = z
+    go z (Push x t stk) = go (f z x t) stk
+{-# INLINE foldl'Stack #-}
 
 {--------------------------------------------------------------------
   Eq converts the set to a list. In a lazy setting, this
@@ -2054,3 +2074,51 @@ validsize t
           Bin sz _ l r -> case (realsize l,realsize r) of
                             (Just n,Just m)  | n+m+1 == sz  -> Just sz
                             _                -> Nothing
+
+--------------------------------------------------------------------
+
+-- Note [fromDistinctAscList implementation]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- fromDistinctAscList is implemented by building up perfectly balanced trees
+-- while we consume elements from the list one by one. A stack of
+-- (root, perfectly balanced left branch) pairs is maintained, in increasing
+-- order of size from top to bottom.
+--
+-- When we get an element from the list, we attempt to link it as the right
+-- branch with the top (root, perfect left branch) of the stack to create a new
+-- perfect tree. We can only do this if the left branch has size 1. If we link
+-- it, we get a perfect tree of size 3. We repeat this process, merging with the
+-- top of the stack as long as the sizes match. When we can't link any more, the
+-- perfect tree we built so far is a potential left branch. The next element
+-- we find becomes the root, and we push this new (root, left branch) on the
+-- stack.
+--
+-- When we are out of elements, we link the (root, left branch)s in the stack
+-- top to bottom to get the final tree.
+--
+-- How long does this take? We do O(1) work per element excluding the links.
+-- Over n elements, we build trees with at most n nodes total, and each link is
+-- done in O(1) using `bin`. The final linking of the stack is done in O(log n)
+-- using `link`  (proof below). The total time is thus O(n).
+--
+-- Additionally, the implemention is written using foldl' over the input list,
+-- which makes it participate as a good consumer in list fusion.
+--
+-- fromDistinctDescList is implemented similarly, adapted for left and right
+-- sides being swapped.
+--
+-- ~~~
+--
+-- A `link` operation links trees L and R with a root in
+-- O(|log(size(L)) - log(size(R))|). Let's say there are m (root, tree) in the
+-- stack, the size of the ith tree being 2^{k_i} - 1. We also know that
+-- k_i > k_j for i > j, and n = \sum_{i=1}^m 2^{k_i}. With this information, we
+-- can calculate the total time to link everything on the stack:
+--
+--   O(\sum_{i=2}^m |log(2^{k_i} - 1) - log(\sum_{j=1}^{i-1} 2^{k_j})|)
+-- = O(\sum_{i=2}^m log(2^{k_i} - 1) - log(\sum_{j=1}^{i-1} 2^{k_j}))
+-- = O(\sum_{i=2}^m log(2^{k_i} - 1) - log(2^{k_{i-1}}))
+-- = O(\sum_{i=2}^m k_i - k_{i-1})
+-- = O(k_m - k_1)
+-- = O(log n)