diff options
Diffstat (limited to 'LifetimeAnalysis2.hs')
-rw-r--r-- | LifetimeAnalysis2.hs | 104 |
1 files changed, 104 insertions, 0 deletions
diff --git a/LifetimeAnalysis2.hs b/LifetimeAnalysis2.hs new file mode 100644 index 0000000..a7bc4c5 --- /dev/null +++ b/LifetimeAnalysis2.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE RankNTypes #-} + +module LifetimeAnalysis(lifetimeAnalysis, Access(..), unAccess) where + +import Control.Monad +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Maybe +import Data.Vector ((!)) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV + +import Utils + + +data Access a = Write a | Read a + deriving (Show, Eq) + +unAccess :: Access a -> a +unAccess (Write x) = x +unAccess (Read x) = x + +type BB a = ([[Access a]], [Int]) + +type Mark = V.Vector (V.Vector Bool) +type MutMark s = MV.MVector s (MV.MVector s Bool) + +lifetimeAnalysis :: Eq a => a -> [BB a] -> [[Bool]] +lifetimeAnalysis target bbs = V.toList $ V.map V.toList $ + foldOr2 $ map (\p -> markAliveFrom bbs target p (emptyMark bbs)) occurrences + where + occurrences :: [(Int, Int)] + occurrences = do + (i, bb) <- zip [0..] bbs + (j, ins) <- zip [0..] (fst bb) + if ins `contains` Write target || ins `contains` Read target + then [(i, j)] + else [] + +emptyMark :: [BB a] -> Mark +emptyMark bbs = V.fromList $ flip map bbs $ \(inss, _) -> V.replicate (length inss) False + +-- Assumes `target` is known to be alive at `pos`. +markAliveFrom :: Eq a => [BB a] -> a -> (Int, Int) -> Mark -> Mark +markAliveFrom bbs target pos topmark = runST $ do + maybem <- goNoCheck pos topmark + m <- case maybem of + Nothing -> thaw2 topmark + Just m' -> return m' + setAt2 m pos True + freeze2 m + where + goNoCheck :: (Int, Int) -> MutMark s -> ST s (Maybe (MutMark s)) + goNoCheck (i, j) mark = do + let suc = flip filter (successors bbs (i, j)) $ \(i', j') -> + not $ mark ! i' ! j' + setAt2 mark (i, j) True + res <- mapM (\s -> go s mark) suc + case catMaybes res of + [] -> return Nothing + mutmarks -> Just <$> mvFoldOr2 mutmarks + + go :: (Int, Int) -> MutMark s -> ST s (Maybe (MutMark s)) + go (i, j) mark + | fst (bbs !! i) !! j `contains` Write target = return Nothing + | fst (bbs !! i) !! j `contains` Read target = Just $ setAt2 mark (i, j) True + | otherwise = goNoCheck (i, j) mark + +successors :: [BB a] -> (Int, Int) -> [(Int, Int)] +successors bbs (i, j) = + let (inss, nexts) = bbs !! i + in if j < length inss - 1 + then [(i, j + 1)] + else [(n, 0) | n <- nexts] + +setAt2 :: MutMark s -> (Int, Int) -> Bool -> ST s () +setAt2 l (i, j) v = do + row <- MV.read l i + MV.write row j v + +foldOr2 :: [Mark] -> Mark +foldOr2 marks = + let (dim1, dim2) = (V.length (head marks), V.length (head marks ! 0)) + in V.generate dim1 $ \i -> V.generate dim2 $ \j -> + foldl1 (||) $ map (\m -> m ! i ! j) marks + +mvFoldOr2 :: [MutMark s] -> ST s (MutMark s) +mvFoldOr2 marks = do + let dim1 = MV.length (head marks) + dim2 <- liftM MV.length $ MV.read (head marks) 0 + mvGenerate dim1 $ \i -> mvGenerate dim2 $ \j -> + foldl1 (||) <$> mapM (\m -> MV.read m i >>= \row -> MV.read row j) marks + +thaw2 :: Mark -> ST s (MutMark s) +thaw2 = join . fmap V.thaw . V.mapM V.thaw + +freeze2 :: MutMark s -> ST s Mark +freeze2 = join . fmap (V.mapM V.freeze) . V.freeze + +mvGenerate :: Int -> (Int -> ST s a) -> ST s (MV.MVector s a) +mvGenerate sz f = do + v <- MV.new sz + mapM_ (\i -> f i >>= \value -> MV.write v i value) [0..sz-1] + return v |