diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,7 @@
+# 0.1
+
+Overhauled the encoding; Sorry, incompatible with 0
+
 # 0
 
 Initial release
diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/bench.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}
+import Control.DeepSeq
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString as B
+import qualified Data.Binary as B
+import Data.Either
+import Data.Winery
+import Data.Word
+import Data.Text (Text)
+import qualified Data.Vector as V
+import GHC.Generics (Generic)
+import Gauge.Main
+import qualified Codec.Serialise as CBOR
+import qualified Data.Csv as CSV
+import Data.Winery.Term
+
+data Gender = Male | Female deriving (Show, Generic)
+
+instance Serialise Gender
+instance CBOR.Serialise Gender
+instance B.Binary Gender
+
+data TestRec = TestRec
+  { id_ :: !Int
+  , first_name :: !Text
+  , last_name :: !Text
+  , email :: !Text
+  , gender :: !Gender
+  , num :: !Int
+  , latitude :: !Double
+  , longitude :: !Double
+  } deriving (Show, Generic)
+
+instance NFData TestRec where
+  rnf TestRec{} = ()
+
+instance Serialise TestRec where
+  schemaVia = gschemaViaRecord
+  toEncoding = gtoEncodingRecord
+  deserialiser = gdeserialiserRecord Nothing
+
+instance B.Binary TestRec
+instance CBOR.Serialise TestRec
+
+main = do
+  winery <- B.readFile "benchmarks/data.winery"
+  binary <- B.readFile "benchmarks/data.binary"
+  cbor <- B.readFile "benchmarks/data.cbor"
+  Right (values :: [TestRec]) <- return $ deserialise winery
+  defaultMain
+    [ bgroup "serialise"
+      [ bench "winery" $ nf serialise values
+      , bench "binary" $ nf (BL.toStrict . B.encode) values
+      , bench "serialise" $ nf (BL.toStrict . CBOR.serialise) values
+      ]
+    , bgroup "deserialise"
+      [ bench "winery" $ nf (fromRight undefined . deserialise :: B.ByteString -> [TestRec]) winery
+      , bench "binary" $ nf (B.decode . BL.fromStrict :: B.ByteString -> [TestRec]) binary
+      , bench "serialise" $ nf (CBOR.deserialise . BL.fromStrict :: B.ByteString -> [TestRec]) cbor
+      ]
+    ]
diff --git a/src/Data/Winery.hs b/src/Data/Winery.hs
--- a/src/Data/Winery.hs
+++ b/src/Data/Winery.hs
@@ -8,12 +8,10 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE ExistentialQuantification #-}
 module Data.Winery
   ( Schema(..)
   , Serialise(..)
@@ -46,6 +44,7 @@
   -- * Generics
   , GSerialiseRecord
   , gschemaViaRecord
+  , GEncodeRecord
   , gtoEncodingRecord
   , gdeserialiserRecord
   , GSerialiseVariant
@@ -60,10 +59,10 @@
 import Control.Monad.Trans.Cont
 import Control.Monad.Reader
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.FastBuilder as BB
 import Data.Bits
 import Data.Dynamic
+import Data.Functor.Compose
 import Data.Functor.Identity
 import Data.Foldable
 import Data.Proxy
@@ -217,8 +216,8 @@
 
 -- | Serialise a value along with its schema.
 serialise :: Serialise a => a -> B.ByteString
-serialise a = BL.toStrict $ BB.toLazyByteString $ mappend (BB.word8 currentSchemaVersion)
-  $ snd $ toEncoding (schema [a], a)
+serialise a = BB.toStrictByteString $ mappend (BB.word8 currentSchemaVersion)
+  $ encodingBuilder $ toEncoding (schema [a], a)
 
 -- | Deserialise a 'serialise'd 'B.Bytestring'.
 deserialise :: Serialise a => B.ByteString -> Either StrategyError a
@@ -226,14 +225,14 @@
   Just (ver, bs) -> do
     m <- getDecoder $ SSchema ver
     ($bs) $ evalContT $ do
-      offB <- decodeVarInt
-      sch <- lift m
-      asks $ \bs' -> ($ B.drop offB bs') <$> getDecoderBy deserialiser sch
+      sizA <- decodeVarInt
+      sch <- lift $ m . B.take sizA
+      asks $ \bs' -> ($ B.drop sizA bs') <$> getDecoderBy deserialiser sch
   Nothing -> Left "Unexpected empty string"
 
 -- | Serialise a value without its schema.
 serialiseOnly :: Serialise a => a -> B.ByteString
-serialiseOnly = BL.toStrict . BB.toLazyByteString . snd . toEncoding
+serialiseOnly = BB.toStrictByteString . encodingBuilder . toEncoding
 {-# INLINE serialiseOnly #-}
 
 substSchema :: Serialise a => Proxy a -> [TypeRep] -> Schema
@@ -242,10 +241,10 @@
   | otherwise = schemaVia p ts
 
 currentSchemaVersion :: Word8
-currentSchemaVersion = 0
+currentSchemaVersion = 1
 
 bootstrapSchema :: Word8 -> Either StrategyError Schema
-bootstrapSchema 0 = Right $ SFix $ SVariant [("SSchema",[SWord8])
+bootstrapSchema 1 = Right $ SFix $ SVariant [("SSchema",[SWord8])
   ,("SUnit",[])
   ,("SBool",[])
   ,("SChar",[])
@@ -299,8 +298,8 @@
 
 instance Serialise Bool where
   schemaVia _ _ = SBool
-  toEncoding False = (1, BB.word8 0)
-  toEncoding True = (1, BB.word8 1)
+  toEncoding False = Encoding 1 (BB.word8 0)
+  toEncoding True = Encoding 1 (BB.word8 1)
   deserialiser = Deserialiser $ Plan $ \case
     SBool -> pure $ (/=0) <$> evalContT getWord8
     s -> unexpectedSchema "Serialise Bool" s
@@ -308,7 +307,7 @@
 
 instance Serialise Word8 where
   schemaVia _ _ = SWord8
-  toEncoding x = (1, BB.word8 x)
+  toEncoding x = Encoding 1 (BB.word8 x)
   deserialiser = Deserialiser $ Plan $ \case
     SWord8 -> pure $ evalContT getWord8
     s -> unexpectedSchema "Serialise Word8" s
@@ -316,7 +315,7 @@
 
 instance Serialise Word16 where
   schemaVia _ _ = SWord16
-  toEncoding x = (2, BB.word16BE x)
+  toEncoding x = Encoding 2 (BB.word16BE x)
   deserialiser = Deserialiser $ Plan $ \case
     SWord16 -> pure $ evalContT $ do
       a <- getWord8
@@ -327,7 +326,7 @@
 
 instance Serialise Word32 where
   schemaVia _ _ = SWord32
-  toEncoding x = (4, BB.word32BE x)
+  toEncoding x = Encoding 4 (BB.word32BE x)
   deserialiser = Deserialiser $ Plan $ \case
     SWord32 -> pure word32be
     s -> unexpectedSchema "Serialise Word32" s
@@ -335,7 +334,7 @@
 
 instance Serialise Word64 where
   schemaVia _ _ = SWord64
-  toEncoding x = (8, BB.word64BE x)
+  toEncoding x = Encoding 8 (BB.word64BE x)
   deserialiser = Deserialiser $ Plan $ \case
     SWord64 -> pure word64be
     s -> unexpectedSchema "Serialise Word64" s
@@ -343,7 +342,7 @@
 
 instance Serialise Word where
   schemaVia _ _ = SWord64
-  toEncoding x = (8, BB.word64BE $ fromIntegral x)
+  toEncoding x = Encoding 8 $ BB.word64BE $ fromIntegral x
   deserialiser = Deserialiser $ Plan $ \case
     SWord64 -> pure $ fromIntegral <$> word64be
     s -> unexpectedSchema "Serialise Word" s
@@ -351,7 +350,7 @@
 
 instance Serialise Int8 where
   schemaVia _ _ = SInt8
-  toEncoding x = (1, BB.int8 x)
+  toEncoding x = Encoding 1 (BB.int8 x)
   deserialiser = Deserialiser $ Plan $ \case
     SInt8 -> pure $ fromIntegral <$> evalContT getWord8
     s -> unexpectedSchema "Serialise Int8" s
@@ -359,7 +358,7 @@
 
 instance Serialise Int16 where
   schemaVia _ _ = SInt16
-  toEncoding x = (2, BB.int16BE x)
+  toEncoding x = Encoding 2 (BB.int16BE x)
   deserialiser = Deserialiser $ Plan $ \case
     SInt16 -> pure $ fromIntegral <$> word16be
     s -> unexpectedSchema "Serialise Int16" s
@@ -367,7 +366,7 @@
 
 instance Serialise Int32 where
   schemaVia _ _ = SInt32
-  toEncoding x = (4, BB.int32BE x)
+  toEncoding x = Encoding 4 (BB.int32BE x)
   deserialiser = Deserialiser $ Plan $ \case
     SInt32 -> pure $ fromIntegral <$> word32be
     s -> unexpectedSchema "Serialise Int32" s
@@ -375,7 +374,7 @@
 
 instance Serialise Int64 where
   schemaVia _ _ = SInt64
-  toEncoding x = (8, BB.int64BE x)
+  toEncoding x = Encoding 8 (BB.int64BE x)
   deserialiser = Deserialiser $ Plan $ \case
     SInt64 -> pure $ fromIntegral <$> word64be
     s -> unexpectedSchema "Serialise Int64" s
@@ -390,7 +389,7 @@
 
 instance Serialise Float where
   schemaVia _ _ = SFloat
-  toEncoding x = (4, BB.word32BE $ unsafeCoerce x)
+  toEncoding x = Encoding 4 $ BB.word32BE $ unsafeCoerce x
   deserialiser = Deserialiser $ Plan $ \case
     SFloat -> pure $ unsafeCoerce <$> word32be
     s -> unexpectedSchema "Serialise Float" s
@@ -398,7 +397,7 @@
 
 instance Serialise Double where
   schemaVia _ _ = SDouble
-  toEncoding x = (8, BB.word64BE $ unsafeCoerce x)
+  toEncoding x = Encoding 8 $ BB.word64BE $ unsafeCoerce x
   deserialiser = Deserialiser $ Plan $ \case
     SDouble -> pure $ unsafeCoerce <$> word64be
     s -> unexpectedSchema "Serialise Double" s
@@ -408,16 +407,17 @@
   schemaVia _ _ = SText
   toEncoding = toEncoding . T.encodeUtf8
   deserialiser = Deserialiser $ Plan $ \case
-    SText -> pure $ T.decodeUtf8 <$> getBytes
+    SText -> pure T.decodeUtf8
     s -> unexpectedSchema "Serialise Text" s
 
 -- | Encoded in variable-length quantity.
 newtype VarInt a = VarInt { getVarInt :: a } deriving (Show, Read, Eq, Ord, Enum
   , Bounded, Num, Real, Integral, Bits, Typeable)
 
-instance (Typeable a, Integral a, Bits a) => Serialise (VarInt a) where
+instance (Typeable a, Bits a, Integral a) => Serialise (VarInt a) where
   schemaVia _ _ = SInteger
-  toEncoding = encodeVarInt
+  toEncoding = encodeVarInt . getVarInt
+  {-# INLINE toEncoding #-}
   deserialiser = Deserialiser $ Plan $ \case
     SInteger -> pure $ evalContT decodeVarInt
     s -> unexpectedSchema "Serialise (VarInt a)" s
@@ -452,10 +452,9 @@
 
 instance Serialise B.ByteString where
   schemaVia _ _ = SBytes
-  toEncoding bs = encodeVarInt (B.length bs)
-    <> (Sum $ B.length bs, BB.byteString bs)
+  toEncoding bs = Encoding (B.length bs) (BB.byteString bs)
   deserialiser = Deserialiser $ Plan $ \case
-    SBytes -> pure getBytes
+    SBytes -> pure id
     s -> unexpectedSchema "Serialise ByteString" s
 
 instance Serialise a => Serialise [a] where
@@ -490,13 +489,13 @@
     getItem <- unPlan plan s
     return $ evalContT $ do
       n <- decodeVarInt
-      asks $ \bs -> [decodeAt (size * i) getItem bs | i <- [0..n - 1]]
+      asks $ \bs -> [decodeAt (size * i, size) getItem bs | i <- [0..n - 1]]
   SList s -> do
     getItem <- unPlan plan s
     return $ evalContT $ do
       n <- decodeVarInt
       offsets <- decodeOffsets n
-      asks $ \bs -> [decodeAt ofs getItem bs | ofs <- offsets]
+      asks $ \bs -> [decodeAt ofs getItem bs | ofs <- UV.toList offsets]
   s -> unexpectedSchema' "extractListWith ..." "[a]" s
 
 instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where
@@ -550,7 +549,7 @@
         m <- unPlan g sch
         return $ evalContT $ do
           offsets <- decodeOffsets (length schs)
-          lift $ decodeAt (unsafeIndex msg offsets i) m
+          lift $ decodeAt (unsafeIndexV msg offsets i) m
       Nothing -> errorStrategy $ rep <> ": Schema not found in " <> pretty (map fst schs)
   s -> unexpectedSchema' rep "a record" s
   where
@@ -580,11 +579,11 @@
       getB <- unwrapDeserialiser deserialiser sb
       return $ evalContT $ do
         offA <- decodeVarInt
-        asks $ \bs -> (getA bs, decodeAt offA getB bs)
-    SProductFixed [(VarInt la, sa), (_, sb)] -> do
+        asks $ \bs -> (decodeAt (0, offA) getA bs, decodeAt (offA, maxBound) getB bs)
+    SProductFixed [(VarInt la, sa), (VarInt lb, sb)] -> do
       getA <- unwrapDeserialiser deserialiser sa
       getB <- unwrapDeserialiser deserialiser sb
-      return $ \bs -> (getA bs, decodeAt la getB bs)
+      return $ \bs -> (decodeAt (0, la) getA bs, decodeAt (la, lb) getB bs)
     s -> unexpectedSchema "Serialise (a, b)" s
 
   constantSize _ = (+) <$> constantSize (Proxy :: Proxy a) <*> constantSize (Proxy :: Proxy b)
@@ -608,12 +607,12 @@
       return $ evalContT $ do
         offA <- decodeVarInt
         offB <- decodeVarInt
-        asks $ \bs -> (getA bs, decodeAt offA getB bs, decodeAt (offA + offB) getC bs)
-    SProductFixed [(VarInt la, sa), (VarInt lb, sb), (_, sc)] -> do
+        asks $ \bs -> (decodeAt (0, offA) getA bs, decodeAt (offA, offB) getB bs, decodeAt (offA + offB, maxBound) getC bs)
+    SProductFixed [(VarInt la, sa), (VarInt lb, sb), (VarInt lc, sc)] -> do
       getA <- unwrapDeserialiser deserialiser sa
       getB <- unwrapDeserialiser deserialiser sb
       getC <- unwrapDeserialiser deserialiser sc
-      return $ \bs -> (getA bs, decodeAt la getB bs, decodeAt (la + lb) getC bs)
+      return $ \bs -> (decodeAt (0, la) getA bs, decodeAt (la, lb) getB bs, decodeAt (la + lb, lc) getC bs)
     s -> unexpectedSchema "Serialise (a, b, c)" s
 
   constantSize _ = fmap sum $ sequence [constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b), constantSize (Proxy :: Proxy c)]
@@ -640,13 +639,13 @@
         offA <- decodeVarInt
         offB <- decodeVarInt
         offC <- decodeVarInt
-        asks $ \bs -> (getA bs, decodeAt offA getB bs, decodeAt (offA + offB) getC bs, decodeAt (offA + offB + offC) getD bs)
-    SProductFixed [(VarInt la, sa), (VarInt lb, sb), (VarInt lc, sc), (_, sd)] -> do
+        asks $ \bs -> (decodeAt (0, offA) getA bs, decodeAt (offB, offA) getB bs, decodeAt (offA + offB, offC) getC bs, decodeAt (offA + offB + offC, maxBound) getD bs)
+    SProductFixed [(VarInt la, sa), (VarInt lb, sb), (VarInt lc, sc), (VarInt ld, sd)] -> do
       getA <- unwrapDeserialiser deserialiser sa
       getB <- unwrapDeserialiser deserialiser sb
       getC <- unwrapDeserialiser deserialiser sc
       getD <- unwrapDeserialiser deserialiser sd
-      return $ \bs -> (getA bs, decodeAt la getB bs, decodeAt (la + lb) getC bs, decodeAt (la + lb + lc) getD bs)
+      return $ \bs -> (decodeAt (0, la) getA bs, decodeAt (la, lb) getB bs, decodeAt (la + lb, lc) getC bs, decodeAt (la + lb + lc, ld) getD bs)
     s -> unexpectedSchema "Serialise (a, b, c, d)" s
 
   constantSize _ = fmap sum $ sequence [constantSize (Proxy :: Proxy a), constantSize (Proxy :: Proxy b), constantSize (Proxy :: Proxy c), constantSize (Proxy :: Proxy d)]
@@ -654,8 +653,8 @@
 instance (Serialise a, Serialise b) => Serialise (Either a b) where
   schemaVia _ ts = SVariant [("Left", [substSchema (Proxy :: Proxy a) ts])
     , ("Right", [substSchema (Proxy :: Proxy b) ts])]
-  toEncoding (Left a) = (1, BB.word8 0) <> toEncoding a
-  toEncoding (Right b) = (1, BB.word8 1) <> toEncoding b
+  toEncoding (Left a) = Encoding 1 (BB.word8 0) <> toEncoding a
+  toEncoding (Right b) = Encoding 1 (BB.word8 1) <> toEncoding b
   deserialiser = Deserialiser $ Plan $ \case
     SVariant [(_, [sa]), (_, [sb])] -> do
       getA <- unwrapDeserialiser deserialiser sa
@@ -693,24 +692,17 @@
 extractConstructor = extractConstructorWith deserialiser
 {-# INLINE extractConstructor #-}
 
-data RecordDecoder i x = Done x | forall a. More !i !(Maybe a) !(Plan (Decoder a)) (RecordDecoder i (Decoder a -> x))
-
-deriving instance Functor (RecordDecoder i)
-
-instance Applicative (RecordDecoder i) where
-  pure = Done
-  Done f <*> a = fmap f a
-  More i p d k <*> c = More i p d (flip <$> k <*> c)
-
 -- | Generic implementation of 'schemaVia' for a record.
 gschemaViaRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> [TypeRep] -> Schema
 gschemaViaRecord p ts = SFix $ SRecord $ recordSchema (Proxy :: Proxy (Rep a)) (typeRep p : ts)
 
 -- | Generic implementation of 'toEncoding' for a record.
-gtoEncodingRecord :: (GSerialiseRecord (Rep a), Generic a) => a -> Encoding
+gtoEncodingRecord :: (GEncodeRecord (Rep a), Generic a) => a -> Encoding
 gtoEncodingRecord = encodeMulti . recordEncoder . from
 {-# INLINE gtoEncodingRecord #-}
 
+data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Plan (Decoder a))
+
 -- | Generic implementation of 'deserialiser' for a record.
 gdeserialiserRecord :: forall a. (GSerialiseRecord (Rep a), Generic a, Typeable a)
   => Maybe a -- ^ default value (optional)
@@ -718,18 +710,15 @@
 gdeserialiserRecord def = Deserialiser $ handleRecursion $ \case
   SRecord schs -> Strategy $ \decs -> do
     let schs' = [(k, (i, s)) | (i, (k, s)) <- zip [0..] schs]
-    let go :: RecordDecoder T.Text x -> Either StrategyError ([Int] -> x)
-        go (Done a) = Right $ const a
-        go (More name def' p k) = case lookup name schs' of
-          Nothing -> case def' of
-            Just d -> go k >>= \r -> return $ \offsets -> r offsets (pure d)
+    let go :: FieldDecoder T.Text x -> Compose (Either StrategyError) ((->) Offsets) (Decoder x)
+        go (FieldDecoder name def' p) = case lookup name schs' of
+          Nothing -> Compose $ case def' of
+            Just d -> Right (pure (pure d))
             Nothing -> Left $ rep <> ": Default value not found for " <> pretty name
-          Just (i, sch) -> do
-            getItem <- p `unPlan` sch `unStrategy` decs
-            r <- go k
-            return $ \offsets -> r offsets
-              $ decodeAt (unsafeIndex "Data.Winery.gdeserialiserRecord: impossible" offsets i) getItem
-    m <- go $ recordDecoder $ from <$> def
+          Just (i, sch) -> Compose $ case p `unPlan` sch `unStrategy` decs of
+            Right getItem -> Right $ \offsets -> decodeAt (unsafeIndexV "Data.Winery.gdeserialiserRecord: impossible" offsets i) getItem
+            Left e -> Left e
+    m <- getCompose $ unTransFusion (recordDecoder $ from <$> def) go
     return $ evalContT $ do
       offsets <- decodeOffsets (length schs)
       asks $ \bs -> to $ m offsets bs
@@ -738,49 +727,65 @@
     rep = "gdeserialiserRecord :: Deserialiser "
       <> viaShow (typeRep (Proxy :: Proxy a))
 
+class GEncodeRecord f where
+  recordEncoder :: f x -> [Encoding]
+
+instance (GEncodeRecord f, GEncodeRecord g) => GEncodeRecord (f :*: g) where
+  recordEncoder (f :*: g) = recordEncoder f ++ recordEncoder g
+  {-# INLINE recordEncoder #-}
+
+instance Serialise a => GEncodeRecord (S1 c (K1 i a)) where
+  recordEncoder (M1 (K1 a)) = pure $! toEncoding a
+  {-# INLINE recordEncoder #-}
+
+instance GEncodeRecord f => GEncodeRecord (C1 c f) where
+  recordEncoder (M1 a) = recordEncoder a
+  {-# INLINE recordEncoder #-}
+
+instance GEncodeRecord f => GEncodeRecord (D1 c f) where
+  recordEncoder (M1 a) = recordEncoder a
+  {-# INLINE recordEncoder #-}
+
 class GSerialiseRecord f where
   recordSchema :: proxy f -> [TypeRep] -> [(T.Text, Schema)]
-  recordEncoder :: f x -> [Encoding]
-  recordDecoder :: Maybe (f x) -> RecordDecoder T.Text (Decoder (f x))
+  recordDecoder :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) Decoder (Decoder (f x))
 
 instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where
   recordSchema _ ts = recordSchema (Proxy :: Proxy f) ts
     ++ recordSchema (Proxy :: Proxy g) ts
-  recordEncoder (f :*: g) = recordEncoder f ++ recordEncoder g
   recordDecoder def = (\f g -> (:*:) <$> f <*> g)
     <$> recordDecoder ((\(x :*: _) -> x) <$> def)
     <*> recordDecoder ((\(_ :*: x) -> x) <$> def)
 
 instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where
   recordSchema _ ts = [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), substSchema (Proxy :: Proxy a) ts)]
-  recordEncoder (M1 (K1 a)) = [toEncoding a]
-  recordDecoder def = More (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x)) (unK1 . unM1 <$> def) (getDeserialiser deserialiser)
-    $ Done $ fmap $ M1 . K1
+  recordDecoder def = TransFusion $ \k -> fmap (fmap (M1 . K1)) $ k $ FieldDecoder
+    (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x))
+    (unK1 . unM1 <$> def)
+    (getDeserialiser deserialiser)
 
 instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where
   recordSchema _ = recordSchema (Proxy :: Proxy f)
-  recordEncoder (M1 a) = recordEncoder a
   recordDecoder def = fmap M1 <$> recordDecoder (unM1 <$> def)
 
 instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where
   recordSchema _ = recordSchema (Proxy :: Proxy f)
-  recordEncoder (M1 a) = recordEncoder a
   recordDecoder def = fmap M1 <$> recordDecoder (unM1 <$> def)
 
 class GSerialiseProduct f where
   productSchema :: proxy f -> [TypeRep] -> [Schema]
   productEncoder :: f x -> [Encoding]
-  productDecoder :: RecordDecoder () (Decoder (f x))
+  productDecoder :: TransFusion (FieldDecoder ()) Decoder (Decoder (f x))
 
 instance GSerialiseProduct U1 where
   productSchema _ _ = []
   productEncoder _ = []
-  productDecoder = Done (pure U1)
+  productDecoder = pure (pure U1)
 
 instance (Serialise a) => GSerialiseProduct (K1 i a) where
   productSchema _ ts = [substSchema (Proxy :: Proxy a) ts]
   productEncoder (K1 a) = [toEncoding a]
-  productDecoder = More () Nothing (getDeserialiser deserialiser) $ Done $ fmap K1
+  productDecoder = TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder () Nothing (getDeserialiser deserialiser)
 
 instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where
   productSchema _ ts = productSchema (Proxy :: Proxy f) ts
@@ -794,14 +799,14 @@
 
 deserialiserProduct' :: GSerialiseProduct f => [Schema] -> Strategy (Decoder (f x))
 deserialiserProduct' schs0 = Strategy $ \recs -> do
-  let go :: Int -> [Schema] -> RecordDecoder () x -> Either StrategyError ([Int] -> x)
+  let go :: Int -> [Schema] -> TransList (FieldDecoder ()) Decoder x -> Either StrategyError (Offsets -> x)
       go _ _ (Done a) = Right $ const a
       go _ [] _ = Left "deserialiserProduct': Mismatching number of fields"
-      go i (sch : schs) (More () _ p k) = do
+      go i (sch : schs) (More (FieldDecoder () _ p) k) = do
         getItem <- unPlan p sch `unStrategy` recs
         r <- go (i + 1) schs k
-        return $ \offsets -> r offsets $ decodeAt (unsafeIndex "Data.Winery.gdeserialiserProduct: impossible" offsets i) getItem
-  m <- go 0 schs0 productDecoder
+        return $ \offsets -> r offsets $ decodeAt (unsafeIndexV "Data.Winery.gdeserialiserProduct: impossible" offsets i) getItem
+  m <- go 0 schs0 $ runTransFusion productDecoder
   return $ evalContT $ do
     offsets <- decodeOffsets (length schs0)
     asks $ \bs -> m offsets bs
@@ -820,14 +825,14 @@
   => Deserialiser a
 gdeserialiserVariant = Deserialiser $ handleRecursion $ \case
   SVariant schs0 -> Strategy $ \decs -> do
-    ds' <- sequence
+    ds' <- V.fromList <$> sequence
       [ case lookup name variantDecoder of
           Nothing -> Left $ rep <> ": Schema not found for " <> pretty name
           Just f -> f sch `unStrategy` decs
       | (name, sch) <- schs0]
     return $ evalContT $ do
       i <- decodeVarInt
-      lift $ fmap to $ unsafeIndex "Data.Winery.gdeserialiserVariant" ds' i
+      lift $ fmap to $ ds' V.! i
   s -> unexpectedSchema' rep "a variant" s
   where
     rep = "gdeserialiserVariant :: Deserialiser "
diff --git a/src/Data/Winery/Internal.hs b/src/Data/Winery/Internal.hs
--- a/src/Data/Winery/Internal.hs
+++ b/src/Data/Winery/Internal.hs
@@ -1,99 +1,168 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
 module Data.Winery.Internal
-  ( Encoding
+  ( Encoding(..)
   , encodeMulti
   , encodeVarInt
   , Decoder
   , decodeAt
   , decodeVarInt
+  , Offsets
   , decodeOffsets
   , getWord8
-  , getBytes
   , word16be
   , word32be
   , word64be
   , unsafeIndex
+  , unsafeIndexV
   , Strategy(..)
   , StrategyError
   , errorStrategy
+  , TransList(..)
+  , TransFusion(..)
+  , runTransFusion
   )where
 
 import Control.Applicative
 import Control.Monad
 import Control.Monad.Fix
+import Control.Monad.ST
 import Control.Monad.Trans.Cont
-import Data.ByteString.Builder
+import Data.ByteString.FastBuilder
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Unsafe as B
-import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.FastBuilder as BB
 import Data.Bits
 import Data.Dynamic
 import Data.Monoid
 import Data.Text.Prettyprint.Doc (Doc)
 import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)
+import qualified Data.Vector.Unboxed as U
+import qualified Data.Vector.Unboxed.Mutable as UM
 import Data.Word
 
-type Encoding = (Sum Int, Builder)
+data Encoding = Encoding
+  { encodingLength :: !Int, encodingBuilder :: !Builder }
 
+instance Monoid Encoding where
+  mempty = Encoding 0 mempty
+  mappend (Encoding m a) (Encoding n b) = Encoding (m + n) (mappend a b)
+
+rebuildEncoding :: Encoding -> Encoding
+rebuildEncoding (Encoding l b) = Encoding l (BB.rebuild b)
+
 type Decoder = (->) B.ByteString
 
-decodeAt :: Int -> Decoder a -> Decoder a
-decodeAt i m bs = m $ B.drop i bs
+decodeAt :: (Int, Int) -> Decoder a -> Decoder a
+decodeAt (i, l) m bs = m $ B.take l $ B.drop i bs
 
-encodeVarInt :: (Integral a, Bits a) => a -> Encoding
+encodeVarInt :: (Bits a, Integral a) => a -> Encoding
 encodeVarInt n
-  | n < 0x80 = (1, BB.word8 $ fromIntegral n)
-  | otherwise = let (s, b) = encodeVarInt (shiftR n 7)
-    in (1 + s, BB.word8 (setBit (fromIntegral n) 7) `mappend` b)
+  | n < 0 = case negate n of
+    n'
+      | n' < 0x40 -> e1 (fromIntegral n' `setBit` 6)
+      | otherwise -> go (e1 (0xc0 .|. fromIntegral n')) (shiftR n' 6)
+  | n < 0x40 = e1 (fromIntegral n)
+  | otherwise = go (e1 (fromIntegral n `setBit` 7 `clearBit` 6)) (shiftR n 6)
+  where
+  e1 = Encoding 1 . BB.word8
+  go !acc m
+    | m < 0x80 = acc `mappend` e1 (fromIntegral m)
+    | otherwise = go (acc <> e1 (setBit (fromIntegral m) 7)) (shiftR m 7)
+{-# INLINE encodeVarInt #-}
 
 getWord8 :: ContT r Decoder Word8
 getWord8 = ContT $ \k bs -> case B.uncons bs of
   Nothing -> k 0 bs
-  Just (x, bs') -> k x bs'
-
-getBytes :: Decoder B.ByteString
-getBytes = runContT decodeVarInt B.take
+  Just (x, bs') -> k x $! bs'
+{-# INLINE getWord8 #-}
 
 decodeVarInt :: (Num a, Bits a) => ContT r Decoder a
 decodeVarInt = getWord8 >>= \case
   n | testBit n 7 -> do
-      m <- decodeVarInt
-      return $! shiftL m 7 .|. clearBit (fromIntegral n) 7
+      m <- getWord8 >>= go
+      if testBit n 6
+        then return $! negate $ shiftL m 6 .|. fromIntegral n .&. 0x3f
+        else return $! shiftL m 6 .|. clearBit (fromIntegral n) 7
+    | testBit n 6 -> return $ negate $ fromIntegral $ clearBit n 6
     | otherwise -> return $ fromIntegral n
+  where
+    go n
+      | testBit n 7 = do
+        m <- getWord8 >>= go
+        return $! shiftL m 7 .|. clearBit (fromIntegral n) 7
+      | otherwise = return $ fromIntegral n
+{-# INLINE decodeVarInt #-}
 
 word16be :: B.ByteString -> Word16
-word16be = \s ->
-  (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|.
-  (fromIntegral (s `B.unsafeIndex` 1))
+word16be = \s -> if B.length s >= 2
+  then
+    (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|.
+    (fromIntegral (s `B.unsafeIndex` 1))
+  else error "word16be"
 
 word32be :: B.ByteString -> Word32
-word32be = \s ->
-  (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 24) .|.
-  (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 16) .|.
-  (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL`  8) .|.
-  (fromIntegral (s `B.unsafeIndex` 3) )
+word32be = \s -> if B.length s >= 4
+  then
+    (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 24) .|.
+    (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 16) .|.
+    (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL`  8) .|.
+    (fromIntegral (s `B.unsafeIndex` 3) )
+  else error "word32be"
 
 word64be :: B.ByteString -> Word64
-word64be = \s ->
-  (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 56) .|.
-  (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 48) .|.
-  (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 40) .|.
-  (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 32) .|.
-  (fromIntegral (s `B.unsafeIndex` 4) `unsafeShiftL` 24) .|.
-  (fromIntegral (s `B.unsafeIndex` 5) `unsafeShiftL` 16) .|.
-  (fromIntegral (s `B.unsafeIndex` 6) `unsafeShiftL`  8) .|.
-  (fromIntegral (s `B.unsafeIndex` 7) )
+word64be = \s -> if B.length s >= 8
+  then
+    (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 56) .|.
+    (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 48) .|.
+    (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 40) .|.
+    (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 32) .|.
+    (fromIntegral (s `B.unsafeIndex` 4) `unsafeShiftL` 24) .|.
+    (fromIntegral (s `B.unsafeIndex` 5) `unsafeShiftL` 16) .|.
+    (fromIntegral (s `B.unsafeIndex` 6) `unsafeShiftL`  8) .|.
+    (fromIntegral (s `B.unsafeIndex` 7) )
+  else error $ "word64be" ++ show s
 
 encodeMulti :: [Encoding] -> Encoding
-encodeMulti ls = foldMap encodeVarInt offsets <> foldMap id ls where
-  offsets = take (length ls - 1) $ map (getSum . fst) ls
+encodeMulti xs = rebuildEncoding
+  $ foldMap (encodeVarInt . encodingLength) (safeInit xs) <> mconcat xs
+  where
+    safeInit [] = []
+    safeInit [_] = []
+    safeInit (y:ys) = y : safeInit ys
+{-# INLINE encodeMulti #-}
 
-decodeOffsets :: Int -> ContT r Decoder [Int]
-decodeOffsets 0 = pure []
-decodeOffsets n = scanl (+) 0 <$> replicateM (n - 1) decodeVarInt
+type Offsets = U.Vector (Int, Int)
 
+decodeOffsets :: Int -> ContT r Decoder Offsets
+decodeOffsets 0 = pure U.empty
+decodeOffsets n = accum <$> U.replicateM (n - 1) decodeVarInt where
+  accum xs = runST $ do
+    r <- UM.unsafeNew (U.length xs + 1)
+    let go s i
+          | i == U.length xs = do
+            UM.write r i (s, maxBound)
+            U.unsafeFreeze r
+          | otherwise = do
+            let x = U.unsafeIndex xs i
+            let s' = s + x
+            UM.write r i (s, x)
+            go s' (i + 1)
+    go 0 0
+
+unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a
+unsafeIndexV err xs i
+  | i >= U.length xs || i < 0 = error err
+  | otherwise = U.unsafeIndex xs i
+{-# INLINE unsafeIndexV #-}
+
 unsafeIndex :: String -> [a] -> Int -> a
 unsafeIndex err xs i = (xs ++ repeat (error err)) !! i
 
@@ -124,3 +193,26 @@
 
 errorStrategy :: Doc AnsiStyle -> Strategy a
 errorStrategy = Strategy . const . Left
+
+newtype TransFusion f g a = TransFusion { unTransFusion :: forall h. Applicative h => (forall x. f x -> h (g x)) -> h a }
+
+runTransFusion :: TransFusion f g a -> TransList f g a
+runTransFusion (TransFusion k) = k (\f -> More f (Done id))
+
+instance Functor (TransFusion f g) where
+  fmap f (TransFusion m) = TransFusion $ \k -> fmap f (m k)
+  {-# INLINE fmap #-}
+
+instance Applicative (TransFusion f g) where
+  pure a = TransFusion $ \_ -> pure a
+  TransFusion a <*> TransFusion b = TransFusion $ \k -> a k <*> b k
+  {-# INLINE (<*>) #-}
+
+data TransList f g a = Done a | forall x. More (f x) (TransList f g (g x -> a))
+
+deriving instance Functor (TransList f g)
+
+instance Applicative (TransList f g) where
+  pure = Done
+  Done f <*> a = fmap f a
+  More i k <*> c = More i (flip <$> k <*> c)
diff --git a/src/Data/Winery/Term.hs b/src/Data/Winery/Term.hs
--- a/src/Data/Winery/Term.hs
+++ b/src/Data/Winery/Term.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase, ScopedTypeVariables #-}
 module Data.Winery.Term where
 
 import Control.Monad.Trans
@@ -12,6 +12,7 @@
 import Data.Winery
 import Data.Winery.Internal
 import Data.Word
+import qualified Data.Vector.Unboxed as V
 
 -- | Common representation for any winery data.
 -- Handy for prettyprinting winery-serialised data.
@@ -63,7 +64,7 @@
     SProduct schs -> do
       decoders <- traverse (unwrapDeserialiser $ go points) schs
       return $ evalContT $ do
-        offsets <- decodeOffsets (length decoders)
+        offsets <- V.toList <$> decodeOffsets (length decoders)
         asks $ \bs -> TProduct [decodeAt ofs dec bs | (dec, ofs) <- zip decoders offsets]
     SProductFixed schs -> do
       decoders <- traverse (\(VarInt n, sch) -> (,) n <$> unwrapDeserialiser (go points) sch) schs
@@ -73,14 +74,14 @@
     SRecord schs -> do
       decoders <- traverse (\(name, sch) -> (,) name <$> unwrapDeserialiser (go points) sch) schs
       return $ evalContT $ do
-        offsets <- decodeOffsets (length decoders)
+        offsets <- V.toList <$> decodeOffsets (length decoders)
         asks $ \bs -> TRecord [(name, decodeAt ofs dec bs) | ((name, dec), ofs) <- zip decoders offsets]
     SVariant schs -> do
       decoders <- traverse (\(name, sch) -> (,) name <$> traverse (unwrapDeserialiser (go points)) sch) schs
       return $ evalContT $ do
         tag <- decodeVarInt
         let (name, decs) = unsafeIndex ("decodeTerm/SVariant") decoders tag
-        offsets <- decodeOffsets (length decs)
+        offsets <- V.toList <$> decodeOffsets (length decs)
         asks $ \bs -> TVariant name [decodeAt ofs dec bs | (dec, ofs) <- zip decs offsets]
     SSelf i -> return $ unsafeIndex "decodeTerm/SSelf" points $ fromIntegral i
     SFix s' -> mfix $ \a -> go (a : points) `unwrapDeserialiser` s'
diff --git a/winery.cabal b/winery.cabal
--- a/winery.cabal
+++ b/winery.cabal
@@ -1,11 +1,11 @@
--- This file has been generated from package.yaml by hpack version 0.28.2.
+-- This file has been generated from package.yaml by hpack version 0.20.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: bfdedbe9822eecf89f3ba7e7ecbf8802c6078d4f65ce427c1f942dbc695ac72b
+-- hash: cd7f7da4332784c7d2fa7dab5a2c1c418d2f8c00ede5bbb3c1b560a6323fb4a6
 
 name:           winery
-version:        0
+version:        0.1
 synopsis:       Sustainable serialisation library
 description:    Please see the README on Github at <https://github.com/fumieval/winery#readme>
 category:       Data
@@ -18,6 +18,7 @@
 license-file:   LICENSE
 build-type:     Simple
 cabal-version:  >= 1.10
+
 extra-source-files:
     ChangeLog.md
     README.md
@@ -29,11 +30,12 @@
 library
   hs-source-dirs:
       src
-  ghc-options: -Wall
+  ghc-options: -Wall -O2
   build-depends:
       base >=4.7 && <5
     , bytestring
     , containers
+    , fast-builder
     , hashable
     , mtl
     , prettyprinter
@@ -52,14 +54,13 @@
 
 executable winery
   main-is: Main.hs
-  other-modules:
-      Paths_winery
   hs-source-dirs:
       app
   build-depends:
       base >=4.7 && <5
     , bytestring
     , containers
+    , fast-builder
     , hashable
     , mtl
     , prettyprinter
@@ -69,6 +70,8 @@
     , unordered-containers
     , vector
     , winery
+  other-modules:
+      Paths_winery
   default-language: Haskell2010
 
 test-suite spec
@@ -80,10 +83,40 @@
       base >=4.7 && <5
     , bytestring
     , containers
+    , fast-builder
     , hashable
     , mtl
     , prettyprinter
     , prettyprinter-ansi-terminal
+    , text
+    , transformers
+    , unordered-containers
+    , vector
+    , winery
+  other-modules:
+      Paths_winery
+  default-language: Haskell2010
+
+benchmark bench-winery
+  type: exitcode-stdio-1.0
+  main-is: bench.hs
+  hs-source-dirs:
+      benchmarks
+  ghc-options: -O2
+  build-depends:
+      base >=4.7 && <5
+    , binary
+    , bytestring
+    , cassava
+    , containers
+    , deepseq
+    , fast-builder
+    , gauge
+    , hashable
+    , mtl
+    , prettyprinter
+    , prettyprinter-ansi-terminal
+    , serialise
     , text
     , transformers
     , unordered-containers