qute

  1{-# LANGUAGE CPP #-}
  2{-# LANGUAGE Strict #-}
  3-- SPDX-FileCopyrightText: 2009 Matt Morrow <klebinger.andreas@gmx.at>
  4--
  5-- SPDX-License-Identifier: BSD-3-Clause
  6{-# OPTIONS_GHC -Wno-name-shadowing #-}
  7
  8module Language.QBE.Analysis.Graph
  9  ( Node,
 10    Path,
 11    Edge,
 12    Graph,
 13    Rooted,
 14    idom,
 15    ipdom,
 16    domTree,
 17    pdomTree,
 18    dom,
 19    pdom,
 20    pddfs,
 21    rpddfs,
 22    fromAdj,
 23    fromEdges,
 24    toAdj,
 25    toEdges,
 26    asTree,
 27    asGraph,
 28    parents,
 29    ancestors,
 30  )
 31where
 32
 33import Control.Monad
 34import Control.Monad.ST.Strict
 35import Data.Array.Base
 36  ( unsafeNewArray_,
 37    unsafeRead,
 38    unsafeWrite,
 39  )
 40import Data.Array.ST
 41import Data.IntMap (IntMap)
 42import Data.IntMap.Strict qualified as IM
 43import Data.IntSet (IntSet)
 44import Data.IntSet qualified as IS
 45import Data.Maybe
 46import Data.Tree
 47import Data.Tuple (swap)
 48
 49-- Since GHC 9.10.1, Prelude exports foldl' before that we need 'Data.Foldable'.
 50--
 51-- See: https://gitlab.haskell.org/ghc/ghc/-/commit/f1ec362817baa5d440a9f2b3a8b17e5513538119
 52#if !MIN_VERSION_base(4,20,0)
 53import Data.Foldable (foldl')
 54#endif
 55
 56-----------------------------------------------------------------------------
 57
 58type Node = Int
 59
 60type Path = [Node]
 61
 62type Edge = (Node, Node)
 63
 64type Graph = IntMap IntSet
 65
 66type Rooted = (Node, Graph)
 67
 68-----------------------------------------------------------------------------
 69
 70-- | /Dominators/.
 71-- Complexity as for @idom@
 72dom :: Rooted -> [(Node, Path)]
 73dom = ancestors . domTree
 74
 75-- | /Post-dominators/.
 76-- Complexity as for @idom@.
 77pdom :: Rooted -> [(Node, Path)]
 78pdom = ancestors . pdomTree
 79
 80-- | /Dominator tree/.
 81-- Complexity as for @idom@.
 82domTree :: Rooted -> Tree Node
 83domTree a@(r, _) =
 84  let is = filter ((/= r) . fst) (idom a)
 85      tg = fromEdges (fmap swap is)
 86   in asTree (r, tg)
 87
 88-- | /Post-dominator tree/.
 89-- Complexity as for @idom@.
 90pdomTree :: Rooted -> Tree Node
 91pdomTree a@(r, _) =
 92  let is = filter ((/= r) . fst) (ipdom a)
 93      tg = fromEdges (fmap swap is)
 94   in asTree (r, tg)
 95
 96-- | /Immediate dominators/.
 97-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
 98-- \"a functional inverse of Ackermann's function\".
 99--
100-- This Complexity bound assumes /O(1)/ indexing. Since we're
101-- using @IntMap@, it has an additional /lg |V|/ factor
102-- somewhere in there. I'm not sure where.
103idom :: Rooted -> [(Node, Node)]
104idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
105
106-- | /Immediate post-dominators/.
107-- Complexity as for @idom@.
108ipdom :: Rooted -> [(Node, Node)]
109ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
110
111-----------------------------------------------------------------------------
112
113-- | /Post-dominated depth-first search/.
114pddfs :: Rooted -> [Node]
115pddfs = reverse . rpddfs
116
117-- | /Reverse post-dominated depth-first search/.
118rpddfs :: Rooted -> [Node]
119rpddfs = concat . levels . pdomTree
120
121-----------------------------------------------------------------------------
122
123type Dom s a = S s (Env s) a
124
125type NodeSet = IntSet
126
127type NodeMap a = IntMap a
128
129data Env s = Env
130  { succE :: !Graph,
131    predE :: !Graph,
132    bucketE :: !Graph,
133    dfsE :: {-# UNPACK #-} !Int,
134    zeroE :: {-# UNPACK #-} !Node,
135    rootE :: {-# UNPACK #-} !Node,
136    labelE :: {-# UNPACK #-} !(Arr s Node),
137    parentE :: {-# UNPACK #-} !(Arr s Node),
138    ancestorE :: {-# UNPACK #-} !(Arr s Node),
139    childE :: {-# UNPACK #-} !(Arr s Node),
140    ndfsE :: {-# UNPACK #-} !(Arr s Node),
141    dfnE :: {-# UNPACK #-} !(Arr s Int),
142    sdnoE :: {-# UNPACK #-} !(Arr s Int),
143    sizeE :: {-# UNPACK #-} !(Arr s Int),
144    domE :: {-# UNPACK #-} !(Arr s Node),
145    rnE :: {-# UNPACK #-} !(Arr s Node)
146  }
147
148-----------------------------------------------------------------------------
149
150idomM :: Dom s [(Node, Node)]
151idomM = do
152  dfsDom =<< rootM
153  n <- gets dfsE
154  forM_
155    [n, n - 1 .. 1]
156    ( \i -> do
157        w <- ndfsM i
158        ps <- predsM w
159        forM_
160          ps
161          ( \v -> do
162              sw <- sdnoM w
163              u <- eval v
164              su <- sdnoM u
165              when
166                (su < sw)
167                (store sdnoE w su)
168          )
169        z <- ndfsM =<< sdnoM w
170        modify
171          ( \e ->
172              e
173                { bucketE =
174                    IM.adjust
175                      (w `IS.insert`)
176                      z
177                      (bucketE e)
178                }
179          )
180        pw <- parentM w
181        link pw w
182        bps <- bucketM pw
183        forM_
184          bps
185          ( \v -> do
186              u <- eval v
187              su <- sdnoM u
188              sv <- sdnoM v
189              let dv = case su < sv of
190                    True -> u
191                    False -> pw
192              store domE v dv
193          )
194    )
195  forM_
196    [1 .. n]
197    ( \i -> do
198        w <- ndfsM i
199        j <- sdnoM w
200        z <- ndfsM j
201        dw <- domM w
202        when
203          (dw /= z)
204          ( do
205              ddw <- domM dw
206              store domE w ddw
207          )
208    )
209  fromEnv
210
211-----------------------------------------------------------------------------
212
213eval :: Node -> Dom s Node
214eval v = do
215  n0 <- zeroM
216  a <- ancestorM v
217  case a == n0 of
218    True -> labelM v
219    False -> do
220      compress v
221      a <- ancestorM v
222      l <- labelM v
223      la <- labelM a
224      sl <- sdnoM l
225      sla <- sdnoM la
226      case sl <= sla of
227        True -> return l
228        False -> return la
229
230compress :: Node -> Dom s ()
231compress v = do
232  n0 <- zeroM
233  a <- ancestorM v
234  aa <- ancestorM a
235  when
236    (aa /= n0)
237    ( do
238        compress a
239        a <- ancestorM v
240        aa <- ancestorM a
241        l <- labelM v
242        la <- labelM a
243        sl <- sdnoM l
244        sla <- sdnoM la
245        when
246          (sla < sl)
247          (store labelE v la)
248        store ancestorE v aa
249    )
250
251-----------------------------------------------------------------------------
252
253link :: Node -> Node -> Dom s ()
254link v w = do
255  n0 <- zeroM
256  lw <- labelM w
257  slw <- sdnoM lw
258  let balance s = do
259        c <- childM s
260        lc <- labelM c
261        slc <- sdnoM lc
262        case slw < slc of
263          False -> return s
264          True -> do
265            zs <- sizeM s
266            zc <- sizeM c
267            cc <- childM c
268            zcc <- sizeM cc
269            case 2 * zc <= zs + zcc of
270              True -> do
271                store ancestorE c s
272                store childE s cc
273                balance s
274              False -> do
275                store sizeE c zs
276                store ancestorE s c
277                balance c
278  s <- balance w
279  lw <- labelM w
280  zw <- sizeM w
281  store labelE s lw
282  store sizeE v . (+ zw) =<< sizeM v
283  let follow s = do
284        when
285          (s /= n0)
286          ( do
287              store ancestorE s v
288              follow =<< childM s
289          )
290  zv <- sizeM v
291  follow =<< case zv < 2 * zw of
292    False -> return s
293    True -> do
294      cv <- childM v
295      store childE v s
296      return cv
297
298-----------------------------------------------------------------------------
299
300dfsDom :: Node -> Dom s ()
301dfsDom i = do
302  _ <- go i
303  n0 <- zeroM
304  r <- rootM
305  store parentE r n0
306  where
307    go i = do
308      n <- nextM
309      store dfnE i n
310      store sdnoE i n
311      store ndfsE n i
312      store labelE i i
313      ss <- succsM i
314      forM_
315        ss
316        ( \j -> do
317            s <- sdnoM j
318            case s == 0 of
319              False -> return ()
320              True -> do
321                store parentE j i
322                go j
323        )
324
325-----------------------------------------------------------------------------
326
327initEnv :: Rooted -> ST s (Env s)
328initEnv (r0, g0) = do
329  -- Graph renumbered to indices from 1 to |V|
330  let (g, rnmap) = renum 1 g0
331      pred = predG g -- reverse graph
332      root = rnmap IM.! r0 -- renamed root
333      n = IM.size g
334      ns = [0 .. n]
335      m = n + 1
336
337  let bucket =
338        IM.fromList
339          (map (,mempty) ns)
340
341  rna <- newI m
342  writes
343    rna
344    ( fmap
345        swap
346        (IM.toList rnmap)
347    )
348
349  doms <- newI m
350  sdno <- newI m
351  size <- newI m
352  parent <- newI m
353  ancestor <- newI m
354  child <- newI m
355  label <- newI m
356  ndfs <- newI m
357  dfn <- newI m
358
359  -- Initialize all arrays
360  forM_ [0 .. n] (doms .= 0)
361  forM_ [0 .. n] (sdno .= 0)
362  forM_ [1 .. n] (size .= 1)
363  forM_ [0 .. n] (ancestor .= 0)
364  forM_ [0 .. n] (child .= 0)
365
366  (doms .= root) root
367  (size .= 0) 0
368  (label .= 0) 0
369
370  return
371    ( Env
372        { rnE = rna,
373          dfsE = 0,
374          zeroE = 0,
375          rootE = root,
376          labelE = label,
377          parentE = parent,
378          ancestorE = ancestor,
379          childE = child,
380          ndfsE = ndfs,
381          dfnE = dfn,
382          sdnoE = sdno,
383          sizeE = size,
384          succE = g,
385          predE = pred,
386          bucketE = bucket,
387          domE = doms
388        }
389    )
390
391fromEnv :: Dom s [(Node, Node)]
392fromEnv = do
393  dom <- gets domE
394  rn <- gets rnE
395  -- r     <- gets rootE
396  (_, n) <- st (getBounds dom)
397  forM
398    [1 .. n]
399    ( \i -> do
400        j <- st (rn !: i)
401        d <- st (dom !: i)
402        k <- st (rn !: d)
403        return (j, k)
404    )
405
406-----------------------------------------------------------------------------
407
408zeroM :: Dom s Node
409zeroM = gets zeroE
410
411domM :: Node -> Dom s Node
412domM = fetch domE
413
414rootM :: Dom s Node
415rootM = gets rootE
416
417succsM :: Node -> Dom s [Node]
418succsM i = gets (IS.toList . (! i) . succE)
419
420predsM :: Node -> Dom s [Node]
421predsM i = gets (IS.toList . (! i) . predE)
422
423bucketM :: Node -> Dom s [Node]
424bucketM i = gets (IS.toList . (! i) . bucketE)
425
426sizeM :: Node -> Dom s Int
427sizeM = fetch sizeE
428
429sdnoM :: Node -> Dom s Int
430sdnoM = fetch sdnoE
431
432-- dfnM :: Node -> Dom s Int
433-- dfnM = fetch dfnE
434ndfsM :: Int -> Dom s Node
435ndfsM = fetch ndfsE
436
437childM :: Node -> Dom s Node
438childM = fetch childE
439
440ancestorM :: Node -> Dom s Node
441ancestorM = fetch ancestorE
442
443parentM :: Node -> Dom s Node
444parentM = fetch parentE
445
446labelM :: Node -> Dom s Node
447labelM = fetch labelE
448
449nextM :: Dom s Int
450nextM = do
451  n <- gets dfsE
452  let n' = n + 1
453  modify (\e -> e {dfsE = n'})
454  return n'
455
456-----------------------------------------------------------------------------
457
458type A = STUArray
459
460type Arr s a = A s Int a
461
462infixl 9 !:
463
464infixr 2 .=
465
466-- | arr .= x idx => write x to index
467(.=) ::
468  (MArray (A s) a (ST s)) =>
469  Arr s a -> a -> Int -> ST s ()
470(v .= x) i = unsafeWrite v i x
471
472(!:) ::
473  (MArray (A s) a (ST s)) =>
474  A s Int a -> Int -> ST s a
475a !: i = do
476  o <- unsafeRead a i
477  return $! o
478
479new ::
480  (MArray (A s) a (ST s)) =>
481  Int -> ST s (Arr s a)
482new n = unsafeNewArray_ (0, n - 1)
483
484newI :: Int -> ST s (Arr s Int)
485newI = new
486
487-- newD :: Int -> ST s (Arr s Double)
488-- newD = new
489
490-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]
491-- dump a = do
492--   (m,n) <- getBounds a
493--   forM [m..n] (\i -> a!:i)
494
495writes ::
496  (MArray (A s) a (ST s)) =>
497  Arr s a -> [(Int, a)] -> ST s ()
498writes a xs = forM_ xs (\(i, x) -> (a .= x) i)
499
500-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)
501-- arr xs = do
502--   let n = length xs
503--   a <- new n
504--   go a n 0 xs
505--   return a
506--   where go _ _ _    [] = return ()
507--         go a n i (x:xs)
508--           | i <= n = (a.=x) i >> go a n (i+1) xs
509--           | otherwise = return ()
510
511-----------------------------------------------------------------------------
512
513(!) :: (Monoid a) => IntMap a -> Int -> a
514(!) g n = fromMaybe mempty (IM.lookup n g)
515
516fromAdj :: [(Node, [Node])] -> Graph
517fromAdj = IM.fromList . fmap (second IS.fromList)
518
519fromEdges :: [Edge] -> Graph
520fromEdges = collectI IS.union fst (IS.singleton . snd)
521
522toAdj :: Graph -> [(Node, [Node])]
523toAdj = fmap (second IS.toList) . IM.toList
524
525toEdges :: Graph -> [Edge]
526toEdges = concatMap (uncurry (fmap . (,))) . toAdj
527
528predG :: Graph -> Graph
529predG g = IM.unionWith IS.union (go g) g0
530  where
531    g0 = fmap (const mempty) g
532    go =
533      IM.foldrWithKey
534        ( \i a m ->
535            foldl'
536              ( \m p ->
537                  IM.insertWith
538                    mappend
539                    p
540                    (IS.singleton i)
541                    m
542              )
543              m
544              (IS.toList a)
545        )
546        mempty
547
548-- predG :: Graph -> Graph
549-- predG g = IM.unionWith IS.union (go g) g0
550--   where g0 = fmap (const mempty) g
551--         f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
552--         f m i a = foldl' (\m p -> IM.insertWith mappend p
553--                                       (IS.singleton i) m)
554--                         m
555--                        (IS.toList a)
556--         go :: IntMap IntSet -> IntMap IntSet
557--         go = flip IM.foldlWithKey' mempty f
558
559pruneReach :: Rooted -> Rooted
560pruneReach (r, g) = (r, g2)
561  where
562    is =
563      reachable
564        ( fromMaybe mempty
565            . flip IM.lookup g
566        )
567        r
568    g2 =
569      IM.map (IS.filter (`IS.member` is))
570        . IM.filterWithKey (\node _targets -> IS.member node is)
571        $ g
572
573tip :: Tree a -> (a, [Tree a])
574tip (Node a ts) = (a, ts)
575
576parents :: Tree a -> [(a, a)]
577parents (Node i xs) =
578  p i xs
579    ++ concatMap parents xs
580  where
581    p i = fmap ((,i) . rootLabel)
582
583ancestors :: Tree a -> [(a, [a])]
584ancestors = go []
585  where
586    go acc (Node i xs) =
587      let acc' = i : acc
588       in p acc' xs ++ concatMap (go acc') xs
589    p is = fmap ((,is) . rootLabel)
590
591asGraph :: Tree Node -> Rooted
592asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
593  where
594    go (Node a ts) =
595      let as = (map fst . fmap tip) ts
596       in (a, as) : concatMap go ts
597
598asTree :: Rooted -> Tree Node
599asTree (r, g) =
600  let go a = Node a (fmap go ((IS.toList . f) a))
601      f = (g !)
602   in go r
603
604reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
605reachable f a = go (IS.singleton a) a
606  where
607    go seen a =
608      let s = f a
609          as = IS.toList (s `IS.difference` seen)
610       in foldl' go (s `IS.union` seen) as
611
612collectI ::
613  (c -> c -> c) ->
614  (a -> Int) ->
615  (a -> c) ->
616  [a] ->
617  IntMap c
618collectI (<>) f g =
619  foldl'
620    ( \m a ->
621        IM.insertWith
622          (<>)
623          (f a)
624          (g a)
625          m
626    )
627    mempty
628
629-- collect :: (Ord b) => (c -> c -> c)
630--         -> (a -> b) -> (a -> c) -> [a] -> Map b c
631-- collect (<>) f g
632--   = foldl' (\m a -> SM.insertWith (<>)
633--                                   (f a)
634--                                   (g a) m) mempty
635
636-- | renum n g: Rename all nodes
637--
638-- Gives nodes sequential names starting at n.
639-- Returns the new graph and a mapping.
640-- (renamed, old -> new)
641renum :: Int -> Graph -> (Graph, NodeMap Node)
642renum from =
643  (\(_, m, g) -> (g, m))
644    . IM.foldrWithKey
645      ( \i ss (!n, !env, !new) ->
646          let (j, n2, env2) = go n env i
647              (n3, env3, ss2) =
648                IS.fold
649                  ( \k (!n, !env, !new) ->
650                      case go n env k of
651                        (l, n2, env2) -> (n2, env2, l `IS.insert` new)
652                  )
653                  (n2, env2, mempty)
654                  ss
655              new2 = IM.insertWith IS.union j ss2 new
656           in (n3, env3, new2)
657      )
658      (from, mempty, mempty)
659  where
660    go ::
661      Int ->
662      NodeMap Node ->
663      Node ->
664      (Node, Int, NodeMap Node)
665    go !n !env i =
666      case IM.lookup i env of
667        Just j -> (j, n, env)
668        Nothing -> (n, n + 1, IM.insert i n env)
669
670-----------------------------------------------------------------------------
671
672-- Nothing better than reinvinting the state monad.
673newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
674
675instance Functor (S z s) where
676  fmap f (S g) = S (\k -> g (k . f))
677
678instance Monad (S z s) where
679  return = pure
680  S g >>= f = S (\k -> g (\a -> unS (f a) k))
681
682instance Applicative (S z s) where
683  pure a = S (\k -> k a)
684  (<*>) = ap
685
686-- get :: S z s s
687-- get = S (\k s -> k s s)
688gets :: (s -> a) -> S z s a
689gets f = S (\k s -> k (f s) s)
690
691-- set :: s -> S z s ()
692-- set s = S (\k _ -> k () s)
693modify :: (s -> s) -> S z s ()
694modify f = S (\k -> k () . f)
695
696-- runS :: S z s a -> s -> ST z (a, s)
697-- runS (S g) = g (\a s -> return (a,s))
698evalS :: S z s a -> s -> ST z a
699evalS (S g) = g ((return .) . const)
700
701-- execS :: S z s a -> s -> ST z s
702-- execS (S g) = g ((return .) . flip const)
703st :: ST z a -> S z s a
704st m =
705  S
706    ( \k s -> do
707        a <- m
708        k a s
709    )
710
711store ::
712  (MArray (A z) a (ST z)) =>
713  (s -> Arr z a) -> Int -> a -> S z s ()
714store f i x = do
715  a <- gets f
716  st ((a .= x) i)
717
718fetch ::
719  (MArray (A z) a (ST z)) =>
720  (s -> Arr z a) -> Int -> S z s a
721fetch f i = do
722  a <- gets f
723  st (a !: i)
724
725-- Redefine Data.Bifunctor.second for GHC 7 compatibility
726second :: (b -> c) -> (a, b) -> (a, c)
727second f (a, b) = (a, f b)