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:)