Random stuff that improves performance

[skip ci]

ma.cabal

@@ -44,12 +44,14 @@ library
                      , MA.Algorithm.Types
                      , MA.Algorithm.Initialize
                      , MA.Algorithm.Split
+                     , MA.Algorithm.Internal
                      , MA.FunctorExpression.Type
                      , MA.FunctorExpression.Parser
                      , MA.FunctorExpression.Pretty
                      , MA.FunctorExpression.Sorts
                      , MA.FunctorExpression.Desorting
                      , MA.Coalgebra.Parser
+                     , MA.Coalgebra.Parser.Class
                      , MA.Coalgebra.Parser.Internal
                      , MA.Coalgebra.RefinementTypes
                      , MA.PartitionPrinter

src/Data/RefinablePartition.hs

@@ -29,6 +29,7 @@ module Data.RefinablePartition
   , groupBy
   -- * Conversion
   , freeze
+  , unsafeStatesOfBlock
   ) where
 
 import           Control.Monad (forM_, when, foldM)
@@ -41,7 +42,7 @@ import qualified Data.Vector.Algorithms.Heap as VM
 import           Data.Vector.Mutable (MVector)
 import qualified Data.Vector.Mutable as VM
 import qualified Data.Vector.Unboxed.Mutable as VU
-import qualified Data.Vector.Unboxed as VUU
+import qualified Data.Vector.Unboxed as VU (convert, freeze, unsafeFreeze, Vector)
 import           Lens.Micro
 import           Lens.Micro.TH
 
@@ -227,25 +228,36 @@ isMarked partition s = do
 -- | Return the marked states of a block.
 --
 -- Runtime O(n) for n == number of states in this block
-markedStates :: RefinablePartition s -> Block -> ST s (V.Vector State)
+markedStates :: RefinablePartition s -> Block -> ST s (VU.Vector State)
 markedStates partition b = do
   block <- getBlock partition b
 
   let len = block^.unmarkedOffset - block^.startOffset
 
-  V.convert <$>
-    VUU.freeze (VU.slice (block^.startOffset) len (partition^.statesByBlock))
+  VU.freeze (VU.slice (block^.startOffset) len (partition^.statesByBlock))
 
 -- | Return a vector of all states in a given block.
 --
 -- Runtime: O(n) for n == number of states in this block
-statesOfBlock :: RefinablePartition s -> Block -> ST s (V.Vector State)
+statesOfBlock :: RefinablePartition s -> Block -> ST s (VU.Vector State)
 statesOfBlock partition b = do
   block <- getBlock partition b
 
   len <- blockSize partition b
   let slice = VU.slice (block^.startOffset) len (partition^.statesByBlock)
-  V.convert <$> VUU.freeze slice
+  VU.freeze slice
+
+-- | Return a vector of all states in a given block.
+--
+-- Runtime: O(n) for n == number of states in this block
+unsafeStatesOfBlock :: RefinablePartition s -> Block -> ST s (VU.Vector State)
+unsafeStatesOfBlock partition b = do
+  block <- getBlock partition b
+
+  len <- blockSize partition b
+  let slice = VU.slice (block^.startOffset) len (partition^.statesByBlock)
+  VU.unsafeFreeze slice
+
 
 -- | Split a block into two new blocks for its marked and unmarked states.
 --
@@ -404,19 +416,24 @@ freeze partition = do
 -- helpers
 getBlock :: RefinablePartition s -> Block -> ST s BlockRepr
 getBlock !partition (Block b) = VM.unsafeRead (_blocks partition) b
+{-# INLINE getBlock #-}
 
 setBlock :: RefinablePartition s -> Block -> (BlockRepr -> BlockRepr) -> ST s ()
 setBlock partition (Block b) setter = VM.unsafeModify (_blocks partition) setter b
+{-# INLINE setBlock #-}
 
 getState :: RefinablePartition s -> State -> ST s StateRepr
 getState partition s = VM.unsafeRead (partition^.states) s
+{-# INLINE getState #-}
 
 setState :: RefinablePartition s -> State -> (StateRepr -> StateRepr) -> ST s ()
 setState partition s setter = VM.modify (partition^.states) setter s
+{-# INLINE setState #-}
 
 setStateAt :: RefinablePartition s -> Int -> (StateRepr -> StateRepr) -> ST s ()
 setStateAt partition loc setter = VU.read (partition^.statesByBlock) loc >>= \state ->
   setState partition state setter
+{-# INLINE setStateAt #-}
 
 newBlock :: RefinablePartition s -> Int -> Int -> ST s Block
 newBlock partition beginning end = do

src/Data/Vector/Unboxed/Mutable/Utils.hs

@@ -9,6 +9,7 @@ module Data.Vector.Unboxed.Mutable.Utils
   ) where
 
 import           Control.Monad (foldM)
+import qualified Control.Monad.ST.Strict
 
 import           Control.Monad.Primitive
 import qualified Data.Vector.Unboxed.Mutable as VU
@@ -33,8 +34,21 @@ partition :: (VU.Unbox a, PrimMonad m)
           -> Int -- ^ The beginning of the region to partition (inclusive)
           -> Int -- ^ The end of the region to partition (exclusive)
           -> m Int
-partition vec predicate  = partitionM vec (return . predicate)
-{-# INLINE partition #-}
+partition vec predicate  = go
+  where
+    go lower upper
+      | lower >= upper = return lower
+      | otherwise = do
+          l <- VU.read vec lower
+          r <- VU.read vec (upper-1)
+
+          let predL = predicate l
+          let predR = predicate r
+
+          if predL then go (lower+1) upper
+            else if not predR then go lower (upper-1)
+            else VU.swap vec lower (upper-1) >> go (lower+1) upper
+{-# SPECIALIZE INLINE partition :: VU.MVector s Int -> (Int -> Bool) -> Int -> Int -> Control.Monad.ST.Strict.ST s Int #-}
 
 -- | 'partition' with monadic predicate
 partitionM :: (VU.Unbox a, PrimMonad m)

src/Data/Vector/Utils.hs

+{-# LANGUAGE BangPatterns #-}
 module Data.Vector.Utils
   ( iforM_
   , sort
   , sortBy
   , sortOn
   , hasDuplicates
+  , imap'
   ) where
 
 import           Data.Ord (comparing)
+import           Control.Monad (forM_)
 
 import           Data.Vector (Vector)
 import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as VM
 import qualified Data.Vector.Algorithms.Intro as V
 
 iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()
@@ -33,3 +37,17 @@ sortOn f = V.modify (V.sortBy (comparing f))
 hasDuplicates :: Eq a => Vector a -> Bool
 hasDuplicates v = V.length (V.uniq v) /= V.length v
 {-# INLINE hasDuplicates #-}
+
+imap' :: (Int -> a -> b) -> Vector a -> Vector b
+imap' !f !v = V.create $ do
+  let !len = (length v)
+  v' <- VM.new len
+
+  forM_ [0..len-1] $ \i -> do
+    let !a = v V.! i
+    VM.write v' i (f' i a)
+
+  return v'
+
+  where
+    f' !i !a = (f $! i) $! a

src/MA/Algorithm.hs

@@ -19,7 +19,7 @@ import           MA.Coalgebra.RefinementTypes
 import           MA.Algorithm.Types
 import           MA.Algorithm.Initialize
 import           MA.Algorithm.Split
-
+import           MA.Algorithm.Internal
 
 processQueue  :: RefinementInterface h => BlockQueue s -> AlgoState s h -> ST s ()
 processQueue queue as = whileM $
@@ -28,13 +28,14 @@ processQueue  queue as = whileM $
     Just block -> do
       runReaderT (split block) (as, queue)
       return True
+{-# SPECIALIZE processQueue :: BlockQueue s -> AlgoState s TheFunctor -> ST s () #-}
 
-refine ::
+refine :: forall f s.
      RefinementInterface f
   => Proxy f
   -> Encoding (Label f) (H1 f)
   -> ST s Partition
-refine (_ :: Proxy f) encoding = do
+refine Proxy encoding = do
   queue <- Queue.empty (size encoding)
   (blocks, state) <- initialize @f encoding
   mapM_ (Queue.enqueue queue) blocks
@@ -42,3 +43,4 @@ refine (_ :: Proxy f) encoding = do
   processQueue  queue state
 
   Partition.freeze (partition state)
+{-# SPECIALIZE refine :: Proxy TheFunctor -> Encoding (Label TheFunctor) (H1 TheFunctor) -> ST s Partition #-}

src/MA/Algorithm/Internal.hs

+module MA.Algorithm.Internal (TheFunctor) where
+
+import MA.FunctorExpression.Desorting (Desorted)
+import MA.Functors.SomeFunctor (SomeFunctor)
+
+type TheFunctor = Desorted SomeFunctor

src/MA/Algorithm/Split.hs

@@ -22,6 +22,7 @@ import           Data.Tuple.Extra (snd3)
 import           Data.Vector (Vector)
 import qualified Data.Vector as V
 import qualified Data.Vector.Mutable as VM
+import qualified Data.Vector.Unboxed as VU
 
 import           Data.Algorithm.PossibleMajorityCandidate
 import           Data.BlockQueue (BlockQueue)
@@ -33,39 +34,48 @@ import           MA.RefinementInterface (RefinementInterface)
 import qualified MA.RefinementInterface as RI
 import           MA.Coalgebra.RefinementTypes
 import           MA.Algorithm.Types
+import           MA.Algorithm.Internal
 
 type SplitM s h = ReaderT (AlgoState s h, BlockQueue s) (ST s)
 
 split :: RefinementInterface h => Block -> SplitM s h ()
 split blockS = do
   (as, _) <- ask
-  statesOfS <- lift $ (Partition.statesOfBlock (partition as) blockS)
-  touchedBlocks <- collectTouchedBlocks statesOfS
+  touchedBlocks <- collectTouchedBlocks blockS
 
   forM_ touchedBlocks $ \(b, v0) -> do
     updateBlock b v0
     whenM (lift $ Partition.hasMarked (partition as) b) $
       splitBlock b
+{-# SPECIALIZE split :: Block -> SplitM s TheFunctor () #-}
 
 updateBlock :: forall s h. RefinementInterface h => Block -> H3 h -> SplitM s h ()
 updateBlock b v0 = ask >>= \(as, _) -> lift $ do
   markB <- Partition.markedStates (partition as) b
-  forM_ markB $ \x -> do
+  VU.forM_ markB $ \x -> do
     -- We can use `head` here, since states are only marked if they have at
     -- least one edge into S => toSub[x] can't be empty.
-    pc <- (fromEdgeRef . head <$> VM.read (toSub as) x)
+    !pc <- (fromEdgeRef . head <$> VM.read (toSub as) x)
             >>= VM.read (lastW as)
-    labelsToS <- map (label . graph (encoding as)) <$> VM.read (toSub as) x
-    (wxS, vx, wxCwithoutS) <- RI.update @h labelsToS <$> readSTRef pc
-    writeSTRef pc wxCwithoutS
-    ps <- newSTRef wxS
-    VM.read (toSub as) x >>= \edges -> forM_ edges $ \(EdgeRef e) ->
-      VM.write (lastW as) e ps
+
+    !labelsToS <- {-# SCC readLabels #-} VM.read (toSub as) x >>= (mapM $ \e -> do
+      let Edge _ !lab _ = graph (encoding as) e
+      return $! lab)
+
+    !pc' <- readSTRef pc
+    (!wxS, !vx, !wxCwithoutS) <- {-# SCC riupdate #-} return $! (((RI.update @h) $! labelsToS) $! pc')
+    writeSTRef pc $! {-# SCC wxCwithoutS #-} wxCwithoutS
+    !ps <- newSTRef $! {-# SCC wxS #-} wxS
+
+    VM.read (toSub as) x >>= \(!edges) -> forM_ edges $ \(EdgeRef !e) ->
+      {-# SCC writelastw #-} (VM.write (lastW as) $! e) $! ps
+
     VM.write (toSub as) x []
 
     if vx == v0
       then Partition.unmark (partition as) x
-      else VM.write (h3Cache as) x vx
+      else VM.write (h3Cache as) x $! vx
+{-# SPECIALIZE updateBlock :: Block -> H3 TheFunctor -> SplitM s TheFunctor () #-}
 
 -- b must have at least one marked state
 splitBlock :: RefinementInterface h => Block -> SplitM s h ()
@@ -79,12 +89,12 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do
   -- effects, this should be safe.
   let unsafeH3 = unsafeDupablePerformIO . unsafeSTToIO . VM.read (h3Cache as)
 
-  !pmc <- (possibleMajorityCandidate . V.map unsafeH3) <$>
-          Partition.statesOfBlock (partition as) b1
+  !pmc <- (possibleMajorityCandidateBy' unsafeH3) <$>
+          Partition.unsafeStatesOfBlock (partition as) b1
 
   -- the pmc occurs in b1, so b1' has to be non-empty
-  (Just b1', b2) <- Partition.splitByM (partition as) b1
-                    (fmap (==pmc) . VM.read (h3Cache as))
+  (Just b1', b2) <- Partition.splitBy (partition as) b1
+                    ((==pmc) . unsafeH3)
 
   blocks <- ((b1':maybeToList bunmarked) ++) <$> case b2 of
     Nothing -> return []
@@ -95,6 +105,7 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do
   ifM (b `Queue.elem` queue) (mapM_ enqueue blocks) $
     deleteLargest (Partition.blockSize (partition as)) (maybeAdd b blocks)
       >>= mapM_ enqueue
+{-# SPECIALIZE splitBlock :: Block -> SplitM s TheFunctor () #-}
 
 -- | Remove one largest element from the list
 --
@@ -103,20 +114,24 @@ deleteLargest :: Eq e => (e -> ST s Int) -> [e] -> ST s [e]
 deleteLargest sizeFunction lst = do
   zipWithSize <- traverse (\x -> (,x) <$> sizeFunction x) lst
   return (delete (snd (maximumBy (compare `on` fst) zipWithSize)) lst)
+{-# INLINE deleteLargest #-}
 
 -- | Add element to list if it isn't already there
 maybeAdd :: Eq e => e -> [e] -> [e]
 maybeAdd e lst
   | e `elem` lst = lst
   | otherwise    = e : lst
+{-# INLINE maybeAdd #-}
 
-collectTouchedBlocks :: forall s h. RefinementInterface h => Vector State -> SplitM s h [(Block, H3 h)]
-collectTouchedBlocks statesOfS = do
+collectTouchedBlocks :: forall s h. RefinementInterface h => Block -> SplitM s h [(Block, H3 h)]
+collectTouchedBlocks blockS = do
   (as, _) <- ask
 
+  statesOfS <- lift $ Partition.statesOfBlock (partition as) blockS
+
   markedBlocks <- lift $ newSTRef []
 
-  lift $ forM_ statesOfS $ \y -> forM_ (pred as V.! y) $ \e -> do
+  lift $ VU.forM_ statesOfS $ \y -> forM_ (pred as V.! y) $ \e -> do
     let Edge x _ _ = graph (encoding as) e
     b <- Partition.blockOfState (partition as) x
 
@@ -131,3 +146,4 @@ collectTouchedBlocks statesOfS = do
     VM.modify (toSub as) (e:) x
 
   lift $ readSTRef markedBlocks
+{-# SPECIALIZE collectTouchedBlocks :: Block -> SplitM s TheFunctor [(Block, H3 TheFunctor)] #-}

src/MA/Algorithm/Types.hs

@@ -21,5 +21,3 @@ data AlgoState s h = AlgoState
   , partition :: RefinablePartition s
   , h3Cache :: MVector s (H3 h)
   }
-
-

src/MA/Coalgebra/Parser.hs

+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module MA.Coalgebra.Parser
   ( parseMorphisms
   , morphismsParser
-  , ParseMorphism(..)
   , SymbolTable(..)
-  , MorphParser
+  , module MA.Coalgebra.Parser.Class
   ) where
 
-import           Data.Void (Void)
-import           Data.Tuple
 import           Control.Monad (void)
+import           Data.Bifunctor
+import           Data.Tuple
+import           Data.Void (Void)
 
 import           Control.Monad.State.Strict (StateT, execStateT)
 import qualified Data.HashMap.Strict as M
@@ -32,13 +34,10 @@ import           MA.Coalgebra.Parser.Internal
 import           MA.Coalgebra.RefinementTypes
 import           MA.FunctorExpression.Sorts (Sort, Sorted(..))
 import           MA.FunctorExpression.Type
+import           MA.FunctorExpression.Desorting (Desorted)
 import qualified MA.Parser.Lexer as L
 import           MA.Parser.Types
-
-type MorphParser l h1 = StateT (ParserState l h1) Parser
-
-class ParseMorphism f where
-  parseMorphismPoint :: (Ord x) => f (MorphParser l h1 x) -> MorphParser l h1 (H1 f, Vector (x, Label f))
+import           MA.Coalgebra.Parser.Class
 
 newState :: MorphParser l h1 State
 newState = nextState <<%= succ
@@ -77,8 +76,8 @@ checkUndefinedRefs = use (symbolTable . to M.toList . to (filter isUndefined)) >
 newtype SymbolTable = SymbolTable { fromSymbolTable :: M.HashMap State Text }
   deriving (Show,Eq,Ord,NFData)
 
-finalizeState ::
-     ParserState l h1 -> (SymbolTable, Encoding (Sorted l) (Sorted h1))
+finalizeState :: forall f.
+     ParserState (Label f) (H1 f) -> (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
 finalizeState state =
   let
     h1s = state ^. h1Map
@@ -92,15 +91,12 @@ finalizeState state =
   in
     (SymbolTable symTab, Encoding.new h1Vec edges)
 
-toEdges :: (State, (Sort, Vector (State, l))) -> (Vector (Encoding.Edge (Sort, l)))
-toEdges (!from, (!sort, !succs)) = V.map (\(!to, !lab) -> Encoding.Edge from (sort, lab) to) succs
-
-morphismsParser ::
+morphismsParser :: forall f.
      (Functor f, ParseMorphism f)
   => FunctorExpression f Sort
-  -> Parser (SymbolTable, Encoding (Sorted (Label f)) (Sorted (H1 f)))
+  -> Parser (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
 morphismsParser Variable = error "should not happen: variable" -- FIXME: Useful error message
-morphismsParser (Functor sort f) = finalizeState <$> (execStateT p initState)
+morphismsParser (Functor sort f) = finalizeState @f <$> (execStateT p initState)
   where
     p = do
       void (some parsePoint)
@@ -124,7 +120,7 @@ parseMorphisms ::
   -> String
   -> Text
   -> Either (ParseError Char Void) ( SymbolTable
-                                   , Encoding (Sorted (Label f)) (Sorted (H1 f)))
+                                   , Encoding (Label (Desorted f)) (H1 (Desorted f)))
 parseMorphisms = parse . morphismsParser
 
 wrapper ::

src/MA/Coalgebra/Parser/Class.hs

+module MA.Coalgebra.Parser.Class
+  ( MorphParser
+  , ParseMorphism(..)
+  ) where
+
+import Data.Vector (Vector)
+
+import Control.Monad.State.Strict (StateT, execStateT)
+import MA.Coalgebra.Parser.Internal
+import MA.Coalgebra.RefinementTypes
+import MA.Parser.Types
+
+type MorphParser l h1 = StateT (ParserState l h1) Parser
+
+class ParseMorphism f where
+  parseMorphismPoint :: (Ord x) => f (MorphParser l h1 x) -> MorphParser l h1 (H1 f, Vector (x, Label f))

src/MA/FunctorExpression/Desorting.hs

 {-# LANGUAGE Strict #-}
+{-# LANGUAGE CPP #-}
 module MA.FunctorExpression.Desorting
   ( Desorted
   , Sorted(..)
@@ -20,17 +21,37 @@ desort :: FunctorExpression f Sort -> Desorted f ()
 desort expr = Desorted expr ()
 
 type instance H1 (Desorted f) = Sorted (H1 f)
+#ifdef RELEASE
+type instance Label (Desorted f) = Label f
+type instance Weight (Desorted f) = Weight f
+type instance H3 (Desorted f) = H3 f
+#else
 type instance Label (Desorted f) = Sorted (Label f)
 type instance Weight (Desorted f) = Sorted (Weight f)
 type instance H3 (Desorted f) = Sorted (H3 f)
+#endif
 
 instance RefinementInterface f => RefinementInterface (Desorted f) where
   {-# SPECIALIZE instance RefinementInterface (Desorted SomeFunctor) #-}
+
+#ifdef RELEASE
+  init (Sorted sort h1) labels = init @f h1 labels
+#else
   init (Sorted sort h1) labels = Sorted sort (init @f h1 (filterBySort sort labels))
+#endif
 
+#ifdef RELEASE
+  update labels w =
+    let (l, h3, r) = ((update @f) $! labels) $! w
+    in (l, h3, r)
+#else
   update labels (Sorted sort w) =
     let (l, h3, r) = update @f (filterBySort sort labels) w
     in (Sorted sort l, Sorted sort h3, Sorted sort r)
+#endif
 
+#ifndef RELEASE
+-- FIXME Don't ignore sort-mismatches. Raise a lound error!
 filterBySort :: Sort -> [Sorted x] -> [x]
 filterBySort sort = map sortedElem . filter ((==sort) . sortedSort)
+#endif

src/MA/Functors/Polynomial.hs

@@ -301,22 +301,27 @@ instance RefinementInterface Polynomial where
        [Label Polynomial]
     -> Weight Polynomial
     -> (Weight Polynomial, H3 Polynomial, Weight Polynomial)
-  update = curry (val . up)
+  update !labs !w = {-# SCC polynoial #-} val $! (up $! (labs, w))
     where
       val :: H3 Polynomial -> (Weight Polynomial, H3 Polynomial, Weight Polynomial)
-      val h3 = (fmap (== ToSub) h3, h3, fmap (== ToCompound) h3)
+      val !h3 =
+        let !toS = {-# SCC a #-} fmap (== ToSub) h3
+            !toC = {-# SCC a #-} fmap (== ToCompound) h3
+        in
+          (toS, h3, toC)
 
       up :: ([Label Polynomial], Weight Polynomial) -> H3 Polynomial
-      up (labels, weight) = fmapIndex (\i j bi -> bi +? ((i,j) `elem` labels)) weight
+      up (!labels, !weight) = {-# SCC a #-} (fmapIndex $! (\i j bi -> bi +? ((i,j) `elem` labels))) $! weight
 
       (+?) :: Bool -> Bool -> Three
-      (+?) a b = toEnum (fromEnum a + fromEnum b)
+      (+?) !a !b = {-# SCC a #-}  toEnum (fromEnum a + fromEnum b)
 
 fmapIndex :: forall a b. (Int -> Int -> a -> b) -> SumValue a -> SumValue b
-fmapIndex f (SumValue s (ProductValue factors)) =
-  SumValue s (ProductValue (V.imap fmapFactor factors))
+fmapIndex f (SumValue !s (ProductValue !factors)) =
+  let !res = V.imap' fmapFactor factors
+  in (SumValue $! s) $! (ProductValue $! res)
 
   where
     fmapFactor :: Int -> FactorValue a -> FactorValue b
-    fmapFactor i (ExponentialValue as) = ExponentialValue (V.imap (f i) as)
-    fmapFactor i other = fmap (f i 0) other
+    fmapFactor !i (ExponentialValue !as) = ExponentialValue (V.imap' (f i) as)
+    fmapFactor !i !other = (fmap $! (f i 0)) $! other

src/MA/Functors/SomeFunctor.hs

@@ -20,7 +20,7 @@ import qualified Data.Vector as V
 import MA.RefinementInterface
 import MA.Coalgebra.RefinementTypes
 import MA.FunctorExpression.Parser
-import MA.Coalgebra.Parser
+import MA.Coalgebra.Parser.Class
 
 type Suitable f = (RefinementInterface f, Functor f, Foldable f, Traversable f, NFData (H1 f), NFData (Label f))
 
@@ -94,9 +94,9 @@ instance RefinementInterface SomeFunctor where
         Nothing -> Nothing
         Just HRefl -> Just l
 
-  update labels (SomeWeight (f :: TypeRep tf) w) =
-    let myLabels = mapMaybe isSameType labels
-        (a, b, c) = update @tf myLabels w
+  update labels (SomeWeight (f :: TypeRep tf) w) = {-# SCC thefuck #-}
+    let myLabels = (mapMaybe $! isSameType) $! labels
+        (a, b, c) = (update @tf $! myLabels) $! w
     in (SomeWeight f a, SomeH3 f b, SomeWeight f c)
 
     where

tests/Data/RefinablePartitionSpec.hs

@@ -12,6 +12,7 @@ import Data.Maybe (isJust,isNothing,fromJust)
 
 import qualified Data.Vector as V
 import qualified Data.Vector.Algorithms.Intro as V
+import qualified Data.Vector.Unboxed as VU
 
 import Data.RefinablePartition
 
@@ -60,15 +61,15 @@ statesOfBlockSpec = describe "statesOfBlock" $ do
         | otherwise = 2
 
   it "returns the correct states" $
-    toList (runST (make 10 3 initPart >>= flip statesOfBlock 1))
+    VU.toList (runST (make 10 3 initPart >>= flip statesOfBlock 1))
       `shouldMatchList` [3,4,5,6,9]
 
   it "works with empty blocks" $
-    toList (runST (make 5 3 initPart >>= flip statesOfBlock 2))
+    VU.toList (runST (make 5 3 initPart >>= flip statesOfBlock 2))
       `shouldMatchList` []
 
   it "works with block containing all states" $
-    toList (runST (make 3 3 initPart >>= flip statesOfBlock 0))
+    VU.toList (runST (make 3 3 initPart >>= flip statesOfBlock 0))
       `shouldMatchList` [0,1,2]
 
 markSpec :: Spec
@@ -220,8 +221,8 @@ markedStatesSpec = describe "markedStates" $ do
           mapM_ (mark p) states
 
           marked <- markedStates p blk
-          blockStates <- toList <$> statesOfBlock p blk
-          return $ sort (intersect states blockStates) == sort (toList marked)
+          blockStates <- VU.toList <$> statesOfBlock p blk
+          return $ sort (intersect states blockStates) == sort (VU.toList marked)
     in
       property $
         forAll (arbitraryBlock 3) $ \block ->
@@ -239,9 +240,9 @@ splitMarkedSpec = describe "splitMarkedSpec" $ do
     let doIt markStates block = runST $ do
           p <- make 10 3 initPart
           mapM_ (mark p) markStates
-          markedPreviously <- statesOfBlock p block >>= V.filterM (isMarked p)
+          markedPreviously <- statesOfBlock p block >>= VU.filterM (isMarked p)
           (a, _) <- splitMarked p block
-          nowInBlock <- maybe (return V.empty) (statesOfBlock p) a
+          nowInBlock <- maybe (return VU.empty) (statesOfBlock p) a
           return (nowInBlock, markedPreviously)
     in
       property $
@@ -255,9 +256,9 @@ splitMarkedSpec = describe "splitMarkedSpec" $ do
           p <- make 10 3 initPart
           mapM_ (mark p) markStates
           unMarkedPreviously <- statesOfBlock p block
-            >>= V.filterM (fmap not . isMarked p)
+            >>= VU.filterM (fmap not . isMarked p)
           (_, b) <- splitMarked p block
-          nowInBlock <- maybe (return V.empty) (statesOfBlock p) b
+          nowInBlock <- maybe (return VU.empty) (statesOfBlock p) b