diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,7 @@
+# 0.2.1.1
+
+- Merged PR #15 from @Russoul to decrease allocations and costs incurred by laziness
+
 # 0.2.1.0
 
 - `traceAll` and `traceTraversable` defined (https://github.com/avieth/contra-tracer/pull/9)
diff --git a/contra-tracer.cabal b/contra-tracer.cabal
--- a/contra-tracer.cabal
+++ b/contra-tracer.cabal
@@ -1,5 +1,5 @@
 name:                contra-tracer
-version:             0.2.1.0
+version:             0.2.1.1
 synopsis:            Arrow and contravariant tracers
 description:         A simple interface for logging, tracing and monitoring
 license:             Apache-2.0
diff --git a/src/Control/Tracer.hs b/src/Control/Tracer.hs
--- a/src/Control/Tracer.hs
+++ b/src/Control/Tracer.hs
@@ -51,6 +51,7 @@
 
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Control.Tracer
     ( Tracer (..)
@@ -140,7 +141,7 @@
 -- >   case event of
 -- >     This i -> use tr  -< i
 -- >     That _ -> squelch -< ()
--- 
+--
 -- The key point of using the arrow representation we have here is that this
 -- tracer will not necessarily need to force @event@: if the input tracer @tr@
 -- does not force its value, then @event@ will not be forced. To elaborate,
@@ -170,7 +171,12 @@
 newtype Tracer m a = Tracer { runTracer :: Arrow.TracerA m a () }
 
 instance Monad m => Contravariant (Tracer m) where
-  contramap f tracer = Tracer (arr f >>> use tracer)
+  -- Strict in `tracer` and strict in the `Tracer` constructor: a lazy
+  -- contramap builds a thunk that retains references to the arguments,
+  -- potentially keeping large heap objects alive. If the tracer is never
+  -- dispatched through (e.g. the relevant event never occurs), those objects
+  -- are never released.
+  contramap f !tracer = Tracer $! (arr f >>> use tracer)
 
 -- | @tr1 <> tr2@ will run @tr1@ and then @tr2@ with the same input.
 instance Monad m => Semigroup (Tracer m s) where
diff --git a/src/Control/Tracer/Arrow.hs b/src/Control/Tracer/Arrow.hs
--- a/src/Control/Tracer/Arrow.hs
+++ b/src/Control/Tracer/Arrow.hs
@@ -75,18 +75,40 @@
 
 instance Monad m => Arrow (TracerA m) where
   arr = compute
-  Squelching l     *** Squelching r     = Squelching (l  *** r )
-  Squelching l     *** Emitting   re rp = Emitting   (id *** re) (l  *** rp)
-  Emitting   le lp *** Squelching r     = Emitting   (le *** id) (lp *** r )
-  Emitting   le lp *** Emitting   re rp = Emitting   (le *** re) (lp *** rp)
+  Squelching l     *** Squelching r     = Squelching (l  **** r )
+  Squelching l     *** Emitting   re rp = Emitting   (id **** re) (l  **** rp)
+  Emitting   le lp *** Squelching r     = Emitting   (le **** id) (lp **** r )
+  Emitting   le lp *** Emitting   re rp = Emitting   (le **** re) (lp **** rp)
 
 instance Monad m => ArrowChoice (TracerA m) where
-  Squelching l     +++ Squelching r     = Squelching (l +++ r)
-  Squelching l     +++ Emitting   re rp = Emitting   (id +++ re) (l  +++ rp)
-  Emitting   le lp +++ Squelching r     = Emitting   (le +++ id) (lp +++ r )
-  Emitting   le lp +++ Emitting   re rp = Emitting   (le +++ re) (lp +++ rp)
+  Squelching l     +++ Squelching r     = Squelching (l   +++ r )
+  Squelching l     +++ Emitting   re rp = Emitting   (id  +++ re) (l   +++ rp)
+  Emitting   le lp +++ Squelching r     = Emitting   (le  +++ id) (lp  +++ r )
+  Emitting   le lp +++ Emitting   re rp = Emitting   (le  +++ re) (lp  +++ rp)
 
+  -- Without explicit (|||) equations the class default fires:
+  --   f ||| g = left f >>> arr (either id id) >>> right g
+  -- which inserts an extra arr (either id id) step on every dispatch.
+  Squelching l     ||| Squelching r     = Squelching (l   ||| r )
+  Squelching l     ||| Emitting   re rp = Emitting   (id  +++ re) (l   ||| rp)
+  Emitting   le lp ||| Squelching r     = Emitting   (le  +++ id) (lp  ||| r )
+  Emitting   le lp ||| Emitting   re rp = Emitting   (le  +++ re) (lp  ||| rp)
+
 -- | Use a natural transformation to change the underlying monad.
 nat :: (forall x . m x -> n x) -> TracerA m a b -> TracerA n a b
 nat h (Squelching (Kleisli k))             = Squelching (Kleisli (h . k))
 nat h (Emitting   (Kleisli k) (Kleisli l)) = Emitting   (Kleisli (h . k)) (Kleisli (h . l))
+
+-- Optimal parallel composition for 'Kleisli' arrows. The 'Arrow' class default
+--
+--   f *** g = first f >>> arr swap >>> first g >>> arr swap
+--
+-- allocates ~1,000 bytes of short-lived thunks per '(***)' level per dispatch
+-- because the lazy irrefutable pattern @~(b,d)@ in 'first' allocates two
+-- thunks on every call that the simplifier cannot eliminate. This strict
+-- version eliminates all per-dispatch allocation.
+infixr 3 ****
+(****) :: Monad m => Kleisli m a b -> Kleisli m c d -> Kleisli m (a, c) (b, d)
+(Kleisli f) **** (Kleisli g) =
+    Kleisli $ \(b, d) -> f b >>= \c -> g d >>= \e -> return (c, e)
+{-# INLINE (****) #-}