aboutsummaryrefslogtreecommitdiff
path: root/LifetimeAnalysis.hs
blob: 0921a8aa915398f0407363de6cc2ea4b8e9feaa2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
module LifetimeAnalysis(lifetimeAnalysis, Access(..), unAccess) where

import Data.Maybe

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

lifetimeAnalysis :: Eq a => a -> [BB a] -> [[Bool]]
lifetimeAnalysis target bbs =
    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] -> [[Bool]]
emptyMark bbs = flip map bbs $ \(inss, _) -> map (const False) inss

-- Assumes `target` is known to be alive at `pos`.
markAliveFrom :: Eq a => [BB a] -> a -> (Int, Int) -> [[Bool]] -> [[Bool]]
markAliveFrom bbs target pos topmark = setAt2 (maybe topmark id $ goNoCheck pos topmark) pos True
  where
    goNoCheck :: (Int, Int) -> [[Bool]] -> Maybe [[Bool]]
    goNoCheck (i, j) mark =
        let suc = flip filter (successors bbs (i, j)) $ \(i', j') ->
                      not $ mark !! i' !! j'
            markset = setAt2 mark (i, j) True
        in case catMaybes [go s markset | s <- suc] of
               [] -> Nothing
               l -> Just $ foldOr2 l

    go :: (Int, Int) -> [[Bool]] -> Maybe [[Bool]]
    go (i, j) mark
        | fst (bbs !! i) !! j `contains` Write target = 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]

modifyAt2 :: [[a]] -> (Int, Int) -> (a -> a) -> [[a]]
modifyAt2 l (i, j) f = modifyAt l i $ \li -> modifyAt li j f

modifyAt :: [a] -> Int -> (a -> a) -> [a]
modifyAt l i f = let (pre, v : post) = splitAt i l in pre ++ f v : post

setAt2 :: [[a]] -> (Int, Int) -> a -> [[a]]
setAt2 l p v = modifyAt2 l p (const v)

foldOr2 :: [[[Bool]]] -> [[Bool]]
foldOr2 = foldl1 (\m1 m2 -> map (map (uncurry (||)) . uncurry zip) (zip m1 m2))