From 17b8a658d6a20744d3f70f2ab2e8e92825a81cbc Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Sun, 3 Sep 2017 22:37:39 +0200
Subject: New lifetime analysis module

---
 LifetimeAnalysis.hs | 111 ++++++++++++++++++++++++++++------------------------
 1 file changed, 60 insertions(+), 51 deletions(-)

diff --git a/LifetimeAnalysis.hs b/LifetimeAnalysis.hs
index 0921a8a..aaf0c30 100644
--- a/LifetimeAnalysis.hs
+++ b/LifetimeAnalysis.hs
@@ -1,6 +1,11 @@
-module LifetimeAnalysis(lifetimeAnalysis, Access(..), unAccess) where
+{-# LANGUAGE ScopedTypeVariables #-}
 
+module LifetimeAnalysis(fullLifetimeAnalysis, lifetimeAnalysis, Access(..), unAccess) where
+
+import Data.List
 import Data.Maybe
+import qualified Data.Map.Strict as Map
+import Debug.Trace
 
 import Utils
 
@@ -14,55 +19,59 @@ 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
+data DUIO a = DUIO {defs :: [a], uses :: [a], ins :: [a], outs :: [a]}
+  deriving Eq
+
+lifetimeAnalysis :: (Eq a, Ord a) => a -> [BB a] -> [[Bool]]
+lifetimeAnalysis target bbs = map (map (target `elem`)) $ fullLifetimeAnalysis bbs
+
+fullLifetimeAnalysis :: (Eq a, Ord a) => [BB a] -> [[[a]]]
+fullLifetimeAnalysis bbs =
+    let duios = map fst $ eqFixpoint analysisIterator $ flip map bbs $
+                    \bb@(_, nexts) -> let (d,u) = defUseAnalysis bb
+                                      in (DUIO d u [] [], nexts)
+    in map markLive $ zip bbs duios
+
+markLive :: forall a. (Eq a, Ord a) => (BB a, DUIO a) -> [[a]]
+markLive ((inaccs, _), duio) = init $ go fullaccs 0 (ins duio)
+  where
+    fullaccs = inaccs ++ [map Read (outs duio)]
+    allvars = nub $ concatMap (map unAccess) fullaccs
+    lastreads = Map.fromList $ map (\v -> (v, lastReadOf v)) allvars
+
+    lastReadOf v = fromMaybe (-1) $ fmap ((length fullaccs - 1) -) $
+                        findIndex (Read v `elem`) (reverse fullaccs)
+
+    go :: (Eq a, Ord a) => [[Access a]] -> Int -> [a] -> [[a]]
+    go [] _ _ = []
+    go (acl : rest) i lives =
+        let (ws, rs) = partitionAccess acl
+            newlives = union rs $ flip filter (union ws lives) $ \v -> case Map.lookup v lastreads of
+                            Nothing -> False
+                            Just j -> j > i
+        in lives : go rest (i+1) newlives
+
+analysisIterator :: (Eq a, Ord a) => [(DUIO a, [Int])] -> [(DUIO a, [Int])]
+analysisIterator toplist = map updateIns $ map updateOuts (zip toplist [0..])
   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
+    updateIns (duio, nexts) = (duio {ins = sort $ union (uses duio) (outs duio \\ defs duio)}, nexts)
+    updateOuts ((duio, nexts), idx) = (duio {outs = sort $ foldl union [] (insAfter idx)}, nexts)
+
+    insAfter = map (ins . fst . (toplist !!)) . snd . (toplist !!)
+
+defUseAnalysis :: Eq a => BB a -> ([a], [a])
+defUseAnalysis (inss, _) = foldl foldfunc ([], []) inss
   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))
+    foldfunc (d, u) accs =
+        let (ws, rs) = partitionAccess accs
+            newds = filter (not . (`elem` u)) ws
+            newus = filter (not . (`elem` d)) rs
+        in (union d newds, union u newus)
+
+partitionAccess :: [Access a] -> ([a], [a])
+partitionAccess [] = ([], [])
+partitionAccess (Write x : rest) = let (w, r) = partitionAccess rest in (x : w, r)
+partitionAccess (Read x : rest) = let (w, r) = partitionAccess rest in (w, x : r)
+
+eqFixpoint :: Eq a => (a -> a) -> a -> a
+eqFixpoint f x = let y = f x in if y == x then x else eqFixpoint f y
-- 
cgit v1.2.3