diff --git a/Data/Graph/Dom.hs b/Data/Graph/Dom.hs
--- a/Data/Graph/Dom.hs
+++ b/Data/Graph/Dom.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts #-}
 
 {- |
   Module      :  Data.Graph.Dom
@@ -19,8 +19,6 @@
     \[3\] Brisk, Sarrafzadeh,
       /Interference Graphs for Procedures in Static Single/
       /Information Form are Interval Graphs/, 2007.
-
-  TODO: An ST version.
 -}
 
 module Data.Graph.Dom (
@@ -37,6 +35,7 @@
 ) where
 
 import Data.Tree
+import Data.List
 import Data.Map(Map)
 import Data.IntMap(IntMap)
 import Data.IntSet(IntSet)
@@ -46,7 +45,11 @@
 import Data.Monoid(Monoid(..))
 import Control.Applicative
 import Control.Monad
-import Data.List
+import Data.Array.ST
+import Data.Array.Base
+  (unsafeNewArray_
+  ,unsafeWrite,unsafeRead)
+import Control.Monad.ST.Strict
 
 -----------------------------------------------------------------------------
 
@@ -92,21 +95,12 @@
 -- using @IntMap@, it has an additional /lg |V|/ factor
 -- somewhere in there. I'm not sure where.
 idom :: Rooted -> [(Node,Node)]
-idom = IM.toList
-     . domE
-     . execS idomM
-     . initEnv
-     . pruneReach
+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
 
 -- | /Immediate post-dominators/.
 -- Complexity as for @idom@.
 ipdom :: Rooted -> [(Node,Node)]
-ipdom = IM.toList
-      . domE
-      . execS idomM
-      . initEnv
-      . pruneReach
-      . mapsnd predG
+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (mapsnd predG rg)))
 
 -----------------------------------------------------------------------------
 
@@ -120,30 +114,30 @@
 
 -----------------------------------------------------------------------------
 
-type Dom a = S Env a
+type Dom s a = S s (Env s) a
 type NodeSet    = IntSet
 type NodeMap a  = IntMap a
-data Env = Env
-  {dfsE       :: !Int
-  ,zeroE      :: !Node
-  ,rootE      :: !Node
-  ,succE      :: !Graph
+data Env s = Env
+  {succE      :: !Graph
   ,predE      :: !Graph
   ,bucketE    :: !Graph
-  ,labelE     :: !(NodeMap Node)
-  ,parentE    :: !(NodeMap Node)
-  ,ancestorE  :: !(NodeMap Node)
-  ,childE     :: !(NodeMap Node)
-  ,ndfsE      :: !(IntMap  Node)
-  ,dfnE       :: !(NodeMap Int)
-  ,sdnoE      :: !(NodeMap Int)
-  ,sizeE      :: !(NodeMap Int)
-  ,domE       :: !(NodeMap Node)}
-  deriving(Eq,Ord,Read,Show)
+  ,dfsE       :: {-# UNPACK #-}!Int
+  ,zeroE      :: {-# UNPACK #-}!Node
+  ,rootE      :: {-# UNPACK #-}!Node
+  ,labelE     :: {-# UNPACK #-}!(Arr s Node)
+  ,parentE    :: {-# UNPACK #-}!(Arr s Node)
+  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)
+  ,childE     :: {-# UNPACK #-}!(Arr s Node)
+  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)
+  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)
+  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)
+  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)
+  ,domE       :: {-# UNPACK #-}!(Arr s Node)
+  ,rnE        :: {-# UNPACK #-}!(Arr s Node)}
 
 -----------------------------------------------------------------------------
 
-idomM :: Dom ()
+idomM :: Dom s [(Node,Node)]
 idomM = do
   dfsDom =<< rootM
   n <- gets dfsE
@@ -155,11 +149,11 @@
       u <- eval v
       su <- sdnoM u
       when (su < sw)
-        (modify(\e->e{sdnoE
-          =IM.insert w su (sdnoE e)})))
+        (store sdnoE w su))
     z <- ndfsM =<< sdnoM w
-    modify(\e->e{bucketE
-      =IM.adjust (w`IS.insert`) z (bucketE e)})
+    modify(\e->e{bucketE=IM.adjust
+                      (w`IS.insert`)
+                      z (bucketE e)})
     pw <- parentM w
     link pw w
     bps <- bucketM pw
@@ -170,8 +164,7 @@
       let dv = case su < sv of
                 True-> u
                 False-> pw
-      modify(\e->e{domE
-        =IM.insert v dv (domE e)})))
+      store domE v dv))
   forM_ [1..n] (\i-> do
     w <- ndfsM i
     j <- sdnoM w
@@ -179,12 +172,12 @@
     dw <- domM w
     when (dw /= z)
       (do ddw <- domM dw
-          modify(\e->e{domE
-            =IM.insert w ddw (domE e)})))
+          store domE w ddw))
+  fromEnv
 
 -----------------------------------------------------------------------------
 
-eval :: Node -> Dom Node
+eval :: Node -> Dom s Node
 eval v = do
   n0 <- zeroM
   a  <- ancestorM v
@@ -201,7 +194,7 @@
         True-> return l
         False-> return la
 
-compress :: Node -> Dom ()
+compress :: Node -> Dom s ()
 compress v = do
   n0  <- zeroM
   a   <- ancestorM v
@@ -215,14 +208,12 @@
     sl  <- sdnoM l
     sla <- sdnoM la
     when (sla < sl)
-      (modify(\e->e{labelE
-        =IM.insert v la (labelE e)}))
-    modify(\e->e{ancestorE
-      =IM.insert v aa (ancestorE e)}))
+      (store labelE v la)
+    store ancestorE v aa)
 
 -----------------------------------------------------------------------------
 
-link :: Node -> Node -> Dom ()
+link :: Node -> Node -> Dom s ()
 link v w = do
   n0  <- zeroM
   lw  <- labelM w
@@ -240,124 +231,153 @@
             zcc <- sizeM cc
             case 2*zc <= zs+zcc of
               True-> do
-                modify(\e->e
-                  {ancestorE=IM.insert c s (ancestorE e)
-                  ,childE=IM.insert s cc (childE e)})
+                store ancestorE c s
+                store childE s cc
                 balance s
               False-> do
-                modify(\e->e
-                  {sizeE=IM.insert c zs (sizeE e)
-                  ,ancestorE=IM.insert s c (ancestorE e)})
+                store sizeE c zs
+                store ancestorE s c
                 balance c
   s   <- balance w
   lw  <- labelM w
   zw  <- sizeM w
-  modify(\e->e
-    {labelE=IM.insert s lw (labelE e)
-    ,sizeE=IM.adjust (+zw) v (sizeE e)})
+  store labelE s lw
+  sv <- sizeM v
+  store sizeE v . (+zw) =<< sizeM v
   let follow s = do
         when (s /= n0) (do
-          modify(\e->e{ancestorE
-            =IM.insert s v (ancestorE e)})
+          store ancestorE s v
           follow =<< childM s)
   zv  <- sizeM v
   follow =<< case zv < 2*zw of
               False-> return s
               True-> do
                 cv <- childM v
-                modify(\e->e{childE
-                  =IM.insert v s (childE e)})
+                store childE v s
                 return cv
 
 -----------------------------------------------------------------------------
 
-dfsDom :: Node -> Dom ()
+dfsDom :: Node -> Dom s ()
 dfsDom i = do
   _   <- go i
   n0  <- zeroM
   r   <- rootM
-  modify(\e->e{parentE
-    =IM.insert r n0 (parentE e)})
+  store parentE r n0
   where go i = do
           n <- nextM
-          modify(\e->e
-            {dfnE   = IM.insert i n (dfnE e)
-            ,sdnoE  = IM.insert i n (sdnoE e)
-            ,ndfsE  = IM.insert n i (ndfsE e)
-            ,labelE = IM.insert i i (labelE e)})
+          store dfnE   i n
+          store sdnoE  i n
+          store ndfsE  n i
+          store labelE i i
           ss <- succsM i
           forM_ ss (\j-> do
             s <- sdnoM j
             case s==0 of
               False-> return()
               True-> do
-                modify(\e->e{parentE=
-                  IM.insert j i (parentE e)})
+                store parentE j i
                 go j)
 
 -----------------------------------------------------------------------------
 
-initEnv :: Rooted -> Env
-initEnv (r,g) =
-  let n = IM.size g
-      ks = IM.keys g
-      n0 = 1 + maximum ks
-      ns = n0:ks
-      doms      = IM.singleton r r
-      sdno      = IM.fromList (zip ns (repeat 0))
-      bucket    = IM.fromList (zip ns (repeat mempty))
-      size      = IM.fromList (zip ns (0 : repeat 1))
-      ancestor  = IM.fromList (zip ns (repeat n0))
-      child     = ancestor
-      label     = IM.singleton n0 n0
+initEnv :: Rooted -> ST s (Env s)
+initEnv (r0,g0) = do
+  let (g,rnmap) = renum 1 g0
       pred      = predG g
- in Env {dfsE       = 0
-        ,zeroE      = n0
-        ,rootE      = r
-        ,labelE     = label
-        ,parentE    = mempty
-        ,ancestorE  = ancestor
-        ,childE     = child
-        ,ndfsE      = mempty
-        ,dfnE       = mempty
-        ,sdnoE      = sdno
-        ,sizeE      = size
-        ,succE      = g
-        ,predE      = pred
-        ,bucketE    = bucket
-        ,domE       = doms}
+      r         = rnmap IM.! r0
+      n         = IM.size g
+      ns        = [0..n]
+      m         = n+1
 
+  let bucket = IM.fromList
+        (zip ns (repeat mempty))
+
+  rna <- newI m
+  writes rna (fmap swap
+        (IM.toList rnmap))
+
+  doms      <- newI m
+  sdno      <- newI m
+  size      <- newI m
+  parent    <- newI m
+  ancestor  <- newI m
+  child     <- newI m
+  label     <- newI m
+  ndfs      <- newI m
+  dfn       <- newI m
+
+  forM_ [0..n] (doms.=0)
+  forM_ [0..n] (sdno.=0)
+  forM_ [1..n] (size.=1)
+  forM_ [0..n] (ancestor.=0)
+  forM_ [0..n] (child.=0)
+
+  (doms.=r) r
+  (size.=0) 0
+  (label.=0) 0
+
+  return (Env
+    {rnE        = rna
+    ,dfsE       = 0
+    ,zeroE      = 0
+    ,rootE      = r
+    ,labelE     = label
+    ,parentE    = parent
+    ,ancestorE  = ancestor
+    ,childE     = child
+    ,ndfsE      = ndfs
+    ,dfnE       = dfn
+    ,sdnoE      = sdno
+    ,sizeE      = size
+    ,succE      = g
+    ,predE      = pred
+    ,bucketE    = bucket
+    ,domE       = doms})
+
+fromEnv :: Dom s [(Node,Node)]
+fromEnv = do
+  dom   <- gets domE
+  rn    <- gets rnE
+  r     <- gets rootE
+  (_,n) <- st (getBounds dom)
+  forM [1..n] (\i-> do
+    j <- st(rn!:i)
+    d <- st(dom!:i)
+    k <- st(rn!:d)
+    return (j,k))
+
 -----------------------------------------------------------------------------
 
-zeroM :: Dom Node
+zeroM :: Dom s Node
 zeroM = gets zeroE
-domM :: Node -> Dom Node
-domM i = gets ((IM.!i) . domE)
-rootM :: Dom Node
+domM :: Node -> Dom s Node
+domM = fetch domE
+rootM :: Dom s Node
 rootM = gets rootE
-succsM :: Node -> Dom [Node]
+succsM :: Node -> Dom s [Node]
 succsM i = gets (IS.toList . (!i) . succE)
-predsM :: Node -> Dom [Node]
+predsM :: Node -> Dom s [Node]
 predsM i = gets (IS.toList . (!i) . predE)
-bucketM :: Node -> Dom [Node]
+bucketM :: Node -> Dom s [Node]
 bucketM i = gets (IS.toList . (!i) . bucketE)
-sizeM :: Node -> Dom Int
-sizeM i = gets ((IM.!i) . sizeE)
-sdnoM :: Node -> Dom Int
-sdnoM i = gets ((IM.!i) . sdnoE)
-dfnM :: Node -> Dom Int
-dfnM i = gets ((IM.!i) . dfnE)
-ndfsM :: Int -> Dom Node
-ndfsM i = gets ((IM.!i) . ndfsE)
-childM :: Node -> Dom Node
-childM i = gets ((IM.!i) . childE)
-ancestorM :: Node -> Dom Node
-ancestorM i = gets ((IM.!i) . ancestorE)
-parentM :: Node -> Dom Node
-parentM i = gets ((IM.!i) . parentE)
-labelM :: Node -> Dom Node
-labelM i = gets ((IM.!i) . labelE)
-nextM :: Dom Int
+sizeM :: Node -> Dom s Int
+sizeM = fetch sizeE
+sdnoM :: Node -> Dom s Int
+sdnoM = fetch sdnoE
+dfnM :: Node -> Dom s Int
+dfnM = fetch dfnE
+ndfsM :: Int -> Dom s Node
+ndfsM = fetch ndfsE
+childM :: Node -> Dom s Node
+childM = fetch childE
+ancestorM :: Node -> Dom s Node
+ancestorM = fetch ancestorE
+parentM :: Node -> Dom s Node
+parentM = fetch parentE
+labelM :: Node -> Dom s Node
+labelM = fetch labelE
+nextM :: Dom s Int
 nextM = do
   n <- gets dfsE
   let n' = n+1
@@ -366,6 +386,54 @@
 
 -----------------------------------------------------------------------------
 
+type A = STUArray
+type Arr s a = A s Int a
+
+infixl 9 !:
+infixr 2 .=
+
+(.=) :: (MArray (A s) a (ST s))
+     => Arr s a -> a -> Int -> ST s ()
+(v .= x) i = unsafeWrite v i x
+
+(!:) :: (MArray (A s) a (ST s))
+     => A s Int a -> Int -> ST s a
+a !: i = do
+  o <- unsafeRead a i
+  return $! o
+
+new :: (MArray (A s) a (ST s))
+    => Int -> ST s (Arr s a)
+new n = unsafeNewArray_ (0,n-1)
+
+newI :: Int -> ST s (Arr s Int)
+newI = new
+
+newD :: Int -> ST s (Arr s Double)
+newD = new
+
+dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]
+dump a = do
+  (m,n) <- getBounds a
+  forM [m..n] (\i -> a!:i)
+
+writes :: (MArray (A s) a (ST s))
+     => Arr s a -> [(Int,a)] -> ST s ()
+writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
+
+arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)
+arr xs = do
+  let n = length xs
+  a <- new n
+  go a n 0 xs
+  return a
+  where go _ _ _    [] = return ()
+        go a n i (x:xs)
+          | i <= n = (a.=x) i >> go a n (i+1) xs
+          | otherwise = return ()
+
+-----------------------------------------------------------------------------
+
 (!) :: Monoid a => IntMap a -> Int -> a
 (!) g n = maybe mempty id (IM.lookup n g)
 
@@ -377,11 +445,11 @@
 
 toAdj :: Graph -> [(Node, [Node])]
 toAdj = fmap (mapsnd IS.toList) . IM.toList
-
-toEdges :: Graph -> [Edge]
 toEdges = concatMap (uncurry (fmap . (,))) . toAdj
 
 predG :: Graph -> Graph
+
+toEdges :: Graph -> [Edge]
 predG g = IM.unionWith IS.union (go g) g0
   where g0 = fmap (const mempty) g
         go = flip IM.foldWithKey mempty (\i a m ->
@@ -454,31 +522,67 @@
 mapsnd :: (b -> c) -> (a,b) -> (a,c)
 mapsnd f = \(a,b) -> (a, f b)
 
+-- (renamed, old -> new)
+renum :: Int -> Graph -> (Graph, NodeMap Node)
+renum from = (\(_,m,g)->(g,m))
+  . IM.foldWithKey
+      (\i ss (!n,!env,!new)->
+          let (j,n2,env2) = go n env i
+              (n3,env3,ss2) = IS.fold
+                (\k (!n,!env,!new)->
+                    case go n env k of
+                      (l,n2,env2)-> (n2,env2,l `IS.insert` new))
+                (n2,env2,mempty) ss
+              new2 = IM.insertWith IS.union j ss2 new
+          in (n3,env3,new2)) (from,mempty,mempty)
+  where go :: Int
+           -> NodeMap Node
+           -> Node
+           -> (Node,Int,NodeMap Node)
+        go !n !env i =
+          case IM.lookup i env of
+            Just j -> (j,n,env)
+            Nothing -> (n,n+1,IM.insert i n env)
+
 -----------------------------------------------------------------------------
 
-newtype S s a = S {unS :: forall o. (a -> s -> o) -> s -> o}
-instance Functor (S s) where
+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
+instance Functor (S z s) where
   fmap f (S g) = S (\k -> g (k . f))
-instance Monad (S s) where
+instance Monad (S z s) where
   return a = S (\k -> k a)
   S g >>= f = S (\k -> g (\a -> unS (f a) k))
-instance Applicative (S s) where
+instance Applicative (S z s) where
   pure = return
   (<*>) = ap
-get :: S s s
+get :: S z s s
 get = S (\k s -> k s s)
-gets :: (s -> a) -> S s a
+gets :: (s -> a) -> S z s a
 gets f = S (\k s -> k (f s) s)
-set :: s -> S s ()
+set :: s -> S z s ()
 set s = S (\k _ -> k () s)
-modify :: (s -> s) -> S s ()
+modify :: (s -> s) -> S z s ()
 modify f = S (\k -> k () . f)
-runS :: S s a -> s -> (a, s)
-runS (S g) = g (,)
-evalS :: S s a -> s -> a
-evalS (S g) = g const
-execS :: S s a -> s -> s
-execS (S g) = g (flip const)
+runS :: S z s a -> s -> ST z (a, s)
+runS (S g) = g (\a s -> return (a,s))
+evalS :: S z s a -> s -> ST z a
+evalS (S g) = g ((return .) . const)
+execS :: S z s a -> s -> ST z s
+execS (S g) = g ((return .) . flip const)
+st :: ST z a -> S z s a
+st m = S (\k s-> do
+  a <- m
+  k a s)
+store :: (MArray (A z) a (ST z))
+      => (s -> Arr z a) -> Int -> a -> S z s ()
+store f i x = do
+  a <- gets f
+  st ((a.=x) i)
+fetch :: (MArray (A z) a (ST z))
+      => (s -> Arr z a) -> Int -> S z s a
+fetch f i = do
+  a <- gets f
+  st (a!:i)
 
 -----------------------------------------------------------------------------
 
diff --git a/dom-lt.cabal b/dom-lt.cabal
--- a/dom-lt.cabal
+++ b/dom-lt.cabal
@@ -1,5 +1,5 @@
 name:               dom-lt
-version:            0.1.1
+version:            0.1.2
 cabal-version:      >= 1.6
 build-type:         Simple
 license:            BSD3
@@ -19,5 +19,5 @@
   hs-source-dirs:   .
   ghc-options:      -O2
   extensions:       RankNTypes
-  build-depends:    base==4.*, containers
+  build-depends:    base==4.*, array, containers
   exposed-modules:  Data.Graph.Dom