{-# LANGUAGE ForeignFunctionInterface, ViewPatterns #-} {- FFI wrappers for benchmarking. -} #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) import Foreign hiding (unsafePerformIO) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) import Data.Graph.Planar hiding (empty) import Data.Graph.Planar.Internal import Data.List(foldl') import qualified Data.Map as M import Data.Maybe(fromJust) import Data.CircularList(focus, fromList, empty) import Data.Functor((<$>)) import qualified Data.Foldable as F import Control.Arrow(first,second) import Data.Sequence(Seq, (<|), (|>), (><), viewl, ViewL(..)) import qualified Data.Sequence as Seq import Criterion.Main import Criterion.Config import Control.DeepSeq #include "bench_match_bud.h" -- ----------------------------------------------------------------------------- null_node :: CInt null_node = #const NULL_NODE ephemeral_edge :: CInt ephemeral_edge = #const EPHEMERAL_EDGE null_edge :: CInt null_edge = #const NULL_EDGE {- foreign import ccall unsafe "matchBud" matchBud_from_c :: Ptr DangD -> Ptr SGraph -> IO () -} main :: IO () main = do with ddl $ \ pdl -> with ddr $ \ pdr -> do -- print $ c_matchBud pdd == matchBud dd defaultMainWith criterionConfig (return ()) [ bench "Haskell matchBud" $ nf (mergeBlackSub ddl) ddr , bench "C matchBud" $ (c_mergeBlackSub ddl pdl) pdr ] criterionConfig :: Config criterionConfig = defaultConfig { cfgSamples = ljust 1000 } {- c_matchBud :: Ptr DangD -> SGraph c_matchBud = unsafePerformIO . c_matchBud' -} {- c_matchBud' :: Ptr DangD -> IO () c_matchBud' pdd = do pddg <- #{peek DANGD, graph} pdd ord <- fromCI <$> #{peek GRAPH, numNodes} pddg sz <- fromCI <$> #{peek GRAPH, numEdges} pddg allocaSGraph ord sz $ \ pg -> do matchBud_from_c pdd pg -} {- test :: IO SGraph test = with dd $ \ pdd -> do pddg <- #{peek DANGD, graph} pdd ord <- fromCI <$> #{peek GRAPH, numNodes} pddg sz <- fromCI <$> #{peek GRAPH, numEdges} pddg allocaSGraph ord sz $ \ pg -> do c_matchBud pdd pg peek pg -} -- ----------------------------------------------------------------------------- data SEdge = SE { fromNd :: CInt , toNd :: CInt , prevID :: CInt , nextID :: CInt , invID :: CInt } deriving (Eq, Ord, Show, Read) nullSEdge :: SEdge nullSEdge = SE { fromNd = null_node , toNd = null_node , prevID = null_edge , nextID = null_edge , invID = null_edge } instance Storable SEdge where sizeOf _ = #{size EDGE} alignment _ = #{alignment EDGE} peek ptr = do from <- #{peek EDGE, start} ptr to <- #{peek EDGE, end} ptr prv <- #{peek EDGE, prev} ptr nxt <- #{peek EDGE, next} ptr inv <- #{peek EDGE, invers} ptr return $ SE from to prv nxt inv poke ptr (SE from to prv nxt inv) = do #{poke EDGE, start} ptr from #{poke EDGE, end} ptr to #{poke EDGE, prev} ptr prv #{poke EDGE, next} ptr nxt #{poke EDGE, invers} ptr inv fromEdge :: EdgeInfo a -> SEdge fromEdge ei = SE { fromNd = conNode $ _fromNode ei , toNd = conNode $ _toNode ei , prevID = conEdge $ _prevEdge ei , nextID = conEdge $ _nextEdge ei , invID = conEdge $ inverse ei } toEdge :: SEdge -> EdgeInfo () toEdge se = EInfo { _fromNode = conNode' $ fromNd se , _toNode = conNode' $ toNd se , _prevEdge = conEdge' $ prevID se , _nextEdge = conEdge' $ nextID se , inverse = conEdge' $ invID se , edgeInfo = () } -- ----------------------------------------------------------------------------- type Graph = PlanarGraph () () -- | The graph /must/ be compact (e.g. result of renumberedTraversal). -- Also assumes all nodes have at least one edge attached to them. -- -- For peek to work, it must also be compact in C. data SGraph = SG { maxNodes :: Int , maxEdges :: Int , graph :: Graph } deriving (Eq, Show, Read) instance NFData SGraph where rnf (SG maxN maxE g) = rnf maxN `seq` rnf maxE `seq` rnf g instance Storable SGraph where sizeOf _ = #{size GRAPH} alignment _ = #{alignment GRAPH} peek ptr = do maxN <- fromCI <$> #{peek GRAPH, numNodes} ptr nextN <- #{peek GRAPH, nextNode} ptr nArr <- #{peek GRAPH, firstEdge} ptr -- We don't need the entire array here. ns <- peekArray (fromCI nextN) nArr print $ zip ([0..] :: [CInt]) ns -- (ns :: [CInt]) maxE <- fromCI <$> #{peek GRAPH, numEdges} ptr nextE <- fromCI <$> #{peek GRAPH, nextEdge} ptr print nextE print maxE eArr <- #{peek GRAPH, edges} ptr -- We don't need the entire array here. es <- peekArray maxE eArr mapM_ print $ zip [0..] es return . SG maxN maxE $ mkPG ns es where mkPG ns es = PG ns' es' where ns' = M.mapKeysMonotonic Node . M.fromDistinctAscList . map (second toNI) . filter ((null_edge/=) . snd) $ zip [minBound..] ns toNI fe = NInfo { outgoing = oes , nodeInfo = () } where oes | fe == ephemeral_edge = empty | otherwise = fromList . eFrom $ conEdge' fe es' = M.mapKeysMonotonic Edge . M.fromDistinctAscList . map (second toEdge) . filter ((null_node/=) . fromNd . snd) $ zip [minBound..] es nextE e = _nextEdge $ es' M.! e eFrom e = (:) e . takeWhile (/=e) $ iterate nextE (nextE e) poke ptr (SG maxN maxE g) = withArr maxN ns' $ \ nArr -> withArr maxE es' $ \ eArr -> do #{poke GRAPH, numNodes} ptr (toCI maxN) #{poke GRAPH, nextNode} ptr (toCI numNs) #{poke GRAPH, firstEdge} ptr nArr #{poke GRAPH, numEdges} ptr (toCI maxE) #{poke GRAPH, nextEdge} ptr (toCI numEs) #{poke GRAPH, edges} ptr eArr where numNs = order g ns = map (maybe ephemeral_edge conEdge . focus . outgoing) . M.elems $ _nodes g ns' = ns ++ replicate (maxN - numNs) null_edge numEs = 2 * size g -- Need factor of 2 for half-edges. es = map fromEdge . M.elems $ _edges g es' = es ++ replicate (maxE - numEs) nullSEdge allocaSGraph :: Int -> Int -> (Ptr SGraph -> IO a) -> IO a allocaSGraph ord sz f = alloca $ \ pg -> allocaArray ord $ \ pns -> allocaArray sz $ \ pes -> do #{poke GRAPH, firstEdge} pg (pns :: Ptr CInt) #{poke GRAPH, edges} pg (pes :: Ptr SEdge) f pg -- ----------------------------------------------------------------------------- type Queue = Seq Node data DEQueue = DQ { maxSize :: Int , queue :: Queue } deriving (Eq, Ord, Show, Read) instance (NFData a) => NFData (Seq a) where rnf = rnf . F.toList instance NFData DEQueue where rnf (DQ ms q) = rnf ms `seq` rnf q instance Storable DEQueue where sizeOf _ = #{size DEQUEUE} alignment _ = #{alignment DEQUEUE} peek ptr = do ms <- fromCI <$> #{peek DEQUEUE, qLen} ptr qPtr <- #{peek DEQUEUE, q} ptr qArr <- peekArray ms qPtr return . DQ ms $ go qArr where go qArr = Seq.fromList . map conNode' $ qStart ++ qEnd where (qEnd,qArr') = span (/=null_node) qArr qStart = dropWhile (==null_node) qArr' poke ptr (DQ ms q) = withArr ms qL $ \ qArr -> do #{poke DEQUEUE, qLen} ptr $ toCI ms #{poke DEQUEUE, startInd} ptr (0 :: CInt) #{poke DEQUEUE, endInd} ptr $ toCI (qLen - 1) #{poke DEQUEUE, q} ptr qArr where qLen = Seq.length q qL = map conNode (F.toList q) ++ replicate (ms - qLen) null_node allocaDEQueue :: Int -> (Ptr DEQueue -> IO a) -> IO a allocaDEQueue len f = alloca $ \ pq -> allocaArray len $ \ pqa -> do #{poke DEQUEUE, q} pq (pqa :: Ptr CInt) f pq -- ----------------------------------------------------------------------------- -- A fake DangD type that only has one outgoing and one incoming bud. data DangD = DD { rootNode :: Maybe Node , sgraph :: SGraph , outBuds :: DEQueue , inBuds :: DEQueue } deriving(Eq, Show, Read) instance NFData DangD where rnf (DD mr sg ob ib) = rnf mr `seq` rnf sg `seq` rnf ob `seq` rnf ib instance Storable DangD where sizeOf _ = #{size DANGD} alignment _ = #{alignment DANGD} peek ptr = do rn <- #{peek DANGD, rootNode} ptr grP <- #{peek DANGD, graph} ptr gr <- peek grP outPtr <- #{peek DANGD, outBuds} ptr outBs <- peek outPtr inPtr <- #{peek DANGD, inBuds} ptr inBs <- peek inPtr return $ DD (fRN rn) gr outBs inBs where fRN rn | rn == null_node = Nothing | otherwise = Just $ conNode' rn poke ptr (DD rn gr outBs inBs) = with gr $ \ grP -> with outBs $ \ outPtr -> with inBs $ \ inPtr -> do #{poke DANGD, rootNode} ptr $ maybe null_node conNode rn #{poke DANGD, graph} ptr grP #{poke DANGD, outBuds} ptr outPtr #{poke DANGD, inBuds} ptr inPtr allocaDangD :: Int -> Int -> Int -> Int -> (Ptr DangD -> IO a) -> IO a allocaDangD ord sz oLen iLen f = alloca $ \ pdd -> allocaSGraph ord sz $ \ psg -> allocaDEQueue oLen $ \ pob -> allocaDEQueue iLen $ \ pib -> do #{poke DANGD, graph} pdd psg #{poke DANGD, outBuds} pdd pob #{poke DANGD, inBuds} pdd pib f pdd -- Use the sizing information of the specified DangD allocaDangDSize :: DangD -> (Ptr DangD -> IO a) -> IO a allocaDangDSize dd = allocaDangD (maxNodes $ sgraph dd) (maxEdges $ sgraph dd) (maxSize $ outBuds dd) (maxSize $ inBuds dd) toDangD :: Int -> Int -> Maybe Node -> PlanarGraph () () -> Seq Node -> Seq Node -> DangD toDangD d n rn g obs ibs = force DD { rootNode = nfunc <$> rn , sgraph = SG numNs numEs g' , outBuds = obQ , inBuds = ibQ } where b = 2*(n-2)`div`(d-2) - 1 maxOut = (d-1) * b -- Each black attached to at least one "white" maxIn = maxOut - d numNs = b + maxOut + maxIn + 1 -- outer -- The +1 in the first term is for the outer face. numEs = (d * (b+1)) {- * 2 `div` 2 -} + 2 * (maxOut + maxIn) -- 2* for half edges trv = traverseGraph breadthFirst g Nothing g' = renumberedTraversal trv nfunc = traversalRevNodeFn' trv obs' = nfunc <$> obs obQ = DQ maxOut obs' ibs' = nfunc <$> ibs ibQ = DQ maxIn ibs' -- ----------------------------------------------------------------------------- mergeBlackSub :: DangD -> DangD -> DangD mergeBlackSub dl dr = dl { sgraph = sgl { graph = gr''' } , outBuds = oblq { queue = ob' } , inBuds = iblq { queue = ib' } } where -- Black-rooted, so will have a root. (Just r) = rootNode dl sgl = sgraph dl oblq = outBuds dl iblq = inBuds dl (gr,transN,_) = mergeGraphs (graph sgl) (graph $ sgraph dr) (gr',bd) = addBud r gr (gr'',obl',ibr') = matchBuds (queue oblq) (fmap transN . queue $ inBuds dr) gr' obr' = fmap transN . queue $ outBuds dr ob = obr' >< obl' ib = queue iblq >< ibr' (gr''',ob',ib') = maybeMatch bd ob ib gr'' matchBud :: Node -> Node -> Graph -> Graph matchBud ob ib m = snd . addUEdge f (BeforeEdge oeBefore) t (BeforeEdge ieBefore) . deleteNode ob . deleteNode ib $ m where -- Replacement edge going in -- This will be a Bud edge oe = fromJust . focus $ incomingEdges m ob oeBefore = nextEdge m oe f = fromNode m oe -- Replacement edge going out -- This will be a BudInverse edge ie = fromJust . focus $ incomingEdges m ib ieBefore = nextEdge m ie t = fromNode m ie matchBuds :: Queue -> Queue -> Graph -> (Graph, Queue, Queue) matchBuds bo bi g = (g', bo', bi') where (bs,(bo',bi')) = zipRest matchBud bo bi g' = foldl' (flip ($)) g bs addBud :: Node -> Graph -> (Graph, Node) addBud n g = (snd $ addUEdge n Anywhere bd Anywhere mb', bd) where (bd,mb') = addUNode g maybeMatch :: Node -> Queue -> Queue -> Graph -> (Graph, Queue, Queue) maybeMatch ib obs ibs gr = case viewl obs of ob :< obs' -> (matchBud ob ib gr, obs', ibs) _ -> (gr, obs, ibs |> ib) -- ----------------------------------------------------------------------------- foreign import ccall unsafe "mergeBlackSub" mergeBlackSub_from_c :: Ptr DangD -> Ptr DangD -> IO () foreign import ccall unsafe "cloneDANGD" c_cloneDANGD :: Ptr DangD -> Ptr DangD -> IO () foreign import ccall unsafe "appendGraph" c_appendGraph :: Ptr SGraph -> Ptr SGraph -> Ptr CInt -> Ptr CInt -> IO () -- DangD parameter just used for sizing info for cloning. c_mergeBlackSub :: DangD -> Ptr DangD -> Ptr DangD -> IO () c_mergeBlackSub dd pdl pdr = allocaDangDSize dd $ \ pdl' -> do c_cloneDANGD pdl pdl' mergeBlackSub_from_c pdl' pdr {- dd' :: DangD dd' = toDangD d n gr outB inB where d = 5 n = 17 gr = deserialise [(0,(),[(138,36,(),139),(136,35,(),137),(134,34,(),135),(132,33,(),133),(131,28,(),130)]),(1,(),[(110,27,(),111),(109,25,(),108),(104,25,(),105),(106,5,(),107),(0,2,(),1)]),(2,(),[(1,1,(),0)]),(5,(),[(107,1,(),106),(81,22,(),80),(76,22,(),77),(78,9,(),79),(6,6,(),7)]),(6,(),[(7,5,(),6)]),(9,(),[(124,28,(),125),(79,5,(),78),(53,19,(),52),(48,19,(),49),(50,13,(),51)]),(13,(),[(96,25,(),97),(51,9,(),50),(43,19,(),42),(40,19,(),41),(68,22,(),69)]),(19,(),[(71,22,(),70),(41,13,(),40),(42,13,(),43),(49,9,(),48),(52,9,(),53)]),(22,(),[(99,25,(),98),(69,13,(),68),(70,19,(),71),(77,5,(),76),(80,5,(),81)]),(25,(),[(127,28,(),126),(97,13,(),96),(98,22,(),99),(105,1,(),104),(108,1,(),109)]),(27,(),[(111,1,(),110)]),(28,(),[(130,0,(),131),(112,29,(),113),(125,9,(),124),(126,25,(),127),(128,32,(),129)]),(29,(),[(113,28,(),112)]),(32,(),[(129,28,(),128)]),(33,(),[(133,0,(),132)]),(34,(),[(135,0,(),134)]),(35,(),[(137,0,(),136)]),(36,(),[(139,0,(),138)])] outB = Node 36 inB = Node 32 dd :: DangD dd = toDangD d n gr outB inB where d = 5 n = 8 gr = deserialise [(0,(),[(36,15,(),37),(34,14,(),35),(32,13,(),33),(30,12,(),31),(29,7,(),28)]),(1,(),[(25,7,(),24),(22,7,(),23),(2,3,(),3),(0,2,(),1),(8,6,(),9)]),(2,(),[(1,1,(),0)]),(3,(),[(3,1,(),2)]),(6,(),[(9,1,(),8)]),(7,(),[(28,0,(),29),(10,8,(),11),(23,1,(),22),(24,1,(),25),(26,11,(),27)]),(8,(),[(11,7,(),10)]),(11,(),[(27,7,(),26)]),(12,(),[(31,0,(),30)]),(13,(),[(33,0,(),32)]),(14,(),[(35,0,(),34)]),(15,(),[(37,0,(),36)])] outB = Node 15 inB = Node 11 -} ddl :: DangD ddl = toDangD d n rn gr outBs inBs where d = 5 n = 17 rn = Just $ Node 0 gr = deserialise [(0,(),[(97,22,(),96),(0,22,(),1)]),(2,(),[(78,21,(),79),(77,19,(),76),(72,19,(),73),(74,6,(),75),(2,3,(),3)]),(3,(),[(3,2,(),2)]),(6,(),[(75,2,(),74),(49,16,(),48),(44,16,(),45),(46,10,(),47),(8,7,(),9)]),(7,(),[(9,6,(),8)]),(10,(),[(92,22,(),93),(47,6,(),46),(39,16,(),38),(36,16,(),37),(64,19,(),65)]),(16,(),[(67,19,(),66),(37,10,(),36),(38,10,(),39),(45,6,(),44),(48,6,(),49)]),(19,(),[(95,22,(),94),(65,10,(),64),(66,16,(),67),(73,2,(),72),(76,2,(),77)]),(21,(),[(79,2,(),78)]),(22,(),[(96,0,(),97),(80,23,(),81),(93,10,(),92),(94,19,(),95),(1,0,(),0)]),(23,(),[(81,22,(),80)])] inBs = Seq.fromList [Node 21] outBs = Seq.fromList [Node 23,Node 7,Node 3] ddr :: DangD ddr = toDangD d n rn gr outBs inBs where d = 5 n = 17 rn = Nothing gr = deserialise [(0,(),[(25,6,(),24),(22,6,(),23),(2,2,(),3),(0,1,(),1),(8,5,(),9)]),(1,(),[(1,0,(),0)]),(2,(),[(3,0,(),2)]),(5,(),[(9,0,(),8)]),(6,(),[(26,10,(),27),(12,8,(),13),(10,7,(),11),(23,0,(),22),(24,0,(),25)]),(7,(),[(11,6,(),10)]),(8,(),[(13,6,(),12)]),(10,(),[(27,6,(),26)])] inBs = Seq.fromList [Node 10,Node 5] outBs = Seq.fromList [Node 8,Node 7,Node 2,Node 1] -- dd1 already has root node (to complete the sub-mobile will need a bud after dd2) -- dd1 = SMobile {marked = Just Node_0, tree = deserialise [(0,(),[(97,22,(),96),(0,22,(),1)]),(2,(),[(78,21,(),79),(77,19,(),76),(72,19,(),73),(74,6,(),75),(2,3,(),3)]),(3,(),[(3,2,(),2)]),(6,(),[(75,2,(),74),(49,16,(),48),(44,16,(),45),(46,10,(),47),(8,7,(),9)]),(7,(),[(9,6,(),8)]),(10,(),[(92,22,(),93),(47,6,(),46),(39,16,(),38),(36,16,(),37),(64,19,(),65)]),(16,(),[(67,19,(),66),(37,10,(),36),(38,10,(),39),(45,6,(),44),(48,6,(),49)]),(19,(),[(95,22,(),94),(65,10,(),64),(66,16,(),67),(73,2,(),72),(76,2,(),77)]),(21,(),[(79,2,(),78)]),(22,(),[(96,0,(),97),(80,23,(),81),(93,10,(),92),(94,19,(),95),(1,0,(),0)]),(23,(),[(81,22,(),80)])], unmatchedIn = fromList [Node_21], unmatchedOut = fromList [Node_23,Node_7,Node_3]} -- dd2 = SMobile {marked = Nothing, tree = deserialise [(0,(),[(25,6,(),24),(22,6,(),23),(2,2,(),3),(0,1,(),1),(8,5,(),9)]),(1,(),[(1,0,(),0)]),(2,(),[(3,0,(),2)]),(5,(),[(9,0,(),8)]),(6,(),[(26,10,(),27),(12,8,(),13),(10,7,(),11),(23,0,(),22),(24,0,(),25)]),(7,(),[(11,6,(),10)]),(8,(),[(13,6,(),12)]),(10,(),[(27,6,(),26)])], unmatchedIn = fromList [Node_10,Node_5], unmatchedOut = fromList [Node_8,Node_7,Node_2,Node_1]} -- At least one of the resulting lists will be [] zipRest :: (a -> b -> c) -> Seq a -> Seq b -> ([c], (Seq a, Seq b)) zipRest f (viewl -> (a :< as)) (viewl -> (b :< bs)) = first ((:) $ f a b) $ zipRest f as bs zipRest _ as bs = ([],(as,bs)) conNode :: Node -> CInt conNode = fromIntegral . node conNode' :: CInt -> Node conNode' = Node . fromIntegral conEdge :: Edge -> CInt conEdge = fromIntegral . edge conEdge' :: CInt -> Edge conEdge' = Edge . fromIntegral withArr :: (Storable a) => Int -> [a] -> (Ptr a -> IO b) -> IO b withArr len xs f = allocaArray len $ \ pt -> pokeArray pt xs >> f pt toCI :: Int -> CInt toCI = fromIntegral fromCI :: CInt -> Int fromCI = fromIntegral