STUFF

This was lying around and I didn't want to not back this up
to the server. Was apparently in the middle of testing the
lifetime analysis module.

I believe the terminal output for many input programs indicates
that the two lifetime analysis modules do not agree.....

5 files changed, 178 insertions, 10 deletions

diff --git a/CodeGen.hs b/CodeGen.hs
index 5ab991b..c837bdc 100644
--- a/CodeGen.hs
+++ b/CodeGen.hs
@@ -16,6 +16,7 @@ import AST
 import Defs
 import Intermediate
 import qualified LifetimeAnalysis as LA
+import qualified LifetimeAnalysisOld as LAO
 import RegAlloc
 import ReplaceRefs
 import Utils
@@ -106,7 +107,10 @@ codegenFunc (IRFunc _ name al bbs sid) = do
         alltemprefs = uniq $ sort $ map LA.unAccess $ concat $ concat $ map fst temprefsperbb
         lifespans = map (\r -> (findLifeSpan r, r)) alltemprefs
             where findLifeSpan ref =
-                      fromJust $ findFirstLast id $ concat $ LA.lifetimeAnalysis ref temprefsperbb
+                      let la = LA.lifetimeAnalysis ref temprefsperbb
+                          lao = LAO.lifetimeAnalysis ref temprefsperbb
+                      in (if la == lao then id else traceShow (ref,bbs,la,lao)) $
+                            fromJust $ findFirstLast id $ concat $ LA.lifetimeAnalysis ref temprefsperbb
 
         aliascandidates = findAliasCandidates bbs :: [(Ref, Ref)]
 
diff --git a/LifetimeAnalysis.hs b/LifetimeAnalysis.hs
index aaf0c30..a421383 100644
--- a/LifetimeAnalysis.hs
+++ b/LifetimeAnalysis.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module LifetimeAnalysis(fullLifetimeAnalysis, lifetimeAnalysis, Access(..), unAccess) where
+module LifetimeAnalysis(fullLifetimeAnalysis, lifetimeAnalysis, Access(..), unAccess, BB) where
 
 import Data.List
 import Data.Maybe
@@ -36,20 +36,19 @@ 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)
+    hasReadBeforeWrite _ [] = False
+    hasReadBeforeWrite t (acl : rest)
+        | Read t `elem` acl = True
+        | Write t `elem` acl = False
+        | otherwise = hasReadBeforeWrite t rest
 
     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
+            newlives = union rs $ flip filter (union ws lives) $ \v -> hasReadBeforeWrite v rest
+        in newlives : 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..])
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
diff --git a/LifetimeAnalysisOld.hs b/LifetimeAnalysisOld.hs
new file mode 100644
index 0000000..f7635ad
--- /dev/null
+++ b/LifetimeAnalysisOld.hs
@@ -0,0 +1,60 @@
+module LifetimeAnalysisOld(lifetimeAnalysis) where
+
+import Data.Maybe
+
+import LifetimeAnalysis (Access(..), unAccess, BB)
+import Utils
+
+
+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))
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..2fdac90
--- /dev/null
+++ b/README.md
@@ -0,0 +1 @@
+Please note that this project is not done. There is unfinished code, the lifetime analysis module is not working completely correctly at the time of writing, and in general there are features not implemented. This git repo is not meant to show off a finished product!