src/Compiler/Hoopl/Passes/DList.hs

    {-# LANGUAGE CPP, GADTs #-}
    {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
    #if __GLASGOW_HASKELL__ >= 701
    {-# LANGUAGE Safe #-}
    #endif

    module Compiler.Hoopl.Passes.DList
      ( Doms, domEntry, domLattice
      , domPass
      )
    where

    import Compiler.Hoopl

    type Doms = WithBot [Label]
    -- ^ List of labels, extended with a standard bottom element

    -- | The fact that goes into the entry of a dominator analysis: the first node
    -- is dominated only by the entry point, which is represented by the empty list
    -- of labels.
    domEntry :: Doms
    domEntry = PElem []

    domLattice :: DataflowLattice Doms
    domLattice = addPoints "dominators" extend

    extend :: JoinFun [Label]
    extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j)
        where j = lcs l l'
              lcs :: [Label] -> [Label] -> [Label] -- longest common suffix
              lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'
                       | length l < length l' = lcs l' l
                       | otherwise = dropUnlike l l' l
              dropUnlike [] [] maybe_like = maybe_like
              dropUnlike (x:xs) (y:ys) maybe_like =
                  dropUnlike xs ys (if x == y then maybe_like else xs)
              dropUnlike _ _ _ = error "this can't happen"

              lengthDiffers [] [] = False
              lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys
              lengthDiffers [] (_:_) = True
              lengthDiffers (_:_) [] = True

    -- | Dominator pass
    domPass :: (NonLocal n, Monad m) => FwdPass m n Doms
    domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite
      where first n = fmap (entryLabel n:)