diff --git a/pqueue.cabal b/pqueue.cabal
index f5169c8..2fa0c7b 100644
--- a/pqueue.cabal
+++ b/pqueue.cabal
@@ -43,6 +43,10 @@ library
     default-extensions: DeriveDataTypeable
   }
   ghc-options: {
+    -- We currently need -fspec-constr to get GHC to compile conversions
+    -- from lists well. We could (and probably should) write those a
+    -- bit differently so we won't need it.
+    -fspec-constr
     -fdicts-strict
     -Wall
     -fno-warn-inline-rule-shadowing
diff --git a/src/Data/PQueue/Internals.hs b/src/Data/PQueue/Internals.hs
index 94566eb..ed75abf 100644
--- a/src/Data/PQueue/Internals.hs
+++ b/src/Data/PQueue/Internals.hs
@@ -22,6 +22,9 @@ module Data.PQueue.Internals (
   foldrAsc,
   foldlAsc,
   insertMinQ,
+  insertMinQ',
+  insertMaxQ',
+  fromList,
 --   mapU,
   foldrU,
   foldlU,
@@ -31,6 +34,7 @@ module Data.PQueue.Internals (
   ) where
 
 import Control.DeepSeq (NFData(rnf), deepseq)
+import Data.Foldable (foldl')
 
 import qualified Data.PQueue.Prio.Internals as Prio
 
@@ -41,7 +45,7 @@ import Data.Data
 import Prelude hiding (null)
 
 -- | A priority queue with elements of type @a@. Supports extracting the minimum element.
-data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int a !(BinomHeap a)
+data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int !a !(BinomHeap a)
 #if __GLASGOW_HASKELL__>=707
   deriving Typeable
 #else
@@ -139,13 +143,30 @@ cmpExtract (x1,q1) (x2,q2) =
 --
 -- is a type constructor that takes an element type and returns the type of binomial trees
 -- of rank @3@.
-data BinomForest rk a = Nil | Skip (BinomForest (Succ rk) a) |
-  Cons {-# UNPACK #-} !(BinomTree rk a) (BinomForest (Succ rk) a)
+--
+-- The Skip constructor must be lazy to obtain the desired amortized bounds.
+-- The forest field of the Succ constructor /could/ be made strict, but that
+-- would be worse for heavily persistent use and not obviously better
+-- otherwise.
+--
+-- Debit invariant:
+--
+-- The next-pointer of a Skip node is allowed 1 debit. No other debits are
+-- allowed in the structure.
+data BinomForest rk a
+   = Nil
+   | Skip (BinomForest (Succ rk) a)
+   | Cons {-# UNPACK #-} !(BinomTree rk a) (BinomForest (Succ rk) a)
 
-data BinomTree rk a = BinomTree a (rk a)
+-- The BinomTree and Succ constructors are entirely strict, primarily because
+-- that makes it easier to make sure everything is as strict as it should
+-- be. The downside is that this slows down `mapMonotonic`. If that's important,
+-- we can do all the forcing manually; it will be a pain.
+
+data BinomTree rk a = BinomTree !a !(rk a)
 
 -- | If |rk| corresponds to rank @k@, then |'Succ' rk| corresponds to rank @k+1@.
-data Succ rk a = Succ {-# UNPACK #-} !(BinomTree rk a) (rk a)
+data Succ rk a = Succ {-# UNPACK #-} !(BinomTree rk a) !(rk a)
 
 -- | Type corresponding to the Zero rank.
 data Zero a = Zero
@@ -243,7 +264,7 @@ foldlUnfold f z0 suc s0 = unf z0 s0 where
 insert' :: LEq a -> a -> MinQueue a -> MinQueue a
 insert' _ x Empty = singleton x
 insert' le x (MinQueue n x' ts)
-  | x `le` x' = MinQueue (n + 1) x (incr le (tip x') ts)
+  | x `le` x' = MinQueue (n + 1) x (insertMin (tip x') ts)
   | otherwise = MinQueue (n + 1) x' (incr le (tip x) ts)
 
 {-# INLINE union' #-}
@@ -257,8 +278,8 @@ union' le (MinQueue n1 x1 f1) (MinQueue n2 x2 f2)
 -- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root.
 extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a)
 extractHeap ts = case extractBin (<=) ts of
-  Yes (Extract x _ ts') -> Just (x, ts')
-  _                     -> Nothing
+  No                        -> Nothing
+  Yes (Extract x ~Zero ts') -> Just (x, ts')
 
 -- | A specialized type intended to organize the return of extract-min queries
 -- from a binomial forest. We walk all the way through the forest, and then
@@ -280,9 +301,7 @@ extractHeap ts = case extractBin (<=) ts of
 --     reconstruction of the binomial forest without @minRoot@. It is
 --     the union of all old roots with rank @>= rk@ (except @minRoot@),
 --     with the set of all children of @minRoot@ with rank @>= rk@.
---     Note that @forest@ is lazy, so if we discover a smaller key
---     than @minKey@ later, we haven't wasted significant work.
-data Extract rk a = Extract a (rk a) (BinomForest rk a)
+data Extract rk a = Extract !a !(rk a) !(BinomForest rk a)
 data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a)
 
 incrExtract :: Extract (Succ rk) a -> Extract rk a
@@ -291,7 +310,7 @@ incrExtract (Extract minKey (Succ kChild kChildren) ts)
 
 incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a
 incrExtract' le t (Extract minKey (Succ kChild kChildren) ts)
-  = Extract minKey kChildren (Skip (incr le (t `cat` kChild) ts))
+  = Extract minKey kChildren (Skip $ incr le (t `cat` kChild) ts)
   where
     cat = joinBin le
 
@@ -299,15 +318,29 @@ incrExtract' le t (Extract minKey (Succ kChild kChildren) ts)
 -- Returns its progress. Each successive application of @extractBin@ takes
 -- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time.
 extractBin :: LEq a -> BinomForest rk a -> MExtract rk a
-extractBin _ Nil = No
-extractBin le (Skip f) = case extractBin le f of
-  Yes ex -> Yes (incrExtract ex)
-  No     -> No
-extractBin le (Cons t@(BinomTree x ts) f) = Yes $ case extractBin le f of
-  Yes ex@(Extract minKey _ _)
-    | minKey `lt` x -> incrExtract' le t ex
-  _                 -> Extract x ts (Skip f)
-  where a `lt` b = not (b `le` a)
+extractBin le0 = start le0
+  where
+    start :: LEq a -> BinomForest rk a -> MExtract rk a
+    start _le Nil = No
+    start le (Skip f) = case start le f of
+      No     -> No
+      Yes ex -> Yes (incrExtract ex)
+    start le (Cons t@(BinomTree x ts) f) = Yes $ case go le x f of
+      No -> Extract x ts (Skip f)
+      Yes ex -> incrExtract' le t ex
+
+    go :: LEq a -> a -> BinomForest rk a -> MExtract rk a
+    go _le _min_above Nil = _min_above `seq` No
+    go le min_above (Skip f) = case go le min_above f of
+      No -> No
+      Yes ex -> Yes (incrExtract ex)
+    go le min_above (Cons t@(BinomTree x ts) f)
+      | min_above `le` x = case go le min_above f of
+          No -> No
+          Yes ex -> Yes (incrExtract' le t ex)
+      | otherwise = case go le x f of
+          No -> Yes (Extract x ts (Skip f))
+          Yes ex -> Yes (incrExtract' le t ex)
 
 mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b
 mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of
@@ -346,18 +379,79 @@ insertMinQ x (MinQueue n x' f) = MinQueue (n + 1) x (insertMin (tip x') f)
 insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a
 insertMin t Nil = Cons t Nil
 insertMin t (Skip f) = Cons t f
-insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f)
+insertMin (BinomTree x ts) (Cons t' f) = f `seq` Skip (insertMin (BinomTree x (Succ t' ts)) f)
+
+-- | @insertMinQ' x h@ assumes that @x@ compares as less
+-- than or equal to every element of @h@.
+insertMinQ' :: a -> MinQueue a -> MinQueue a
+insertMinQ' x Empty = singleton x
+insertMinQ' x (MinQueue n x' f) = MinQueue (n + 1) x (insertMin' (tip x') f)
+
+-- | @insertMin' t f@ assumes that the root of @t@ compares as less than
+-- every other root in @f@, and merges accordingly. It eagerly evaluates
+-- the modified portion of the structure.
+insertMin' :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a
+insertMin' t Nil = Cons t Nil
+insertMin' t (Skip f) = Cons t f
+insertMin' (BinomTree x ts) (Cons t' f) = Skip $! insertMin' (BinomTree x (Succ t' ts)) f
+
+-- | @insertMaxQ' x h@ assumes that @x@ compares as greater
+-- than or equal to every element of @h@. It also assumes,
+-- and preserves, an extra invariant. See 'insertMax'' for details.
+-- tldr: this function can be used safely to build a queue from an
+-- ascending list/array/whatever, but that's about it.
+insertMaxQ' :: a -> MinQueue a -> MinQueue a
+insertMaxQ' x Empty = singleton x
+insertMaxQ' x (MinQueue n x' f) = MinQueue (n + 1) x' (insertMax' (tip x) f)
+
+-- | @insertMax' t f@ assumes that the root of @t@ compares as greater
+-- than or equal to every root in @f@, and further assumes that the roots
+-- in @f@ occur in descending order. It produces a forest whose roots are
+-- again in descending order. Note: the whole modified portion of the spine
+-- is forced.
+insertMax' :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a
+insertMax' t Nil = Cons t Nil
+insertMax' t (Skip f) = Cons t f
+insertMax' t (Cons (BinomTree x ts) f) = Skip $! insertMax' (BinomTree x (Succ t ts)) f
+
+{-# INLINABLE fromList #-}
+-- | /O(n)/. Constructs a priority queue from an unordered list.
+fromList :: Ord a => [a] -> MinQueue a
+-- We build a forest first and then extract its minimum at the end.
+-- Why not just build the 'MinQueue' directly? This way saves us one
+-- comparison per element.
+fromList xs = case extractHeap (fromListHeap (<=) xs) of
+  Nothing -> Empty
+  -- Should we track the size as we go instead? That saves O(log n)
+  -- at the end, but it needs an extra register all along the way.
+  -- The nodes should probably all be in L1 cache already thanks to the
+  -- extractHeap.
+  Just (m, f) -> MinQueue (sizeHeap f + 1) m f
+
+{-# INLINE fromListHeap #-}
+fromListHeap :: LEq a -> [a] -> BinomHeap a
+fromListHeap le xs = foldl' go Nil xs
+  where
+    go fr x = incr' le (tip x) fr
+
+sizeHeap :: BinomHeap a -> Int
+sizeHeap = go 0 1
+  where
+    go :: Int -> Int -> BinomForest rk a -> Int
+    go acc rk Nil = rk `seq` acc
+    go acc rk (Skip f) = go acc (2 * rk) f
+    go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f
 
 -- | Given two binomial forests starting at rank @rk@, takes their union.
 -- Each successive application of this function costs /O(1)/, so applying it
 -- from the beginning costs /O(log n)/.
 merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a
 merge le f1 f2 = case (f1, f2) of
-  (Skip f1', Skip f2')    -> Skip (merge le f1' f2')
-  (Skip f1', Cons t2 f2') -> Cons t2 (merge le f1' f2')
-  (Cons t1 f1', Skip f2') -> Cons t1 (merge le f1' f2')
+  (Skip f1', Skip f2')    -> Skip $! merge le f1' f2'
+  (Skip f1', Cons t2 f2') -> Cons t2 $! merge le f1' f2'
+  (Cons t1 f1', Skip f2') -> Cons t1 $! merge le f1' f2'
   (Cons t1 f1', Cons t2 f2')
-        -> Skip (carry le (t1 `cat` t2) f1' f2')
+        -> Skip $! carry le (t1 `cat` t2) f1' f2'
   (Nil, _)                -> f2
   (_, Nil)                -> f1
   where  cat = joinBin le
@@ -367,11 +461,14 @@ merge le f1 f2 = case (f1, f2) of
 -- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/.
 carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a
 carry le t0 f1 f2 = t0 `seq` case (f1, f2) of
-  (Skip f1', Skip f2')    -> Cons t0 (merge le f1' f2')
-  (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2')
-  (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2')
+  (Skip f1', Skip f2')    -> Cons t0 $! merge le f1' f2'
+  (Skip f1', Cons t2 f2') -> Skip $! mergeCarry t0 t2 f1' f2'
+  (Cons t1 f1', Skip f2') -> Skip $! mergeCarry t0 t1 f1' f2'
   (Cons t1 f1', Cons t2 f2')
-        -> Cons t0 (mergeCarry t1 t2 f1' f2')
+        -> Cons t0 $! mergeCarry t1 t2 f1' f2'
+  -- Why do these use incr and not incr'? We want the merge to take amortized
+  -- O(log(min(|f1|, |f2|))) time. If we performed this final increment
+  -- eagerly, that would degrade to O(log(max(|f1|, |f2|))) time.
   (Nil, _f2)              -> incr le t0 f2
   (_f1, Nil)              -> incr le t0 f1
   where  cat = joinBin le
@@ -384,8 +481,33 @@ incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a
 incr le t f0 = t `seq` case f0 of
   Nil  -> Cons t Nil
   Skip f     -> Cons t f
-  Cons t' f' -> Skip (incr le (t `cat` t') f')
-  where  cat = joinBin le
+  Cons t' f' -> f' `seq` Skip (incr le (t `cat` t') f')
+      -- Question: should we force t `cat` t' here? We're allowed to;
+      -- it's not obviously good or obviously bad.
+    where
+      cat = joinBin le
+
+-- | A version of 'incr' that constructs the spine eagerly. This is
+-- intended for implementing @fromList@.
+incr' :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a
+incr' le t f0 = t `seq` case f0 of
+  Nil  -> Cons t Nil
+  Skip f     -> Cons t f
+  Cons t' f' -> Skip $! incr' le (t `cat` t') f'
+      -- Question: should we force t `cat` t' here? We're allowed to;
+      -- it's not obviously good or obviously bad.
+    where
+      cat = joinBin le
+
+-- Amortization: In the Skip case, we perform O(1) unshared work and pay a
+-- debit. In the Cons case, there are no debits on f', so we can force it for
+-- free. We perform O(1) unshared work, and by induction suspend O(1) amortized
+-- work. Another way to look at this: We have a string of Conses followed by
+-- a Skip or Nil. We change all the Conses to Skips, and change the Skip to
+-- a Cons or the Nil to a Cons Nil. Processing each Cons takes O(1) time, which
+-- we account for by placing debits below the new Skips. Note: this increment
+-- pattern is exactly the same as the one for Hinze-Paterson 2–3 finger trees,
+-- and the amortization argument works just the same.
 
 -- | The carrying operation: takes two binomial heaps of the same rank @k@
 -- and returns one of rank @k+1@. Takes /O(1)/ time.
@@ -409,8 +531,8 @@ instance Functor rk => Functor (BinomForest rk) where
   fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts)
 
 instance Foldable Zero where
-  foldr _ z _ = z
-  foldl _ z _ = z
+  foldr _ z ~Zero = z
+  foldl _ z ~Zero = z
 
 instance Foldable rk => Foldable (Succ rk) where
   foldr f z (Succ t ts) = foldr f (foldr f z ts) t
@@ -460,7 +582,13 @@ foldlU f z (MinQueue _ x ts) = foldl f (z `f` x) ts
 -- traverseU _ Empty = pure Empty
 -- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts
 
--- | Forces the spine of the priority queue.
+-- | /O(log n)/. @seqSpine q r@ forces the spine of @q@ and returns @r@.
+--
+-- Note: The spine of a 'MinQueue' is stored somewhat lazily. Most operations
+-- take great care to prevent chains of thunks from accumulating along the
+-- spine to the detriment of performance. However, @mapU@ can leave expensive
+-- thunks in the structure and repeated applications of that function can
+-- create thunk chains.
 seqSpine :: MinQueue a -> b -> b
 seqSpine Empty z = z
 seqSpine (MinQueue _ _ ts) z = seqSpineF ts z
diff --git a/src/Data/PQueue/Max.hs b/src/Data/PQueue/Max.hs
index 9c6a803..b75d224 100644
--- a/src/Data/PQueue/Max.hs
+++ b/src/Data/PQueue/Max.hs
@@ -16,8 +16,6 @@
 -- some operations. These bounds hold even in a persistent (shared) setting.
 --
 -- This implementation is based on a binomial heap augmented with a global root.
--- The spine of the heap is maintained lazily. To force the spine of the heap,
--- use 'seqSpine'.
 --
 -- This implementation does not guarantee stable behavior.
 --
@@ -335,12 +333,18 @@ fromDescList = MaxQ . Min.fromAscList . map Down
 {-# INLINE fromList #-}
 -- | /O(n log n)/. Constructs a priority queue from an unordered list.
 fromList :: Ord a => [a] -> MaxQueue a
-fromList = foldr insert empty
+fromList = MaxQ . Min.fromList . map Down
 
 -- | /O(n)/. Constructs a priority queue from the keys of a 'Prio.MaxPQueue'.
 keysQueue :: Prio.MaxPQueue k a -> MaxQueue k
 keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q)
 
--- | /O(log n)/. Forces the spine of the heap.
+-- | /O(log n)/. @seqSpine q r@ forces the spine of @q@ and returns @r@.
+--
+-- Note: The spine of a 'MaxQueue' is stored somewhat lazily. Most operations
+-- take great care to prevent chains of thunks from accumulating along the
+-- spine to the detriment of performance. However, 'mapU' can leave expensive
+-- thunks in the structure and repeated applications of that function can
+-- create thunk chains.
 seqSpine :: MaxQueue a -> b -> b
 seqSpine (MaxQ q) = Min.seqSpine q
diff --git a/src/Data/PQueue/Min.hs b/src/Data/PQueue/Min.hs
index 562890a..319b34e 100644
--- a/src/Data/PQueue/Min.hs
+++ b/src/Data/PQueue/Min.hs
@@ -17,8 +17,6 @@
 -- some operations. These bounds hold even in a persistent (shared) setting.
 --
 -- This implementation is based on a binomial heap augmented with a global root.
--- The spine of the heap is maintained lazily. To force the spine of the heap,
--- use 'seqSpine'.
 --
 -- This implementation does not guarantee stable behavior.
 --
@@ -265,24 +263,22 @@ foldrDesc = foldlAsc . flip
 foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b
 foldlDesc = foldrAsc . flip
 
-{-# INLINE fromList #-}
--- | /O(n)/. Constructs a priority queue from an unordered list.
-fromList :: Ord a => [a] -> MinQueue a
-fromList = foldr insert empty
-
-{-# RULES
-  "fromList" fromList = foldr insert empty;
-  "fromAscList" fromAscList = foldr insertMinQ empty;
-  #-}
-
 {-# INLINE fromAscList #-}
 -- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition.
+--
+-- Performance note: Code using this function in a performance-sensitive context
+-- with an argument that is a "good producer" for list fusion should be compiled
+-- with @-fspec-constr@ or @-O2@. For example, @fromAscList . map f@ needs one
+-- of these options for best results.
 fromAscList :: [a] -> MinQueue a
-fromAscList = foldr insertMinQ empty
+-- We apply an explicit argument to get foldl' to inline.
+fromAscList xs = foldl' (flip insertMaxQ') empty xs
 
+{-# INLINE fromDescList #-}
 -- | /O(n)/. Constructs a priority queue from an descending list. /Warning/: Does not check the precondition.
 fromDescList :: [a] -> MinQueue a
-fromDescList = foldl' (flip insertMinQ) empty
+-- We apply an explicit argument to get foldl' to inline.
+fromDescList xs = foldl' (flip insertMinQ') empty xs
 
 -- | Maps a function over the elements of the queue, ignoring order. This function is only safe if the function is monotonic.
 -- This function /does not/ check the precondition.
diff --git a/src/Data/PQueue/Prio/Internals.hs b/src/Data/PQueue/Prio/Internals.hs
index 797256b..951cba3 100644
--- a/src/Data/PQueue/Prio/Internals.hs
+++ b/src/Data/PQueue/Prio/Internals.hs
@@ -26,6 +26,9 @@ module Data.PQueue.Prio.Internals (
   foldrWithKey,
   foldlWithKey,
   insertMin,
+  insertMin',
+  insertMax',
+  fromList,
   foldrWithKeyU,
   foldlWithKeyU,
   traverseWithKeyU,
@@ -35,6 +38,7 @@ module Data.PQueue.Prio.Internals (
 
 import Control.Applicative.Identity (Identity(Identity, runIdentity))
 import Control.DeepSeq (NFData(rnf), deepseq)
+import Data.List (foldl')
 
 import Data.Monoid ((<>))
 
@@ -69,7 +73,7 @@ infixr 8 .:
 
 -- | A priority queue where values of type @a@ are annotated with keys of type @k@.
 -- The queue supports extracting the element with minimum key.
-data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int k a (BinomHeap k a)
+data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a)
 #if __GLASGOW_HASKELL__
   deriving (Typeable)
 #endif
@@ -80,9 +84,9 @@ data BinomForest rk k a =
   Cons {-# UNPACK #-} !(BinomTree rk k a) (BinomForest (Succ rk) k a)
 type BinomHeap = BinomForest Zero
 
-data BinomTree rk k a = BinomTree k a (rk k a)
+data BinomTree rk k a = BinomTree !k a !(rk k a)
 data Zero k a = Zero
-data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a)
+data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) !(rk k a)
 
 type CompF a = a -> a -> Bool
 
@@ -160,7 +164,7 @@ spanKey p q = case minViewWithKey q of
 insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a
 insert' _ k a Empty = singleton k a
 insert' le k a (MinPQ n k' a' ts)
-  | k `le` k' = MinPQ (n + 1) k  a  (incr le (tip k' a') ts)
+  | k `le` k' = MinPQ (n + 1) k  a  (incrMin (tip k' a') ts)
   | otherwise = MinPQ (n + 1) k' a' (incr le (tip k  a ) ts)
 
 -- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union
@@ -251,6 +255,48 @@ insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a
 insertMin k a Empty = MinPQ 1 k a Nil
 insertMin k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin (tip k' a') ts)
 
+-- | Equivalent to 'insert', save the assumption that this key is @<=@
+-- every other key in the map. /The precondition is not checked./ Additionally,
+-- this eagerly constructs the new portion of the spine.
+insertMin' :: k -> a -> MinPQueue k a -> MinPQueue k a
+insertMin' k a Empty = MinPQ 1 k a Nil
+insertMin' k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin' (tip k' a') ts)
+
+-- | Inserts an entry with key @>=@ every key in the map. Assumes and preserves
+-- an extra invariant: the roots of the binomial trees are decreasing along
+-- the spine.
+insertMax' :: k -> a -> MinPQueue k a -> MinPQueue k a
+insertMax' k a Empty = MinPQ 1 k a Nil
+insertMax' k a (MinPQ n k' a' ts) = MinPQ (n + 1) k' a' (incrMax' (tip k a) ts)
+
+{-# INLINE fromList #-}
+-- | /O(n)/. Constructs a priority queue from an unordered list.
+fromList :: Ord k => [(k, a)] -> MinPQueue k a
+-- We build a forest first and then extract its minimum at the end.
+-- Why not just build the 'MinQueue' directly? This way saves us one
+-- comparison per element.
+fromList xs = case extractForest (<=) (fromListHeap (<=) xs) of
+  No -> Empty
+  -- Should we track the size as we go instead? That saves O(log n)
+  -- at the end, but it needs an extra register all along the way.
+  -- The nodes should probably all be in L1 cache already thanks to the
+  -- extractHeap.
+  Yes (Extract k v ~Zero f) -> MinPQ (sizeHeap f + 1) k v f
+
+{-# INLINE fromListHeap #-}
+fromListHeap :: CompF k -> [(k, a)] -> BinomHeap k a
+fromListHeap le xs = foldl' go Nil xs
+  where
+    go fr (k, a) = incr' le (tip k a) fr
+
+sizeHeap :: BinomHeap k a -> Int
+sizeHeap = go 0 1
+  where
+    go :: Int -> Int -> BinomForest rk k a -> Int
+    go acc rk Nil = rk `seq` acc
+    go acc rk (Skip f) = go acc (2 * rk) f
+    go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f
+
 -- | /O(1)/. Returns a binomial tree of rank zero containing this
 -- key and value.
 tip :: k -> a -> BinomTree Zero k a
@@ -265,10 +311,10 @@ meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2)
 -- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition.
 mergeForest :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a
 mergeForest le f1 f2 = case (f1, f2) of
-  (Skip ts1, Skip ts2)       -> Skip (mergeForest le ts1 ts2)
-  (Skip ts1, Cons t2 ts2)    -> Cons t2 (mergeForest le ts1 ts2)
-  (Cons t1 ts1, Skip ts2)    -> Cons t1 (mergeForest le ts1 ts2)
-  (Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest le (meld le t1 t2) ts1 ts2)
+  (Skip ts1, Skip ts2)       -> Skip $! mergeForest le ts1 ts2
+  (Skip ts1, Cons t2 ts2)    -> Cons t2 $! mergeForest le ts1 ts2
+  (Cons t1 ts1, Skip ts2)    -> Cons t1 $! mergeForest le ts1 ts2
+  (Cons t1 ts1, Cons t2 ts2) -> Skip $! carryForest le (meld le t1 t2) ts1 ts2
   (Nil, _)                   -> f2
   (_, Nil)                   -> f1
 
@@ -276,10 +322,13 @@ mergeForest le f1 f2 = case (f1, f2) of
 -- Analogous to binary addition when a digit has been carried.
 carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a
 carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of
-  (Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2)
-  (Cons t1 ts1, Skip ts2)    -> Skip (carryMeld t0 t1 ts1 ts2)
-  (Skip ts1, Cons t2 ts2)    -> Skip (carryMeld t0 t2 ts1 ts2)
-  (Skip ts1, Skip ts2)       -> Cons t0 (mergeForest le ts1 ts2)
+  (Cons t1 ts1, Cons t2 ts2) -> Cons t0 $! carryMeld t1 t2 ts1 ts2
+  (Cons t1 ts1, Skip ts2)    -> Skip $! carryMeld t0 t1 ts1 ts2
+  (Skip ts1, Cons t2 ts2)    -> Skip $! carryMeld t0 t2 ts1 ts2
+  (Skip ts1, Skip ts2)       -> Cons t0 $! mergeForest le ts1 ts2
+  -- Why do these use incr and not incr'? We want the merge to take
+  -- O(log(min(|f1|, |f2|))) amortized time. If we performed this final
+  -- increment eagerly, that would degrade to O(log(max(|f1|, |f2|))) time.
   (Nil, _)                   -> incr le t0 f2
   (_, Nil)                   -> incr le t0 f1
   where  carryMeld = carryForest le .: meld le
@@ -289,7 +338,15 @@ incr :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
 incr le t ts = t `seq` case ts of
   Nil         -> Cons t Nil
   Skip ts'    -> Cons t ts'
-  Cons t' ts' -> Skip (incr le (meld le t t') ts')
+  Cons t' ts' -> ts' `seq` Skip (incr le (meld le t t') ts')
+
+-- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation.
+-- Forces the rebuilt portion of the spine.
+incr' :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
+incr' le t ts = t `seq` case ts of
+  Nil         -> Cons t Nil
+  Skip ts'    -> Cons t ts'
+  Cons t' ts' -> Skip $! incr' le (meld le t t') ts'
 
 -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree
 -- is less than all other roots. Analogous to binary incrementation. Equivalent to
@@ -298,7 +355,23 @@ incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
 incrMin t@(BinomTree k a ts) tss = case tss of
   Nil          -> Cons t Nil
   Skip tss'    -> Cons t tss'
-  Cons t' tss' -> Skip (incrMin (BinomTree k a (Succ t' ts)) tss')
+  Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k a (Succ t' ts)) tss')
+
+-- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree
+-- is less than all other roots. Analogous to binary incrementation. Equivalent to
+-- @'incr'' (\_ _ -> True)@. Forces the rebuilt portion of the spine.
+incrMin' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
+incrMin' t@(BinomTree k a ts) tss = case tss of
+  Nil          -> Cons t Nil
+  Skip tss'    -> Cons t tss'
+  Cons t' tss' -> Skip $! incrMin' (BinomTree k a (Succ t' ts)) tss'
+
+-- | See 'insertMax'' for invariant info.
+incrMax' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a
+incrMax' t tss = t `seq` case tss of
+  Nil          -> Cons t Nil
+  Skip tss'    -> Cons t tss'
+  Cons (BinomTree k a ts) tss' -> Skip $! incrMax' (BinomTree k a (Succ t ts)) tss'
 
 extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a
 extractHeap le n ts = n `seq` case extractForest le ts of
@@ -330,29 +403,51 @@ extractHeap le n ts = n `seq` case extractForest le ts of
 --     Note that @forest@ is lazy, so if we discover a smaller key
 --     than @minKey@ later, we haven't wasted significant work.
 
-data Extract rk k a = Extract k a (rk k a) (BinomForest rk k a)
+data Extract rk k a = Extract !k a !(rk k a) !(BinomForest rk k a)
 data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a)
 
-incrExtract :: CompF k -> Maybe (BinomTree rk k a) -> Extract (Succ rk) k a -> Extract rk k a
-incrExtract _ Nothing (Extract k a (Succ t ts) tss)
-  = Extract k a ts (Cons t tss)
-incrExtract le (Just t) (Extract k a (Succ t' ts) tss)
-  = Extract k a ts (Skip (incr le (meld le t t') tss))
+incrExtract :: Extract (Succ rk) k a -> Extract rk k a
+incrExtract (Extract minKey minVal (Succ kChild kChildren) ts)
+  = Extract minKey minVal kChildren (Cons kChild ts)
+
+-- Why are we so lazy here? The idea, right or not, is to avoid a potentially
+-- expensive second pass to propagate carries. Instead, carry propagation gets
+-- fused (operationally) with successive operations. If the next operation is
+-- union or minView, this doesn't save anything, but if some insertions follow,
+-- it might be faster this way.
+incrExtract' :: CompF k -> BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a
+incrExtract' le t (Extract minKey minVal (Succ kChild kChildren) ts)
+  = Extract minKey minVal kChildren (Skip $ incr le (t `cat` kChild) ts)
+  where
+    cat = meld le
 
 -- | Walks backward from the biggest key in the forest, as far as rank @rk@.
 -- Returns its progress. Each successive application of @extractBin@ takes
 -- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time.
 extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a
-extractForest _ Nil = No
-extractForest le (Skip tss) = case extractForest le tss of
-  No     -> No
-  Yes ex -> Yes (incrExtract le Nothing ex)
-extractForest le (Cons t@(BinomTree k a0 ts) tss) = Yes $ case extractForest le tss of
-  Yes ex@(Extract k' _ _ _)
-    | k' <? k  -> incrExtract le (Just t) ex
-  _            -> Extract k a0 ts (Skip tss)
+extractForest le0 = start le0
   where
-    a <? b = not (b `le` a)
+    start :: CompF k -> BinomForest rk k a -> MExtract rk k a
+    start _le Nil = No
+    start le (Skip f) = case start le f of
+      No     -> No
+      Yes ex -> Yes (incrExtract ex)
+    start le (Cons t@(BinomTree k v ts) f) = Yes $ case go le k f of
+      No -> Extract k v ts (Skip f)
+      Yes ex -> incrExtract' le t ex
+
+    go :: CompF k -> k -> BinomForest rk k a -> MExtract rk k a
+    go _le _min_above Nil = _min_above `seq` No
+    go le min_above (Skip f) = case go le min_above f of
+      No -> No
+      Yes ex -> Yes (incrExtract ex)
+    go le min_above (Cons t@(BinomTree k v ts) f)
+      | min_above `le` k = case go le min_above f of
+          No -> No
+          Yes ex -> Yes (incrExtract' le t ex)
+      | otherwise = case go le k f of
+          No -> Yes (Extract k v ts (Skip f))
+          Yes ex -> Yes (incrExtract' le t ex)
 
 extract :: (Ord k) => BinomForest rk k a -> MExtract rk k a
 extract = extractForest (<=)
@@ -456,7 +551,13 @@ mapKeysMonoF f fCh ts0 = case ts0 of
     fCh' (Succ (BinomTree k a ts) tss) =
       Succ (BinomTree (f k) a (fCh ts)) (fCh tss)
 
--- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap.
+-- | /O(log n)/. @seqSpine q r@ forces the spine of @q@ and returns @r@.
+--
+-- Note: The spine of a 'MinPQueue' is stored somewhat lazily.  Most operations
+-- take great care to prevent chains of thunks from accumulating along the
+-- spine to the detriment of performance. However, 'mapKeysMonotonic' can leave
+-- expensive thunks in the structure and repeated applications of that function
+-- can create thunk chains.
 seqSpine :: MinPQueue k a -> b -> b
 seqSpine Empty z0 = z0
 seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where
diff --git a/src/Data/PQueue/Prio/Max.hs b/src/Data/PQueue/Prio/Max.hs
index c5b030e..edbea20 100644
--- a/src/Data/PQueue/Prio/Max.hs
+++ b/src/Data/PQueue/Prio/Max.hs
@@ -18,8 +18,6 @@
 -- bound is also specified; these bounds do not hold in a persistent context.
 --
 -- This implementation is based on a binomial heap augmented with a global root.
--- The spine of the heap is maintained lazily. To force the spine of the heap,
--- use 'seqSpine'.
 --
 -- We do not guarantee stable behavior.
 -- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there
@@ -471,6 +469,12 @@ assocsU = toListU
 toListU :: MaxPQueue k a -> [(k, a)]
 toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q)
 
--- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap.
+-- | /O(log n)/. @seqSpine q r@ forces the spine of @q@ and returns @r@.
+--
+-- Note: The spine of a 'MaxPQueue' is stored somewhat lazily. Most operations
+-- take great care to prevent chains of thunks from accumulating along the
+-- spine to the detriment of performance. However, 'mapKeysMonotonic' can leave
+-- expensive thunks in the structure and repeated applications of that function
+-- can create thunk chains.
 seqSpine :: MaxPQueue k a -> b -> b
 seqSpine (MaxPQ q) = Q.seqSpine q
diff --git a/src/Data/PQueue/Prio/Min.hs b/src/Data/PQueue/Prio/Min.hs
index afb9ae1..6c2f563 100644
--- a/src/Data/PQueue/Prio/Min.hs
+++ b/src/Data/PQueue/Prio/Min.hs
@@ -18,8 +18,6 @@
 -- bound is also specified; these bounds do not hold in a persistent context.
 --
 -- This implementation is based on a binomial heap augmented with a global root.
--- The spine of the heap is maintained lazily. To force the spine of the heap,
--- use 'seqSpine'.
 --
 -- We do not guarantee stable behavior.
 -- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there
@@ -176,7 +174,7 @@ instance (Read k, Read a) => Read (MinPQueue k a) where
 
 -- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@).
 unions :: Ord k => [MinPQueue k a] -> MinPQueue k a
-unions = List.foldl union empty
+unions = List.foldl' union empty
 
 -- | /O(1)/. The minimal (key, element) in the queue. Calls 'error' if empty.
 findMin :: MinPQueue k a -> (k, a)
@@ -317,24 +315,15 @@ spanWithKey p q = case minViewWithKey q of
 breakWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a)
 breakWithKey p = spanWithKey (not .: p)
 
--- | /O(n)/. Build a priority queue from the list of (key, value) pairs.
-fromList :: Ord k => [(k, a)] -> MinPQueue k a
-fromList = foldr (uncurry' insert) empty
-
 -- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./
 fromAscList :: [(k, a)] -> MinPQueue k a
-fromAscList = foldr (uncurry' insertMin) empty
+{-# INLINE fromAscList #-}
+fromAscList xs = List.foldl' (\q (k, a) -> insertMax' k a q) empty xs
 
 -- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./
 fromDescList :: [(k, a)] -> MinPQueue k a
-fromDescList = List.foldl' (\q (k, a) -> insertMin k a q) empty
-
-{-# RULES
-  "fromList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) .
-    fromList (build g) = g (uncurry' insert) empty;
-  "fromAscList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) .
-    fromAscList (build g) = g (uncurry' insertMin) empty;
-  #-}
+{-# INLINE fromDescList #-}
+fromDescList xs = List.foldl' (\q (k, a) -> insertMin' k a q) empty xs
 
 {-# INLINE keys #-}
 -- | /O(n log n)/. Return all keys of the queue in ascending order.
diff --git a/tests/PQueueTests.hs b/tests/PQueueTests.hs
index e9231c5..92ea50c 100644
--- a/tests/PQueueTests.hs
+++ b/tests/PQueueTests.hs
@@ -1,21 +1,27 @@
 module Main (main) where
 
 import qualified Data.PQueue.Prio.Max as PMax ()
-import qualified Data.PQueue.Prio.Min as PMin ()
+import qualified Data.PQueue.Prio.Min as PMin
 import qualified Data.PQueue.Max as Max ()
 import qualified Data.PQueue.Min as Min
 
 import Test.QuickCheck
+import Test.QuickCheck.Poly (OrdA)
 
 import System.Exit
 
 import qualified Data.List as List
+import Data.Function (on)
 import Control.Arrow (second)
 
 
 validMinToAscList :: [Int] -> Bool
 validMinToAscList xs = Min.toAscList (Min.fromList xs) == List.sort xs
 
+validMinPrioToAscList :: [(Int,OrdA)] -> Bool
+validMinPrioToAscList xs =
+  List.concatMap List.sort (List.groupBy ((==) `on` fst) (PMin.toAscList (PMin.fromList xs))) == List.sort xs
+
 validMinToDescList :: [Int] -> Bool
 validMinToDescList xs = Min.toDescList (Min.fromList xs) == List.sortBy (flip compare) xs
 
@@ -28,9 +34,20 @@ validMinToList xs = List.sort (Min.toList (Min.fromList xs)) == List.sort xs
 validMinFromAscList :: [Int] -> Bool
 validMinFromAscList xs = Min.fromAscList (List.sort xs) == Min.fromList xs
 
+validMinPrioFromAscList :: [(Int, OrdA)] -> Bool
+validMinPrioFromAscList xs =
+  List.concatMap List.sort (List.groupBy ((==) `on` fst) (PMin.toAscList (PMin.fromAscList sorted))) == sorted
+  where sorted = List.sort xs
+
 validMinFromDescList :: [Int] -> Bool
 validMinFromDescList xs = Min.fromDescList (List.sortBy (flip compare) xs) == Min.fromList xs
 
+validMinPrioFromDescList :: [(Int, OrdA)] -> Property
+validMinPrioFromDescList xs =
+  List.concatMap List.sort (List.groupBy ((==) `on` fst) (PMin.toAscList (PMin.fromDescList sorted))) === reverse sorted
+  where sorted = bsort xs
+        bsort = List.sortBy (flip compare)
+
 validMinUnion :: [Int] -> [Int] -> Bool
 validMinUnion xs1 xs2 = Min.union (Min.fromList xs1) (Min.fromList xs2) == Min.fromList (xs1 ++ xs2)
 
@@ -111,11 +128,14 @@ validFoldrU xs = Min.foldrU (+) 0 q == List.sum xs
 main :: IO ()
 main = do
   check validMinToAscList
+  check validMinPrioToAscList
   check validMinToDescList
   check validMinUnfoldr
   check validMinToList
   check validMinFromAscList
+  check validMinPrioFromAscList
   check validMinFromDescList
+  check validMinPrioFromDescList
   check validMinUnion
   check validMinMapMonotonic
   check validMinPartition