diff --git a/echo-client/Main.hs b/echo-client/Main.hs
new file mode 100644
--- /dev/null
+++ b/echo-client/Main.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+module Main where
+
+import Control.Concurrent (threadDelay)
+import Hans.Address.Mac
+import Hans.DhcpClient
+import Hans.NetworkStack
+import System.Environment (getArgs)
+
+#ifdef HaLVM_HOST_OS
+import Hans.Device.Xen
+import Hypervisor.Console
+import Hypervisor.XenStore
+import XenDevice.NIC
+#else
+import Hans.Device.Tap
+#endif
+
+main :: IO ()
+main  = do
+
+  [ip] <- getArgs
+  let addr = read ip
+
+  ns  <- newNetworkStack
+  mac <- initEthernetDevice ns
+
+  deviceUp ns mac
+  putStrLn "Network stack running..."
+
+  putStrLn "Discovering address"
+
+  mbIP <- dhcpDiscover ns mac
+  case mbIP of
+    Nothing -> putStrLn "Couldn't get an IP address."
+    Just self -> do
+      putStrLn ("Bound to address: " ++ show self)
+
+      sock <- connect ns addr 9001 Nothing
+      putStrLn ("Connected to: " ++ show addr)
+
+      putStrLn "Sending bytes..."
+      sent <- sendBytes sock "Hello"
+
+      putStrLn ("Sent " ++ show sent ++ " bytes")
+      print =<< recvBytes sock 512
+
+      threadDelay 1000000
+
+      close sock
+
+#ifdef HaLVM_HOST_OS
+initEthernetDevice :: NetworkStack -> IO Mac
+initEthernetDevice ns =
+  do xs <- initXenStore
+     _ <- initXenConsole -- should set up putStrLn
+     nics <- listNICs xs
+     case nics of
+       [] -> fail "No NICs found to use!"
+       (macstr:_) ->
+         do let mac = read macstr
+            nic <- openNIC xs macstr
+            addDevice ns mac (xenSend nic) (xenReceiveLoop nic)
+            return mac
+#else
+initEthernetDevice :: NetworkStack -> IO Mac
+initEthernetDevice ns = do
+  let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x57
+  Just dev <- openTapDevice "tap7"
+  addDevice ns mac (tapSend dev) (tapReceiveLoop dev)
+  return mac
+#endif
diff --git a/hans.cabal b/hans.cabal
--- a/hans.cabal
+++ b/hans.cabal
@@ -1,5 +1,5 @@
 name:           hans
-version:        2.4.0.0
+version:        2.4.0.1
 cabal-version:  >= 1.8
 license:        BSD3
 license-file:   LICENSE
@@ -60,7 +60,8 @@
                                 containers >= 0.3.0.0,
                                 monadLib   >= 3.6.0,
                                 time       >= 1.1.0.0,
-                                fingertree >= 0.0.1.0
+                                fingertree >= 0.0.1.0,
+                                stm        >= 2.4
 
         if flag(word32-in-random)
                 build-depends:  random     >= 1.0.1.0
@@ -144,7 +145,8 @@
 executable web-server
         main-is:        Main.hs
         hs-source-dirs: web-server
-        ghc-options:    -Wall -threaded -rtsopts
+        ghc-options:    -Wall -threaded -rtsopts -fno-warn-unused-do-bind
+                        -fno-warn-orphans
 
         if os(HaLVM)
                 buildable: False
@@ -168,7 +170,7 @@
 executable tcp-test
         main-is:        Main.hs
         hs-source-dirs: tcp-test
-        ghc-options:    -Wall -threaded
+        ghc-options:    -Wall -rtsopts -threaded
         build-depends:  base       >= 4.0.0.0 && < 5,
                         cereal     >= 0.3.5.2,
                         bytestring >= 0.9.1.0,
@@ -180,6 +182,33 @@
         if os(HaLVM)
                 build-depends:      XenDevice     >= 2.0.0 && < 3.0.0,
                                     HALVMCore     >= 2.0.0 && < 3.0.0
+
+executable echo-client
+        main-is:        Main.hs
+        hs-source-dirs: echo-client
+        ghc-options:    -Wall -rtsopts -threaded
+        build-depends:  base       >= 4.0.0.0 && < 5,
+                        cereal     >= 0.3.5.2,
+                        bytestring >= 0.9.1.0,
+                        containers >= 0.3.0.0,
+                        monadLib   >= 3.6.0,
+                        time       >= 1.1.0.0,
+                        old-locale >= 1.0.0.0,
+                        hans
+        if os(HaLVM)
+                build-depends:      XenDevice     >= 2.0.0 && < 3.0.0,
+                                    HALVMCore     >= 2.0.0 && < 3.0.0
+
+executable tcp-test-client
+        main-is:        Main.hs
+        hs-source-dirs: tcp-test-client
+        if os(HaLVM)
+                buildable:          False
+        else
+                build-depends:      base,
+                                    bytestring,
+                                    network
+
 
 executable test-suite
         hs-source-dirs: tests
diff --git a/src/Hans/DhcpClient.hs b/src/Hans/DhcpClient.hs
--- a/src/Hans/DhcpClient.hs
+++ b/src/Hans/DhcpClient.hs
@@ -16,7 +16,8 @@
 import Hans.NetworkStack
 import Hans.Timers (delay_)
 
-import Control.Monad (guard)
+import Control.Monad (guard,unless)
+import Control.Concurrent.STM
 import Data.Maybe (fromMaybe,mapMaybe)
 import System.Random (randomIO)
 import qualified Data.ByteString as S
@@ -45,22 +46,66 @@
 
 -- DHCP ------------------------------------------------------------------------
 
-type AckHandler = IP4 -> IO ()
-
 -- | Discover a dhcp server, and request an address.
 dhcpDiscover :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack
                 , HasDns stack )
-             => stack -> Mac -> AckHandler -> IO ()
-dhcpDiscover ns mac h = do
+             => stack -> Mac -> IO (Maybe IP4)
+dhcpDiscover ns mac = do
+  addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns)
+
+  offerTMV <- newEmptyTMVarIO
+  addUdpHandler ns bootpc (handleOffer ns offerTMV)
+
   w32 <- randomIO
   let xid = Xid (fromIntegral (w32 :: Int))
+      disc = discoverToMessage (mkDiscover xid mac)
 
-  addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns)
-  addUdpHandler ns bootpc (handleOffer ns (Just h))
+  --  waitResult sends our DHCP discover and waits for an offer.
+  mbOffer <- waitResult retries disc offerTMV
+  case mbOffer of
 
-  let disc = discoverToMessage (mkDiscover xid mac)
-  sendMessage ns disc currentNetwork broadcastIP4 broadcastMac
+    -- We exceeded our retries, give up.
+    Nothing    -> return Nothing
 
+    --  We got an offer
+    --  - Install an DHCP Ack handler.
+    --  - Send a DHCP Request via waitResult, and wait for an IP to appear in resp.
+    Just offer -> do
+      resp <- newEmptyTMVarIO
+      addUdpHandler ns bootpc (handleAck ns offer (Just (atomically . putTMVar resp)))
+      let req = requestToMessage (offerToRequest offer)
+      waitResult retries req resp
+
+  where
+    -- RFC 2131 says to do exponential backoff starting at 4s and going to 64s.
+    -- It also says to add random noise between -1s and +1s, but we're skipping that for now.
+    initialTimeout :: Int
+    initialTimeout = 4000000 -- 4 seconds in µs
+
+    retries :: Int
+    retries = 6
+
+    -- Sends a message and waits for a response (indicated by a value appearing the TMVar)
+    -- until timeout. Retries a given number of times doubling the backoff each time.
+    waitResult :: Int -> Dhcp4Message -> TMVar a -> IO (Maybe a)
+    waitResult n msg result = go n initialTimeout
+      where
+        go 0 _to = return Nothing
+        go i  to =
+          do sendMessage ns msg currentNetwork broadcastIP4 broadcastMac
+             timeout <- registerDelay to
+             -- If there is a result, return Just it.
+             -- If not, and we aren't timed out, retry.
+             -- If we are timed out, return Nothing.
+             mb <- atomically $ orElse (fmap Just (takeTMVar result))
+                                       (do isTimedOut <- readTVar timeout
+                                           unless isTimedOut retry
+                                           return Nothing)
+             -- Exponential backoff on timeout, return result on success.
+             case mb of
+               Just _  -> return mb
+               Nothing -> go (i-1) (to * 2)
+
 -- | Restore the connection between the Ethernet and IP4 layers.
 restoreIp4 :: (HasEthernet stack, HasIP4 stack) => stack -> IO ()
 restoreIp4 ns = connectEthernet (ip4Handle ns) (ethernetHandle ns)
@@ -83,21 +128,18 @@
 -- | Handle a DHCP Offer message.
 --
 --  * Remove the current UDP handler
---  * Install an DHCP Ack handler
---  * Send a DHCP Request
+--  * Write offer to TMV for retrieval.
 handleOffer :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack
                , HasDns stack )
-            => stack -> Maybe AckHandler -> IP4 -> UdpPort
+            => stack -> TMVar Offer -> IP4 -> UdpPort
             -> S.ByteString -> IO ()
-handleOffer ns mbh _src _srcPort bytes =
+handleOffer ns tmv _src _srcPort bytes =
   case getDhcp4Message bytes of
     Right msg -> case parseDhcpMessage msg of
 
       Just (Right (OfferMessage offer)) -> do
         removeUdpHandler ns bootpc
-        let req = requestToMessage (offerToRequest offer)
-        addUdpHandler ns bootpc (handleAck ns offer mbh)
-        sendMessage ns req currentNetwork broadcastIP4 broadcastMac
+        atomically $ putTMVar tmv offer
 
       msg1 -> do
         putStrLn (show msg)
@@ -107,6 +149,11 @@
 
 -- | Handle a DHCP Ack message.
 --
+--   The optional handler (mbh) is present only the first time handleAck is
+--   installed, so we can update the main thread on our IP assignment. After
+--   that (when dhcpRenew installs handleAck) it is Nothing, because we just
+--   have to update the network stack.
+--
 --  * Remove the custom IP4 handler
 --  * Restore the connection between the Ethernet and IP4 layers
 --  * Remove the bootpc UDP listener
@@ -115,7 +162,7 @@
 --    has passed
 handleAck :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack
              , HasDns stack )
-          => stack -> Offer -> Maybe AckHandler -> IP4 -> UdpPort
+          => stack -> Offer -> Maybe (IP4 -> IO ()) -> IP4 -> UdpPort
           -> S.ByteString -> IO ()
 handleAck ns offer mbh _src _srcPort bytes =
   case getDhcp4Message bytes of
@@ -142,7 +189,7 @@
 --
 --  * Re-install the DHCP IP4 handler
 --  * Add a UDP handler for an Ack message
---  * Re-send a renquest message, generated from the offer given.
+--  * Re-send a request message, generated from the offer given.
 dhcpRenew :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack
              , HasDns stack )
           => stack -> Offer -> IO ()
diff --git a/src/Hans/Layer.hs b/src/Hans/Layer.hs
--- a/src/Hans/Layer.hs
+++ b/src/Hans/Layer.hs
@@ -14,14 +14,14 @@
 import Data.Time.Clock.POSIX
 import MonadLib (StateM(get,set),BaseM(inBase))
 import qualified Control.Exception as X
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 
 data LayerState i = LayerState
-  { lsNow     :: POSIXTime
-  , lsState   :: i
+  { lsNow     :: !POSIXTime
+  , lsState   :: !i
   }
 
-data Action = Nop | Action (IO ())
+data Action = Nop | Action !(IO ())
 
 instance Monoid Action where
   mempty = Nop
@@ -35,9 +35,9 @@
 runAction (Action m) = m `X.catch` \ se -> print (se :: X.SomeException)
 
 data Result i a
-  = Error Action
-  | Exit (LayerState i) Action
-  | Result (LayerState i) a Action
+  = Error !Action
+  | Exit !(LayerState i) !Action
+  | Result !(LayerState i) !a !Action
 
 -- | Early exit continuation
 type Exit i r = LayerState i -> Action -> Result i r
@@ -67,7 +67,7 @@
   loop i = do
     a   <- msg
     now <- getPOSIXTime
-    let res = runLayer (i {lsNow = now }) (k a)
+    let res = (runLayer $! i {lsNow = now }) (k a)
     _ <- X.evaluate res `X.catch` \ se -> do
            putStrLn (name ++ show (se :: X.SomeException))
            return res
@@ -98,8 +98,8 @@
   mplus = (<|>)
 
 instance StateM (Layer i) i where
-  get   = Layer (\i0 o0 _ _ k -> k (lsState i0) i0 o0)
-  set i = Layer (\i0 o0 _ _ k -> k () (i0 { lsState = i }) o0)
+  get   = Layer (\i0 o0 _ _ k -> (k $! lsState i0) i0 o0)
+  set i = Layer (\i0 o0 _ _ k -> (k () $! i0 { lsState = i }) o0)
 
 instance BaseM (Layer i) (Layer i) where
   inBase = id
@@ -118,10 +118,10 @@
 
 {-# INLINE time #-}
 time :: Layer i POSIXTime
-time  = Layer (\i o _ _ k -> k (lsNow i) i o)
+time  = Layer (\i o _ _ k -> (k $! lsNow i) i o)
 
 output :: IO () -> Layer i ()
-output m = Layer $ \i0 o0 _ _ k -> k () i0 (o0 `mappend` Action m)
+output m = Layer $ \i0 o0 _ _ k -> k () i0 $! o0 `mappend` Action m
 
 liftRight :: Either String b -> Layer i b
 liftRight (Right b)  = return b
diff --git a/src/Hans/Layer/Arp.hs b/src/Hans/Layer/Arp.hs
--- a/src/Hans/Layer/Arp.hs
+++ b/src/Hans/Layer/Arp.hs
@@ -27,7 +27,7 @@
 import Control.Monad (forM_,mplus,guard,unless,when)
 import MonadLib (BaseM(inBase),set,get)
 import qualified Data.ByteString.Lazy as L
-import qualified Data.Map             as Map
+import qualified Data.Map.Strict      as Map
 import qualified Data.ByteString      as S
 
 
@@ -69,11 +69,11 @@
 type Arp = Layer ArpState
 
 data ArpState = ArpState
-  { arpTable    :: ArpTable
-  , arpAddrs    :: Map.Map IP4 Mac -- this layer's addresses
-  , arpWaiting  :: Map.Map IP4 [Maybe Mac -> IO ()]
-  , arpEthernet :: EthernetHandle
-  , arpSelf     :: ArpHandle
+  { arpTable    :: !ArpTable
+  , arpAddrs    :: !(Map.Map IP4 Mac) -- this layer's addresses
+  , arpWaiting  :: !(Map.Map IP4 [Maybe Mac -> IO ()])
+  , arpEthernet :: {-# UNPACK #-} !EthernetHandle
+  , arpSelf     :: {-# UNPACK #-} !ArpHandle
   }
 
 emptyArpState :: ArpHandle -> EthernetHandle -> ArpState
diff --git a/src/Hans/Layer/Arp/Table.hs b/src/Hans/Layer/Arp/Table.hs
--- a/src/Hans/Layer/Arp/Table.hs
+++ b/src/Hans/Layer/Arp/Table.hs
@@ -5,7 +5,7 @@
 
 import Control.Arrow (second)
 import Data.Time.Clock.POSIX (POSIXTime)
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 
 
 -- Arp Table -------------------------------------------------------------------
@@ -14,15 +14,15 @@
 arpEntryTimeout = 60
 
 data ArpEntry
-  = ArpEntry    { arpMac     :: Mac
-                , arpTimeout :: POSIXTime
+  = ArpEntry    { arpMac     :: {-# UNPACK #-} !Mac
+                , arpTimeout :: !POSIXTime
                 }
-  | ArpPending  { arpTimeout :: POSIXTime
+  | ArpPending  { arpTimeout :: !POSIXTime
                 }
  deriving Show
 
 data ArpResult
-  = KnownAddress Mac
+  = KnownAddress {-# UNPACK #-} !Mac
   | Pending
   | Unknown
 
@@ -43,8 +43,8 @@
 -- | Assumption: there is not already a pending ARP query recorded in the
 -- ARP table for the given IP address.
 addPending :: POSIXTime -> IP4 -> ArpTable -> ArpTable
-addPending now ip = Map.insert ip ent where
-  ent = ArpPending
+addPending now ip =
+  Map.insert ip ArpPending
     { arpTimeout = now + arpEntryTimeout -- FIXME: should queries stay longer?
     }
 
diff --git a/src/Hans/Layer/Dns.hs b/src/Hans/Layer/Dns.hs
--- a/src/Hans/Layer/Dns.hs
+++ b/src/Hans/Layer/Dns.hs
@@ -38,7 +38,7 @@
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as L
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 
 
 -- External Interface ----------------------------------------------------------
@@ -103,12 +103,12 @@
 
 type Dns = Layer DnsState
 
-data DnsState = DnsState { dnsSelf        :: DnsHandle
-                         , dnsUdpHandle   :: UdpHandle
-                         , dnsNameServers :: [IP4]
-                         , dnsReqId       :: !Word16
-                         , dnsQueries     :: Map.Map Word16 DnsQuery
-                         , dnsTimeout     :: Milliseconds
+data DnsState = DnsState { dnsSelf        :: {-# UNPACK #-} !DnsHandle
+                         , dnsUdpHandle   :: {-# UNPACK #-} !UdpHandle
+                         , dnsNameServers :: ![IP4]
+                         , dnsReqId       :: {-# UNPACK #-} !Word16
+                         , dnsQueries     :: !(Map.Map Word16 DnsQuery)
+                         , dnsTimeout     :: {-# UNPACK #-} !Milliseconds
                          }
 
 emptyDnsState :: DnsHandle -> UdpHandle -> DnsState
diff --git a/src/Hans/Layer/Ethernet.hs b/src/Hans/Layer/Ethernet.hs
--- a/src/Hans/Layer/Ethernet.hs
+++ b/src/Hans/Layer/Ethernet.hs
@@ -31,7 +31,7 @@
 import Control.Monad (mplus)
 import MonadLib (get,set)
 import qualified Data.ByteString.Lazy as L
-import qualified Data.Map             as Map
+import qualified Data.Map.Strict      as Map
 import qualified Data.ByteString      as S
 
 
@@ -96,9 +96,9 @@
 type Eth = Layer EthernetState
 
 data EthernetState = EthernetState
-  { ethHandlers :: Handlers EtherType Handler
-  , ethDevices  :: Map.Map Mac EthernetDevice
-  , ethHandle   :: EthernetHandle
+  { ethHandlers :: !(Handlers EtherType Handler)
+  , ethDevices  :: !(Map.Map Mac EthernetDevice)
+  , ethHandle   :: {-# UNPACK #-} !EthernetHandle
   }
 
 instance ProvidesHandlers EthernetState EtherType Handler where
diff --git a/src/Hans/Layer/IP4.hs b/src/Hans/Layer/IP4.hs
--- a/src/Hans/Layer/IP4.hs
+++ b/src/Hans/Layer/IP4.hs
@@ -33,7 +33,7 @@
 import Hans.Utils.Checksum
 
 import Control.Concurrent (forkIO)
-import Control.Monad (guard,mplus,(<=<))
+import Control.Monad (guard, (<=<))
 import MonadLib (get,set)
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString      as S
@@ -72,11 +72,11 @@
 type IP = Layer IP4State
 
 data IP4State = IP4State
-  { ip4Fragments :: FragmentationTable IP4
-  , ip4Routes    :: RoutingTable IP4
-  , ip4Handlers  :: Handlers IP4Protocol Handler
-  , ip4NextIdent :: Ident
-  , ip4ArpHandle :: ArpHandle
+  { ip4Fragments :: !(FragmentationTable IP4)
+  , ip4Routes    :: !(RoutingTable IP4)
+  , ip4Handlers  :: !(Handlers IP4Protocol Handler)
+  , ip4NextIdent :: {-# UNPACK #-} !Ident
+  , ip4ArpHandle :: {-# UNPACK #-} !ArpHandle
   }
 
 instance ProvidesHandlers IP4State IP4Protocol Handler where
@@ -124,10 +124,10 @@
   state <- get
   just (route addr (ip4Routes state))
 
-
--- | Route a packet that is forwardable
-forward :: IP4Header -> L.ByteString -> IP ()
-forward hdr body = do
+-- Route a packet that is forwardable.
+-- XXX Hide this facility behind configuration
+_forward :: IP4Header -> L.ByteString -> IP ()
+_forward hdr body = do
   rule@(src,_,_) <- findRoute (ip4DestAddr hdr)
   guard (src /= ip4SourceAddr hdr)
   sendPacket' hdr body rule
@@ -138,23 +138,21 @@
   state <- get
   guard (ip `elem` localAddrs (ip4Routes state))
 
-
-findSourceMask :: IP4 -> IP IP4Mask
-findSourceMask ip = do
+_findSourceMask :: IP4 -> IP IP4Mask
+_findSourceMask ip = do
   state <- get
   just (sourceMask ip (ip4Routes state))
 
-
-broadcastDestination :: IP4 -> IP ()
-broadcastDestination ip = do
-  mask <- findSourceMask ip
+_broadcastDestination :: IP4 -> IP ()
+_broadcastDestination ip = do
+  mask <- _findSourceMask ip
   guard (isBroadcast mask ip)
 
 -- | Route a message to a local handler
 routeLocal :: IP4Header -> S.ByteString -> IP ()
 routeLocal hdr body = do
   let dest = ip4DestAddr hdr
-  localAddress dest `mplus` broadcastDestination dest
+  localAddress dest
   h  <- getHandler (ip4Protocol hdr)
   mb <- handleFragments hdr body
   case mb of
@@ -194,7 +192,9 @@
 
   -- forward?
   let payload = S.take (plen - hlen) rest
-  routeLocal hdr payload `mplus` forward hdr (chunk payload)
+  routeLocal hdr payload
+    -- XXX Hide this old router functionality behind a setting
+    -- `mplus` forward hdr (chunk payload)
 
 
 handleAddRule :: Rule IP4Mask IP4 -> IP ()
diff --git a/src/Hans/Layer/IP4/Fragmentation.hs b/src/Hans/Layer/IP4/Fragmentation.hs
--- a/src/Hans/Layer/IP4/Fragmentation.hs
+++ b/src/Hans/Layer/IP4/Fragmentation.hs
@@ -9,7 +9,7 @@
 import Data.Ord (comparing)
 import Data.Time.Clock.POSIX (POSIXTime)
 import qualified Data.ByteString.Lazy as L
-import qualified Data.Map             as Map
+import qualified Data.Map.Strict      as Map
 import qualified Data.ByteString      as S
 
 
@@ -21,14 +21,14 @@
 
 data Fragments = Fragments
   { startTime :: !POSIXTime
-  , totalSize :: !Int
-  , fragments :: [Fragment]
+  , totalSize :: {-# UNPACK #-} !Int
+  , fragments :: ![Fragment]
   } deriving Show
 
 data Fragment = Fragment
-  { fragmentOffset  :: !Int
-  , fragmentLength  :: !Int
-  , fragmentPayload :: L.ByteString
+  { fragmentOffset  :: {-# UNPACK #-} !Int
+  , fragmentLength  :: {-# UNPACK #-} !Int
+  , fragmentPayload :: !L.ByteString
   } deriving (Eq,Show)
 
 instance Ord Fragment where
diff --git a/src/Hans/Layer/Icmp4.hs b/src/Hans/Layer/Icmp4.hs
--- a/src/Hans/Layer/Icmp4.hs
+++ b/src/Hans/Layer/Icmp4.hs
@@ -18,6 +18,7 @@
 import qualified Hans.Layer.IP4 as IP4
 
 import Control.Concurrent (forkIO)
+import Control.Monad (unless)
 import Data.Serialize (runPut,putByteString)
 import MonadLib (get,set)
 import qualified Data.ByteString as S
@@ -37,8 +38,8 @@
   void (forkIO (loopLayer "icmp4" handles (receive h) id))
 
 data Icmp4Handles = Icmp4Handles
-  { icmpIp4      :: IP4.IP4Handle
-  , icmpHandlers :: [Handler]
+  { icmpIp4      :: {-# UNPACK #-} !IP4.IP4Handle
+  , icmpHandlers :: ![Handler]
   }
 
 type Icmp4 = Layer Icmp4Handles
@@ -106,4 +107,4 @@
 matchHandlers :: Icmp4Packet -> Icmp4 ()
 matchHandlers pkt = do
   s <- get
-  output (mapM_ ($ pkt) (icmpHandlers s))
+  unless (null (icmpHandlers s)) (output (mapM_ ($ pkt) (icmpHandlers s)))
diff --git a/src/Hans/Layer/Tcp.hs b/src/Hans/Layer/Tcp.hs
--- a/src/Hans/Layer/Tcp.hs
+++ b/src/Hans/Layer/Tcp.hs
@@ -18,6 +18,7 @@
 import Hans.Utils
 
 import Control.Concurrent (forkIO)
+import Control.Monad (when)
 import Data.Time.Clock.POSIX (getPOSIXTime,POSIXTime)
 import qualified Data.ByteString as S
 
@@ -30,7 +31,7 @@
   addIP4Handler ip4 tcpProtocol (queueTcp tcp)
 
   -- initialize the timers
-  send tcp initTimers
+  initTimers tcp
 
 -- | Queue a tcp packet.
 queueTcp :: TcpHandle -> IP4Header -> S.ByteString -> IO ()
@@ -43,15 +44,16 @@
 -- | Run the tcp action, after updating any internal state.
 stepTcp :: Tcp () -> Tcp ()
 stepTcp body = do
-  now <- time
-  modifyHost $ \ host ->
-    let diff = now - hostLastUpdate host
-        -- increment the ISN at 128KHz
-        inc  = round (isnRate * diff)
-     in if inc > 0
-           then host
-             { hostLastUpdate    = now
-             , hostInitialSeqNum = hostInitialSeqNum host + inc
-             }
-           else host
+  now        <- time
+  lastUpdate <- getLastUpdate
+  let diff = now - lastUpdate
+      -- increment the ISN at 128KHz
+      inc  = round (isnRate * diff)
+
+  when (inc > 0) $
+    modifyHost_ $ \ host ->
+      host { hostLastUpdate    = now
+           , hostInitialSeqNum = hostInitialSeqNum host + inc
+           }
+
   body
diff --git a/src/Hans/Layer/Tcp/Handlers.hs b/src/Hans/Layer/Tcp/Handlers.hs
--- a/src/Hans/Layer/Tcp/Handlers.hs
+++ b/src/Hans/Layer/Tcp/Handlers.hs
@@ -20,7 +20,7 @@
 import Control.Monad (guard,when,unless,join)
 import Data.Bits (bit)
 import Data.Int (Int64)
-import Data.Maybe (fromMaybe,isJust,isNothing)
+import Data.Maybe (fromMaybe,isJust)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Foldable as F
@@ -44,8 +44,7 @@
 
 noConnection :: IP4 -> TcpHeader -> S.ByteString -> Tcp ()
 noConnection src hdr @ TcpHeader { .. } body =
-  do output (putStrLn "no connection")
-     if | tcpRst    -> return ()
+  do if | tcpRst    -> return ()
         | tcpAck    -> sendSegment src (mkRst hdr)                    L.empty
         | otherwise -> sendSegment src (mkRstAck hdr (S.length body)) L.empty
      finish
@@ -100,10 +99,7 @@
 
 segmentArrives :: IP4 -> TcpHeader -> S.ByteString -> Sock ()
 segmentArrives src hdr body =
-  do shouldDrop <- modifyTcpSocket (updateTimestamp hdr)
-     when shouldDrop discardAndReturn
-
-     whenState Closed (inTcp (noConnection src hdr body))
+  do whenState Closed (inTcp (noConnection src hdr body))
 
      whenState Listen $
        do when (tcpAck hdr) (rst hdr)
@@ -116,6 +112,9 @@
           -- wasn't covered by the above two cases.
           done
 
+     shouldDrop <- modifyTcpSocket (updateTimestamp hdr)
+     when shouldDrop discardAndReturn
+
      whenState SynSent $
        do tcp <- getTcpSocket
 
@@ -143,8 +142,7 @@
           -- check SYN
 
           when (tcpSyn hdr) $
-            do advanceRcvNxt 1
-               modifyTcpSocket_ $ \ sock -> sock
+            do modifyTcpSocket_ $ \ sock -> sock
                  { tcpOutMSS      = fromMaybe (tcpInMSS sock) (getMSS hdr)
 
                    -- clear out, and configure the retransmit buffer
@@ -153,20 +151,25 @@
                                   $ clearRetransmit
                                   $ tcpOut sock
 
-                   -- this corresponds to setting IRS to SEQ.SEG
-                 , tcpIn          = emptyLocalWindow (tcpSeqNum hdr) 14600 0
+                   -- this corresponds to setting IRS to SEQ.SEG, and advancing
+                   -- RCV.NXT by one
+                 , tcpIn          = emptyLocalWindow (tcpSeqNum hdr + 1) 14600 0
                  , tcpSack        = sackSupported hdr
                  , tcpWindowScale = isJust (findTcpOption OptTagWindowScaling hdr)
                  }
 
                when (tcpAck hdr) $
-                 do handleAck hdr -- update SND.UNA
+                 do -- advance SND.UNA
+                    modifyTcpSocket_ $ \ sock -> sock
+                      { tcpSndUna = tcpAckNum hdr }
+
                     TcpSocket { .. } <- getTcpSocket
                     if tcpSndUna > tcpIss
                        then do ack
-                               establishConnection
                                notify True
 
+                               setState Established
+
                                -- continue at step 6
                                when (tcpUrg hdr) (proceedFromStep6 hdr body)
 
@@ -177,6 +180,8 @@
 
                     done
 
+          when (not (tcpSyn hdr || tcpRst hdr)) discardAndReturn
+
      -- make sure that the sequence numbers are valid
      checkSequenceNumber hdr body
      checkResetBit hdr
@@ -220,23 +225,13 @@
 -- | Process the presence of the RST bit
 checkResetBit :: TcpHeader -> Sock ()
 checkResetBit hdr
-  | tcpRst hdr =
-    do TcpSocket { .. } <- getTcpSocket
-
-       whenState SynReceived $
-            -- from an active open
-         do when (isNothing tcpParent) $ do flushQueues
-                                            closeSocket
-            done
-
-       whenStates [Established,FinWait1,FinWait2,CloseWait] $
-         do flushQueues
-            closeSocket
-            done
-
-       whenStates [Closing,LastAck] $
-         do closeSocket
-            done
+  | tcpRst hdr = do
+      TcpSocket { .. } <- getTcpSocket
+      whenStates [ SynReceived, Established, FinWait1, FinWait2
+                 , CloseWait, Closing, LastAck] $
+        do notify False
+           closeSocket
+           done
 
   | otherwise  = return ()
 
@@ -247,8 +242,7 @@
     do tcp <- getTcpSocket
 
        when (tcpSeqNum hdr `inRcvWnd` tcp) $
-         do flushQueues
-            closeSocket
+         do closeSocket
             done
 
   | otherwise  = return ()
@@ -286,7 +280,8 @@
                  when (nothingOutstanding tcp) enterTimeWait
 
        whenState LastAck $
-         do tcp <- getTcpSocket
+         do handleAck hdr
+            tcp <- getTcpSocket
             when (nothingOutstanding tcp) $ do closeSocket
                                                done
 
@@ -296,7 +291,7 @@
 processSegmentText hdr body =
   whenStates [Established,FinWait1,FinWait2] $
     do if S.null body
-          -- make sure that the the delayed ack flag gets set
+          -- make sure that the delayed ack flag gets set
           then when (tcpSyn hdr || tcpFin hdr) $ modifyTcpTimers_
                                                $ \ tt -> tt { ttDelayedAck = True }
 
@@ -356,14 +351,18 @@
   do finalizers <- modifyTcpSocket flush
      outputS finalizers
   where
-  flush tcp = (fins,tcp')
+  flush tcp = (inFins >> outFins,tcp')
     where
 
     -- empty the outgoing buffer, notifying all waiting processes that the send
     -- won't happen
-    (fins,out') = flushWaiting (tcpOutBuffer tcp)
+    (outFins,out') = flushWaiting (tcpOutBuffer tcp)
 
+    -- empty the input buffer
+    (inFins, in')  = flushWaiting (tcpInBuffer tcp)
+
     tcp' = tcp { tcpOutBuffer = out'
+               , tcpInBuffer  = in'
                }
 
 
@@ -372,13 +371,14 @@
 --
 -- RFC 1323
 updateTimestamp :: TcpHeader -> TcpSocket -> (Bool,TcpSocket)
-updateTimestamp hdr tcp = (shouldDrop,tcp { tcpTimestamp = ts' })
+updateTimestamp hdr tcp 
+  | shouldDrop = (True, tcp)
+  | otherwise  = (False,tcp { tcpTimestamp = ts' })
   where
   -- when the timestamp check fails from an ack, that's not a syn,ack, mark this
   -- packet as one to be dropped.
   shouldDrop = not (tcpSyn hdr || tcpRst hdr)
-            && isJust (tcpTimestamp tcp)
-            && isNothing ts'
+            && isJust (tcpTimestamp tcp) /= isJust ts'
   ts' = do
     ts                     <- tcpTimestamp tcp
     OptTimestamp them echo <- findTcpOption OptTagTimestamp hdr
diff --git a/src/Hans/Layer/Tcp/Monad.hs b/src/Hans/Layer/Tcp/Monad.hs
--- a/src/Hans/Layer/Tcp/Monad.hs
+++ b/src/Hans/Layer/Tcp/Monad.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Hans.Layer.Tcp.Monad where
 
@@ -20,7 +21,6 @@
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Map.Strict as Map
 import qualified Data.Sequence as Seq
-import qualified Data.Traversable as T
 
 
 -- TCP Monad -------------------------------------------------------------------
@@ -30,9 +30,9 @@
 type Tcp = Layer TcpState
 
 data TcpState = TcpState
-  { tcpSelf  :: TcpHandle
-  , tcpIP4   :: IP4Handle
-  , tcpHost  :: Host
+  { tcpSelf  :: {-# UNPACK #-} !TcpHandle
+  , tcpIP4   :: {-# UNPACK #-} !IP4Handle
+  , tcpHost  :: !Host
   }
 
 emptyTcpState :: TcpHandle -> IP4Handle -> POSIXTime -> TcpState
@@ -56,19 +56,29 @@
 getHost :: Tcp Host
 getHost  = tcpHost `fmap` get
 
+getLastUpdate :: Tcp POSIXTime
+getLastUpdate  = hostLastUpdate `fmap` getHost
+
 setHost :: Host -> Tcp ()
 setHost host = do
   rw <- get
-  set $! rw { tcpHost = host }
+  host `seq` set rw { tcpHost = host }
 
-modifyHost :: (Host -> Host) -> Tcp ()
+modifyHost_ :: (Host -> Host) -> Tcp ()
+modifyHost_ f = do
+  host <- getHost
+  setHost (f host)
+
+modifyHost :: (Host -> (a,Host)) -> Tcp a
 modifyHost f = do
   host <- getHost
-  setHost $! f host
+  let (a,host') = f host
+  setHost host'
+  return a
 
 -- | Reset the 2MSL timer on the socket in TimeWait.
 resetTimeWait2MSL :: SocketId -> Tcp ()
-resetTimeWait2MSL sid = modifyHost $ \ host ->
+resetTimeWait2MSL sid = modifyHost_ $ \ host ->
   host { hostTimeWaits = Map.adjust twReset2MSL sid (hostTimeWaits host) }
 
 getTimeWait :: IP4 -> TcpHeader -> Tcp (Maybe (SocketId,TimeWaitSock))
@@ -80,14 +90,19 @@
 
 removeTimeWait :: SocketId -> Tcp ()
 removeTimeWait sid =
-  modifyHost $ \ host ->
+  modifyHost_ $ \ host ->
     host { hostTimeWaits = Map.delete sid (hostTimeWaits host) }
 
 getConnections :: Tcp Connections
 getConnections  = hostConnections `fmap` getHost
 
+takeConnections :: Tcp Connections
+takeConnections  =
+  modifyHost $ \ Host { .. } ->
+    (hostConnections, Host { hostConnections = Map.empty, .. })
+
 setConnections :: Connections -> Tcp ()
-setConnections cons = modifyHost (\host -> host { hostConnections = cons })
+setConnections cons = modifyHost_ (\host -> host { hostConnections = cons })
 
 -- | Lookup a connection, returning @Nothing@ if the connection doesn't exist.
 lookupConnection :: SocketId -> Tcp (Maybe TcpSocket)
@@ -117,7 +132,7 @@
 setConnection :: SocketId -> TcpSocket -> Tcp ()
 setConnection ident con
   | tcpState con == TimeWait =
-    modifyHost $ \ host ->
+    modifyHost_ $ \ host ->
       host { hostTimeWaits   = addTimeWait con (hostTimeWaits host)
            , hostConnections = Map.delete ident (hostConnections host)
            }
@@ -162,7 +177,7 @@
 -- | Increment the initial sequence number by a value.
 addInitialSeqNum :: TcpSeqNum -> Tcp ()
 addInitialSeqNum sn =
-  modifyHost (\host -> host { hostInitialSeqNum = hostInitialSeqNum host + sn })
+  modifyHost_ (\host -> host { hostInitialSeqNum = hostInitialSeqNum host + sn })
 
 -- | Allocate a new port for use.
 allocatePort :: Tcp TcpPort
@@ -176,7 +191,7 @@
 
 -- | Release a used port.
 closePort :: TcpPort -> Tcp ()
-closePort port = modifyHost (releasePort port)
+closePort port = modifyHost_ (releasePort port)
 
 
 -- Socket Monad ----------------------------------------------------------------
@@ -190,17 +205,16 @@
 -- locally.  This gives the ability to simulate `finished`, with the benefit of
 -- only yielding from the Sock context, not the whole Tcp context.
 newtype Sock a = Sock
-  { unSock :: forall r. TcpSocket -> Escape r -> Next a r
-           -> Tcp (TcpSocket,Maybe r)
+  { unSock :: forall r. TcpSocket -> Escape r -> Next a r -> Tcp r
   }
 
-type Escape r = TcpSocket -> Tcp (TcpSocket,Maybe r)
-
-type Next a r = TcpSocket -> a -> Tcp (TcpSocket, Maybe r)
+type Escape r = TcpSocket      -> Tcp r
+type Next a r = TcpSocket -> a -> Tcp r
 
 instance Functor Sock where
   fmap f m = Sock $ \s  x k -> unSock m s x
                   $ \s' a   -> k s' (f a)
+  {-# INLINE fmap #-}
 
 instance Applicative Sock where
   {-# INLINE pure #-}
@@ -217,10 +231,16 @@
 
   m >>= f = Sock $ \ s  x k -> unSock m s x
                  $ \ s' a   -> unSock (f a) s' x k
+  {-# INLINE (>>=) #-}
 
+  m >> n = Sock $ \ s  x k -> unSock m s  x
+                $ \ s' _   -> unSock n s' x k
+  {-# INLINE (>>) #-}
+
 inTcp :: Tcp a -> Sock a
 inTcp m = Sock $ \ s _ k -> do a <- m
                                k s a
+{-# INLINE inTcp #-}
 
 
 -- | Finish early, with no result.
@@ -232,19 +252,27 @@
   do _ <- runSock tcp sm
      return ()
 
-runSock' :: TcpSocket -> Sock a -> Tcp TcpSocket
-runSock' tcp sm =
-  do (tcp',_) <- runSock tcp sm
-     return tcp'
+runSock :: TcpSocket -> Sock a -> Tcp (Maybe a)
+runSock tcp sm =
+  do (tcp',mb) <- runSock' tcp sm
+     setConnection (tcpSocketId tcp') $! tcp'
+     return mb
 
--- | Run the socket action, and increment its internal timestamp value.
-runSock :: TcpSocket -> Sock a -> Tcp (TcpSocket,Maybe a)
-runSock tcp sm = do
+seqMaybe :: Maybe a -> ()
+seqMaybe (Just a) = a `seq` ()
+seqMaybe Nothing  = ()
+
+-- | Run the socket action, and increment its internal timestamp value.  Do not
+-- add it back to the connections map.
+runSock' :: TcpSocket -> Sock a -> Tcp (TcpSocket,Maybe a)
+runSock' tcp sm = do
   now      <- time
-  let steppedTcp = tcp { tcpTimestamp = stepTimestamp now `fmap` tcpTimestamp tcp }
-  r@(tcp',_) <- unSock sm steppedTcp escapeK nextK
-  addConnection (tcpSocketId tcp') tcp'
-  return r
+  let steppedTcp = tcp { tcpTimestamp =
+                           let ts' = stepTimestamp now `fmap` tcpTimestamp tcp
+                            in seqMaybe ts' `seq` ts'
+                       }
+  res@(tcp',_) <- (unSock sm $! steppedTcp) escapeK nextK
+  tcp' `seq` return res
   where
   escapeK s = return (s,Nothing)
   nextK s a = return (s,Just a)
@@ -253,13 +281,31 @@
 -- computation fails.
 eachConnection :: Sock () -> Tcp ()
 eachConnection m =
-  setConnections . removeClosed =<< T.mapM sandbox =<< getConnections
+  do cs       <- takeConnections
+     (cs',ws) <- sandbox [] [] (Map.elems cs)
+
+     modifyHost_ $ \ Host { .. } ->
+       Host { hostConnections = cs'
+            , hostTimeWaits   = Map.union ws hostTimeWaits
+            , ..
+            }
+
   where
 
   -- Prevent failure in the socket action from leaking out of this scope.  When
   -- failure is detected, just return the old TCB
-  sandbox tcp = runSock' tcp m `mplus` return tcp
+  sandbox active timeWait (tcp:rest) =
+    do tcp' <- fmap fst (runSock' tcp m) `mplus` return tcp
 
+       if | tcpState tcp' == TimeWait -> sandbox       active (tcp':timeWait) rest
+          | tcpState tcp' == Closed
+            && tcpUserClosed tcp'     -> sandbox       active       timeWait  rest
+          | otherwise                 -> sandbox (tcp':active)      timeWait  rest
+
+  sandbox active timeWait [] =
+    return ( Map.fromList [ (tcpSocketId tcp, tcp)            | tcp <- active ]
+           , Map.fromList [ (tcpSocketId tcp, mkTimeWait tcp) | tcp <- timeWait ])
+
 withConnection :: IP4 -> TcpHeader -> Sock a -> Tcp ()
 withConnection remote hdr m = withConnection' remote hdr m mzero
 
@@ -277,7 +323,7 @@
 listeningConnection sid m = do
   tcp <- getConnection sid
   guard (tcpState tcp == Listen && isAccepting tcp)
-  (_,mb) <- runSock tcp m
+  mb <- runSock tcp m
   return mb
 
 -- | Run a socket operation in the context of the socket identified by the
@@ -300,27 +346,29 @@
 inParent m = do
   mbPid <- getParent
   case mbPid of
-    Just pid -> inTcp $ do p      <- getConnection pid
-                           (_,mb) <- runSock p m
+    Just pid -> inTcp $ do p  <- getConnection pid
+                           mb <- runSock p m
                            return mb
     Nothing  -> return Nothing
 
 withChild :: TcpSocket -> Sock a -> Sock (Maybe a)
-withChild tcp m = inTcp $ do (_,mb) <- runSock tcp m
+withChild tcp m = inTcp $ do mb <- runSock tcp m
                              return mb
 
 getTcpSocket :: Sock TcpSocket
-getTcpSocket  = Sock (\s _ k -> k s s)
+getTcpSocket  = Sock (\s _ k -> k s $! s)
+{-# INLINE getTcpSocket #-}
 
 setTcpSocket :: TcpSocket -> Sock ()
-setTcpSocket tcp = Sock (\ _ _ k -> k tcp ())
+setTcpSocket tcp = Sock (\ _ _ k -> (k $! tcp) ())
+{-# INLINE setTcpSocket #-}
 
 getTcpTimers :: Sock TcpTimers
 getTcpTimers  = tcpTimers `fmap` getTcpSocket
 
 modifyTcpSocket :: (TcpSocket -> (a,TcpSocket)) -> Sock a
 modifyTcpSocket f = Sock $ \ s _ k -> let (a,s') = f s
-                                       in k s' a
+                                       in (k $! s') a
 
 modifyTcpSocket_ :: (TcpSocket -> TcpSocket) -> Sock ()
 modifyTcpSocket_ k = modifyTcpSocket (\tcp -> ((), k tcp))
@@ -407,8 +455,8 @@
 shutdown :: Sock ()
 shutdown  = do
   finalize <- modifyTcpSocket $ \ tcp -> 
-      let (wOut,bufOut) = shutdownWaiting (tcpOutBuffer tcp)
-          (wIn,bufIn)   = shutdownWaiting (tcpInBuffer tcp)
+      let (wOut,bufOut) = flushWaiting (tcpOutBuffer tcp)
+          (wIn,bufIn)   = flushWaiting (tcpInBuffer tcp)
        in (wOut >> wIn,tcp { tcpOut       = clearRetransmit (tcpOut tcp)
                            , tcpOutBuffer = bufOut
                            , tcpInBuffer  = bufIn
@@ -420,3 +468,6 @@
 closeSocket  = do
   shutdown
   setState Closed
+
+userClose :: Sock ()
+userClose  = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True })
diff --git a/src/Hans/Layer/Tcp/Socket.hs b/src/Hans/Layer/Tcp/Socket.hs
--- a/src/Hans/Layer/Tcp/Socket.hs
+++ b/src/Hans/Layer/Tcp/Socket.hs
@@ -27,7 +27,7 @@
 import Control.Exception (Exception,throwIO)
 import Control.Monad (mplus)
 import Data.Int (Int64)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (isJust)
 import Data.Typeable (Typeable)
 import qualified Data.ByteString.Lazy as L
 
@@ -35,7 +35,7 @@
 -- Socket Interface ------------------------------------------------------------
 
 data Socket = Socket
-  { sockHandle :: TcpHandle
+  { sockHandle :: !TcpHandle
   , sockId     :: !SocketId
   }
 
@@ -100,8 +100,9 @@
               }
             else socketError ConnectionRefused
         , tcpState     = Listen
-        , tcpSndNxt    = isn
+        , tcpSndNxt    = isn + 1
         , tcpSndUna    = isn
+        , tcpIss       = isn
         , tcpTimestamp = Just (emptyTimestamp now)
         }
   -- XXX how should the retry/backoff be implemented
@@ -187,7 +188,7 @@
 
           CloseWait ->
             do finAck
-               setState TimeWait
+               setState LastAck
                ok
 
           SynSent ->
@@ -215,8 +216,6 @@
   -- closing a connection that doesn't exist causes a CloseError
   connected `mplus` unblock (socketError CloseError)
 
-userClose :: Sock ()
-userClose  = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True })
 
 
 -- Writing ---------------------------------------------------------------------
@@ -247,14 +246,24 @@
 
 outputBytes :: L.ByteString -> Wakeup -> TcpSocket -> (Maybe Int64, TcpSocket)
 outputBytes bytes wakeup tcp
-  | tcpState tcp == Established = (mbWritten,    tcp { tcpOutBuffer = bufOut })
-  | otherwise                   = (Just written, tcp { tcpOutBuffer = flushed })
+  | tcpState tcp == Established              = ok
+  | tcpState tcp == CloseWait                = ok
+  | tcpState tcp `elem` [ Closing, LastAck
+                        , FinWait1, FinWait2
+                        , TimeWait ]         = bad
+  | otherwise                                = bad
   where
   (mbWritten,bufOut) = writeBytes bytes wakeup (tcpOutBuffer tcp)
-  (fin,flushed)      = flushWaiting bufOut
-  written            = fromMaybe 0 mbWritten
 
+  -- normal response (add the data to the output buffer, or queue if there's no
+  -- space available)
+  ok = (mbWritten, tcp { tcpOutBuffer = bufOut })
 
+  -- the connection is closed, so return that no data was written, and don't
+  -- queue a wakeup action
+  bad = (Just 0, tcp)
+
+
 -- Reading ---------------------------------------------------------------------
 
 -- | True when there are bytes queued to receive.
@@ -282,6 +291,19 @@
    in performRecv
 
 inputBytes :: Int64 -> Wakeup -> TcpSocket -> (Maybe L.ByteString, TcpSocket)
-inputBytes len wakeup tcp = (mbRead, tcp { tcpInBuffer = bufIn })
+inputBytes len wakeup tcp
+  | tcpState tcp == Established                        = ok
+  | tcpState tcp == CloseWait                          = if isJust mbRead
+                                                            then ok
+                                                            else bad
+  | tcpState tcp `elem` [ Closing, LastAck, TimeWait ] = bad
+  | otherwise                                          = ok
+
   where
   (mbRead,bufIn) = readBytes len wakeup (tcpInBuffer tcp)
+
+  -- normal behavior (read buffered data, or queue)
+  ok = (mbRead, tcp { tcpInBuffer = bufIn })
+
+  -- return that there's no data to read, and don't queue a wakeup action
+  bad = (Just L.empty, tcp)
diff --git a/src/Hans/Layer/Tcp/Timers.hs b/src/Hans/Layer/Tcp/Timers.hs
--- a/src/Hans/Layer/Tcp/Timers.hs
+++ b/src/Hans/Layer/Tcp/Timers.hs
@@ -12,12 +12,10 @@
   ) where
 
 import Hans.Channel
-import Hans.Layer
 import Hans.Layer.Tcp.Messages
 import Hans.Layer.Tcp.Monad
 import Hans.Layer.Tcp.Types
 import Hans.Layer.Tcp.Window
-import Hans.Timers (Milliseconds)
 
 import Control.Concurrent (forkIO,threadDelay)
 import Control.Monad (when,unless,forever,void)
@@ -27,41 +25,37 @@
 
 -- Timer Handlers --------------------------------------------------------------
 
--- | Schedule a @Tcp@ action to run every n milliseconds.
---
--- XXX we should investigate timing the time that body takes to run, and making
--- the decision about how long to delay based on that.
-every :: Milliseconds -> Tcp () -> Tcp ()
-every len body = do
-  tcp <- self
-  let timeout = len * 1000
-  output $ void $ forkIO $ forever $
-    do threadDelay timeout
-       send tcp body
-
 -- | Schedule the timers to run on the fast and slow intervals.
-initTimers :: Tcp ()
-initTimers  = do
+initTimers :: TcpHandle -> IO ()
+initTimers tcp = do
   every 500 slowTimer
   every 200 fastTimer
 
+  where
+
+  -- XXX we should investigate timing the time that body takes to run, and
+  -- making the decision about how long to delay based on that.
+  every n body = void $ forkIO $ forever $
+    do threadDelay timeout
+       send tcp body
+    where
+    timeout = n * 1000
+
 -- | Fires every 500ms.
 slowTimer :: Tcp ()
 slowTimer  =
   do -- first, handle active connections
      eachConnection $ do
-       -- the slow timer is valid for all states but TimeWait
-       do TcpSocket { .. } <- getTcpSocket
-          unless (tcpState == TimeWait) $
-            do handleRTO
-               handleFinWait2
-
-          handle2MSL
-
-          updateTimers
+       -- the slow timer is valid for all states but TimeWait; the check is done
+       -- here because the socket may have only just transitioned to TimeWait,
+       -- and hasn't been moved to hostTimeWaits yet.
+       TcpSocket { .. } <- getTcpSocket
+       unless (tcpState == TimeWait) handleRTO
+       handle2MSL
+       updateTimers
 
      -- second, decrement the 2MSL timer for sockets in the TimeWait state
-     modifyHost $ \ host ->
+     modifyHost_ $ \ host ->
        host { hostTimeWaits = stepTimeWaitConnections (hostTimeWaits host) }
 
 resetIdle :: Sock ()
@@ -127,23 +121,6 @@
           if tcpState /= TimeWait && ttIdle <= ttMaxIdle
              then set2MSL tcpKeepIntVal
              else closeSocket
-
--- FIN_WAIT_2 ------------------------------------------------------------------
-
--- | The FinWait2 10m timeout.
-finWait2Idle :: SlowTicks
-finWait2Idle  = 1200
-
--- | GC the connection if it's been open for a long time, in FIN_WAIT_2.
---
--- XXX not sure if this is the correct way to do this.  should this set a flag
--- to indicate that if the 2MSL timer goes off, the connection should be cleaned
--- up?
-handleFinWait2 :: Sock ()
-handleFinWait2  = whenState FinWait2
-                $ whenIdleFor finWait2Idle
-                $ set2MSL tcpKeepIntVal
-
 
 -- RTO -------------------------------------------------------------------------
 
diff --git a/src/Hans/Layer/Tcp/Types.hs b/src/Hans/Layer/Tcp/Types.hs
--- a/src/Hans/Layer/Tcp/Types.hs
+++ b/src/Hans/Layer/Tcp/Types.hs
@@ -21,11 +21,11 @@
 -- Hosts Information -----------------------------------------------------------
 
 data Host = Host
-  { hostConnections   :: Connections
-  , hostTimeWaits     :: TimeWaitConnections
-  , hostInitialSeqNum :: !TcpSeqNum
+  { hostConnections   :: !Connections
+  , hostTimeWaits     :: !TimeWaitConnections
+  , hostInitialSeqNum :: {-# UNPACK #-} !TcpSeqNum
   , hostPorts         :: !(PortManager TcpPort)
-  , hostLastUpdate    :: POSIXTime
+  , hostLastUpdate    :: !POSIXTime
   }
 
 emptyHost :: POSIXTime -> Host
@@ -58,9 +58,9 @@
   Map.filter (\tcp -> tcpState tcp /= Closed || not (tcpUserClosed tcp))
 
 data SocketId = SocketId
-  { sidLocalPort  :: !TcpPort
-  , sidRemotePort :: !TcpPort
-  , sidRemoteHost :: !IP4
+  { sidLocalPort  :: {-# UNPACK #-} !TcpPort
+  , sidRemotePort :: {-# UNPACK #-} !TcpPort
+  , sidRemoteHost :: {-# UNPACK #-} !IP4
   } deriving (Eq,Show,Ord)
 
 emptySocketId :: SocketId
@@ -94,14 +94,14 @@
 -- | The socket that's in TimeWait, plus its current 2MSL value.
 type TimeWaitConnections = Map.Map SocketId TimeWaitSock
 
-data TimeWaitSock = TimeWaitSock { tw2MSL      :: !SlowTicks
+data TimeWaitSock = TimeWaitSock { tw2MSL      :: {-# UNPACK #-} !SlowTicks
                                    -- ^ The current 2MSL value
-                                 , twInit2MSL  :: !SlowTicks
+                                 , twInit2MSL  :: {-# UNPACK #-} !SlowTicks
                                    -- ^ The initial 2MSL value
-                                 , twSeqNum    :: !TcpSeqNum
+                                 , twSeqNum    :: {-# UNPACK #-} !TcpSeqNum
                                    -- ^ The sequence number to use when
                                    -- responding to messages
-                                 , twTimestamp :: Maybe Timestamp
+                                 , twTimestamp :: !(Maybe Timestamp)
                                    -- ^ The last timestamp used
                                  } deriving (Show)
 
@@ -143,16 +143,16 @@
   { ttDelayedAck :: !Bool
 
     -- 2MSL
-  , tt2MSL       :: !SlowTicks
+  , tt2MSL       :: {-# UNPACK #-} !SlowTicks
 
     -- retransmit timer
-  , ttRTO        :: !SlowTicks
+  , ttRTO        :: {-# UNPACK #-} !SlowTicks
   , ttSRTT       :: !POSIXTime
   , ttRTTVar     :: !POSIXTime
 
     -- idle timer
-  , ttMaxIdle    :: !SlowTicks
-  , ttIdle       :: !SlowTicks
+  , ttMaxIdle    :: {-# UNPACK #-} !SlowTicks
+  , ttIdle       :: {-# UNPACK #-} !SlowTicks
   }
 
 emptyTcpTimers :: TcpTimers
@@ -171,8 +171,8 @@
 
 -- | Manage the timestamp values that are in flight between two hosts.
 data Timestamp = Timestamp
-  { tsTimestamp     :: !Word32
-  , tsLastTimestamp :: !Word32
+  { tsTimestamp     :: {-# UNPACK #-} !Word32
+  , tsLastTimestamp :: {-# UNPACK #-} !Word32
   , tsGranularity   :: !POSIXTime -- ^ Hz
   , tsLastUpdate    :: !POSIXTime
   } deriving (Show)
@@ -211,28 +211,28 @@
 type Close = IO ()
 
 data TcpSocket = TcpSocket
-  { tcpParent      :: Maybe SocketId
-  , tcpSocketId    :: !SocketId
+  { tcpParent      :: !(Maybe SocketId)
+  , tcpSocketId    :: {-# UNPACK #-} !SocketId
   , tcpState       :: !ConnState
-  , tcpAcceptors   :: Seq.Seq Acceptor
-  , tcpNotify      :: Maybe Notify
-  , tcpIss         :: !TcpSeqNum
-  , tcpSndNxt      :: !TcpSeqNum
-  , tcpSndUna      :: !TcpSeqNum
+  , tcpAcceptors   :: !(Seq.Seq Acceptor)
+  , tcpNotify      :: !(Maybe Notify)
+  , tcpIss         :: {-# UNPACK #-} !TcpSeqNum
+  , tcpSndNxt      :: {-# UNPACK #-} !TcpSeqNum
+  , tcpSndUna      :: {-# UNPACK #-} !TcpSeqNum
 
-  , tcpUserClosed  :: Bool
-  , tcpOut         :: RemoteWindow
-  , tcpOutBuffer   :: Buffer Outgoing
-  , tcpOutMSS      :: !Int64
-  , tcpIn          :: LocalWindow
-  , tcpInBuffer    :: Buffer Incoming
-  , tcpInMSS       :: !Int64
+  , tcpUserClosed  :: !Bool
+  , tcpOut         :: !RemoteWindow
+  , tcpOutBuffer   :: !(Buffer Outgoing)
+  , tcpOutMSS      :: {-# UNPACK #-} !Int64
+  , tcpIn          :: !LocalWindow
+  , tcpInBuffer    :: !(Buffer Incoming)
+  , tcpInMSS       :: {-# UNPACK #-} !Int64
 
-  , tcpTimers      :: !TcpTimers
-  , tcpTimestamp   :: Maybe Timestamp
+  , tcpTimers      :: {-# UNPACK #-} !TcpTimers
+  , tcpTimestamp   :: !(Maybe Timestamp)
 
-  , tcpSack        :: Bool
-  , tcpWindowScale :: Bool
+  , tcpSack        :: !Bool
+  , tcpWindowScale :: !Bool
   }
 
 emptyTcpSocket :: Word16 -> Int -> TcpSocket
diff --git a/src/Hans/Layer/Tcp/WaitBuffer.hs b/src/Hans/Layer/Tcp/WaitBuffer.hs
--- a/src/Hans/Layer/Tcp/WaitBuffer.hs
+++ b/src/Hans/Layer/Tcp/WaitBuffer.hs
@@ -12,7 +12,6 @@
     -- * Directed Buffers
   , Buffer
   , emptyBuffer
-  , shutdownWaiting
   , isFull
   , isEmpty
   , flushWaiting
@@ -56,10 +55,10 @@
 
 -- | Data Buffers, in a direction.
 data Buffer d = Buffer
-  { bufBytes     :: L.ByteString
-  , bufWaiting   :: Seq.Seq Wakeup
-  , bufSize      :: !Int64
-  , bufAvailable :: !Int64
+  { bufBytes     :: !L.ByteString
+  , bufWaiting   :: !(Seq.Seq Wakeup)
+  , bufSize      :: {-# UNPACK #-} !Int64
+  , bufAvailable :: {-# UNPACK #-} !Int64
   }
 
 -- | An empty buffer, with a limit.
@@ -115,12 +114,6 @@
         , bufAvailable = bufAvailable buf + L.length bytes
         }
   return (bytes,buf')
-
--- | Run all waiting continuations with a parameter of False, 
-shutdownWaiting :: Buffer d -> (IO (), Buffer d)
-shutdownWaiting buf = (m,buf { bufWaiting = Seq.empty })
-  where
-  m = F.mapM_ abort (bufWaiting buf)
 
 
 -- Sending Buffer --------------------------------------------------------------
diff --git a/src/Hans/Layer/Tcp/Window.hs b/src/Hans/Layer/Tcp/Window.hs
--- a/src/Hans/Layer/Tcp/Window.hs
+++ b/src/Hans/Layer/Tcp/Window.hs
@@ -23,11 +23,11 @@
 
 -- | Remote window management.
 data RemoteWindow = RemoteWindow
-  { rwSegments     :: OutSegments
-  , rwAvailable    :: !Word32
-  , rwSize         :: !Word32
-  , rwSndWind      :: !Word16
-  , rwSndWindScale :: !Int
+  { rwSegments     :: !OutSegments
+  , rwAvailable    :: {-# UNPACK #-} !Word32
+  , rwSize         :: {-# UNPACK #-} !Word32
+  , rwSndWind      :: {-# UNPACK #-} !Word16
+  , rwSndWindScale :: {-# UNPACK #-} !Int
   } deriving (Show)
 
 -- | The empty window, seeded with an initial size.
@@ -122,10 +122,10 @@
 
 -- | A delivered segment.
 data OutSegment = OutSegment
-  { outAckNum :: !TcpSeqNum
+  { outAckNum :: {-# UNPACK #-} !TcpSeqNum
   , outTime   :: !POSIXTime
-  , outFresh  :: Bool       -- ^ Whether or not this is a retransmission
-  , outRTO    :: !Int       -- ^ Retransmit timer for this segment
+  , outFresh  :: !Bool               -- ^ Whether or not this is a retransmission
+  , outRTO    :: {-# UNPACK #-} !Int -- ^ Retransmit timer for this segment
   , outHeader :: !TcpHeader
   , outBody   :: !L.ByteString
   } deriving (Show)
diff --git a/src/Hans/Layer/Udp.hs b/src/Hans/Layer/Udp.hs
--- a/src/Hans/Layer/Udp.hs
+++ b/src/Hans/Layer/Udp.hs
@@ -123,10 +123,10 @@
 type Udp = Layer UdpState
 
 data UdpState = UdpState
-  { udpPorts       :: PortManager UdpPort
-  , udpHandlers    :: Handlers UdpPort Handler
-  , udpIp4Handle   :: IP4.IP4Handle
-  , udpIcmp4Handle :: Icmp4.Icmp4Handle
+  { udpPorts       :: !(PortManager UdpPort)
+  , udpHandlers    :: !(Handlers UdpPort Handler)
+  , udpIp4Handle   :: {-# UNPACK #-} !IP4.IP4Handle
+  , udpIcmp4Handle :: {-# UNPACK #-} !Icmp4.Icmp4Handle
   }
 
 emptyUdp4State :: IP4.IP4Handle -> Icmp4.Icmp4Handle -> UdpState
diff --git a/tcp-test-client/Main.hs b/tcp-test-client/Main.hs
new file mode 100644
--- /dev/null
+++ b/tcp-test-client/Main.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Control.Concurrent (forkIO,killThread,threadDelay)
+import qualified Control.Exception as X
+import           Control.Monad (replicateM,when)
+import qualified Data.ByteString.Char8 as S
+import qualified Data.Foldable as F
+import           Network (withSocketsDo,connectTo,PortID(..))
+import           System.Environment (getArgs)
+import           System.IO (hPutStrLn,hGetLine,hClose)
+
+main = withSocketsDo $
+  do [addr]  <- getArgs
+
+     X.bracket (replicateM 100 (forkClient addr))
+               (mapM_ killThread) $ \ _ ->
+
+       do _ <- getLine
+          return ()
+
+forkClient addr =
+  do tid <- forkIO (createClient addr)
+     threadDelay (100 * 1000)
+     return tid
+
+createClient addr =
+  X.bracket (connectTo addr (PortNumber 9001)) hClose $ \ conn ->
+    F.forM_ (cycle ["foo", "bar", "baz", "ASDF"]) $ \ str ->
+      do S.hPutStrLn conn str
+         str' <- S.hGetLine conn
+         when (str /= str') $
+           do putStrLn "Invalid echo server response:"
+              putStr   "  expected: " >> S.putStrLn str
+              putStr   "  received: " >> S.putStrLn str'
diff --git a/tcp-test/Main.hs b/tcp-test/Main.hs
--- a/tcp-test/Main.hs
+++ b/tcp-test/Main.hs
@@ -18,18 +18,19 @@
 import Hans.Device.Tap
 #endif
 
-import Control.Concurrent (newEmptyMVar,putMVar,takeMVar,threadDelay,forkIO
-                          ,killThread,myThreadId)
-import Control.Monad (forever,when)
+import Control.Concurrent (threadDelay,forkIO)
+
+import Control.Monad (forever)
 import System.Environment (getArgs)
 import qualified Data.ByteString.Lazy as L
-
+import qualified Control.Exception as X
 
 localAddr :: IP4
 localAddr  = IP4 192 168 90 2
 
 main :: IO ()
 main  = do
+
   ns  <- newNetworkStack
   mac <- initEthernetDevice ns
   deviceUp ns mac
@@ -38,20 +39,21 @@
   args <- getArgs
   if args == ["dhcp"]
      then do putStrLn "Discovering address"
-             res <- newEmptyMVar
-             dhcpDiscover ns mac (putMVar res)
-             ip  <- takeMVar res
-             putStrLn ("Bound to address: " ++ show ip)
+             mbIP <- dhcpDiscover ns mac
+             case mbIP of
+               Nothing -> putStrLn "Couldn't get an IP address."
+               Just ip -> do
+                 putStrLn ("Bound to address: " ++ show ip)
 
-             putStrLn "Looking up galois.com..."
-             HostEntry { .. } <- getHostByName ns "galois.com"
-             print hostAddresses
+                 -- putStrLn "Looking up galois.com..."
+                 -- HostEntry { .. } <- getHostByName ns "galois.com"
+                 -- print hostAddresses
 
-             server ns
 
      else do setAddress mac ns
-             server ns
 
+  server ns
+
 server :: NetworkStack -> IO ()
 server ns = do
   sock <- listen ns localAddr 9001
@@ -65,13 +67,13 @@
 handleClient :: Socket -> IO ()
 handleClient conn =
   do putStrLn ("Got one: " ++ show (sockRemoteHost conn))
-     loop
+     loop `X.catch` \se -> do print (se :: X.SomeException)
+                              close conn
   where
   loop =
     do buf <- recvBytes conn 512
        if L.null buf
-          then do putStrLn "Client closed connection"
-                  close conn
+          then    putStrLn "Client closed connection"
           else do _ <- sendBytes conn buf
                   loop
 
@@ -96,7 +98,7 @@
        [] -> fail "No NICs found to use!"
        (macstr:_) ->
          do let mac = read macstr
-            nic <- openNIC xs macstr 
+            nic <- openNIC xs macstr
             addDevice ns mac (xenSend nic) (xenReceiveLoop nic)
             return mac
 #else
diff --git a/web-server/Main.hs b/web-server/Main.hs
--- a/web-server/Main.hs
+++ b/web-server/Main.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
 -- Copyright 2014 Galois, Inc.
 -- This software is distributed under a standard, three-clause BSD license.
 -- Please see the file LICENSE, distributed with this software, for specific
@@ -14,7 +15,6 @@
 import Data.Time
 import Data.Version
 import Data.Word
-import GHC.Stats
 import Hans.Address.Mac
 import Hans.Address.IP4
 import Hans.Device.Tap
@@ -25,15 +25,16 @@
 import Network.HTTP.Base
 import Network.HTTP.Headers
 import Network.HTTP.Stream
-import Network.Stream
 import System.Exit
 import System.Info
-import System.Locale
-import Text.Blaze.Html5 as H hiding (map)
+import Text.Blaze.Html5 as H hiding (map, main)
 import Text.Blaze.Html5.Attributes(href)
 import Text.Blaze.Html.Renderer.String
-import Text.Blaze.Internal(string)
 
+#if !MIN_VERSION_base(4,8,0)
+import           System.Locale
+#endif
+
 instance Stream Socket where
   readLine s = loop ""
    where loop acc =
@@ -42,7 +43,7 @@
                  | BS.head bstr == 10 -> return (Right (acc ++ "\n"))
                  | otherwise          -> loop (acc ++ BSC.unpack bstr)
 
-  readBlock s x = loop (fromIntegral x) BS.empty
+  readBlock s y = loop (fromIntegral y) BS.empty
     where loop 0 acc = return (Right (BSC.unpack acc))
           loop x acc =
             do bstr <- recvBytes s x
@@ -88,18 +89,19 @@
      deviceUp ns mac
      putStrLn ("Starting server on device " ++ show mac)
 
-     ipMV <- newEmptyMVar
-     dhcpDiscover ns mac (putMVar ipMV)
-     ipaddr <- takeMVar ipMV
-     putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr)
+     mbIP <- dhcpDiscover ns mac
+     case mbIP of
+       Nothing -> putStrLn "Couldn't get an IP address."
+       Just ipaddr -> do
+         putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr)
 
-     lsock <- listen ns undefined 80 `catch` handler
-     forever $ do
-       sock <- accept lsock
-       putStrLn "Accepted socket."
-       forkIO (handleClient sock state)
-       forkIO (addHost ns (sockRemoteHost sock) (lastHosts state))
-       return ()
+         lsock <- listen ns undefined 80 `catch` handler
+         forever $ do
+           sock <- accept lsock
+           putStrLn "Accepted socket."
+           _ <- forkIO (handleClient sock state)
+           _ <- forkIO (addHost ns (sockRemoteHost sock) (lastHosts state))
+           return ()
 
  where
   handler ListenError{} =
@@ -113,9 +115,9 @@
      case mreq of
        Left err  -> putStrLn ("ReqERROR: " ++ show err)
        Right req ->
-         do body <- buildBody req state
+         do bod <- buildBody req state
             putStrLn "Built response"
-            let lenstr = show (length body)
+            let lenstr = show (length bod)
                 keepAlive = [ mkHeader HdrConnection "keep-alive"
                             | hdr <- retrieveHeaders HdrConnection req
                             , map toLower (hdrValue hdr) == "keep-alive" ]
@@ -127,7 +129,7 @@
                            , rspHeaders = mkHeader HdrContentLength lenstr
                                         : mkHeader HdrContentType   "text/html"
                                         : conn
-                           , rspBody = body
+                           , rspBody = bod
                            }
             respondHTTP sock resp
             if null keepAlive
@@ -135,7 +137,7 @@
                else handleClient sock state
 
 buildBody :: Request String -> ServerState -> IO String
-buildBody req state =
+buildBody _req state =
   do numReqs <- modifyMVar (responseCount state) (\ x -> return (x + 1, x))
      prevHosts <- readMVar (lastHosts state)
      putStrLn ("prevHosts: " ++ show prevHosts ++ "\n")
@@ -156,7 +158,7 @@
              li $    hans >> " to talk to you over TCP."
              li $ do http >> " (modified to use the " >> network_hans
                      " shim) to understand your request and respond to it."
-             li $ do blaze >> " (which built out of the box) to generate this " 
+             li $ do blaze >> " (which built out of the box) to generate this "
                      "pretty HTML."
              li $ do "... and a host of other libraries to do other, more "
                      "standard, things."