WIP liveness analysis implementation

5 files changed, 79 insertions, 12 deletions

diff --git a/Intermediate.hs b/Intermediate.hs
index 2705431..6a11bf0 100644
--- a/Intermediate.hs
+++ b/Intermediate.hs
@@ -82,6 +82,17 @@ instance AllRefs Terminator where
     allRefs IExit = []
     allRefs IUnknown = []
 
+outEdges :: BB -> [Int]
+outEdges (BB _ _ term) = outEdgesT term
+
+outEdgesT :: Terminator -> [Int]
+outEdgesT (IBr _ a b) = [a, b]
+outEdgesT (IJmp a) = [a]
+outEdgesT (IRet _) = []
+outEdgesT (ITailC _ _) = []
+outEdgesT IExit = []
+outEdgesT IUnknown = []
+
 
 instance Show IRProgram where
     show (IRProgram bbs gfds datas) = intercalate "\n" $
diff --git a/Liveness.hs b/Liveness.hs
new file mode 100644
index 0000000..9df5484
--- /dev/null
+++ b/Liveness.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE TupleSections, ScopedTypeVariables #-}
+module Liveness (
+    livenessAnalysis
+) where
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+
+class    IntoSet s   where intoSet :: Ord a => s a -> Set a
+instance IntoSet []  where intoSet = Set.fromList
+instance IntoSet Set where intoSet = id
+
+
+livenessAnalysis
+    :: forall bbid bb ins var set.
+       (Ord bbid, Ord var, IntoSet set)
+    => [bb]  -- basic blocks
+    -> (bb -> bbid)  -- ID of the basic block; should probably be Int
+    -> (bb -> [ins])  -- instructions in the basic block
+    -> (bb -> [bbid])  -- control flow graph: subsequents of a basic block
+    -> (ins -> set var)  -- read set (variables required to be live when entering this instruction)
+    -> (ins -> set var)  -- write set (variables made available after this instruction)
+    -> [[Set var]]  -- variables live at the start of that instruction
+livenessAnalysis bblocks bidOf bbInss bbNexts fread fwrite =
+    let bbEndLive = computeFlow (Map.fromList (map (,Set.empty) bids))
+    in zipWith (\fs endlive -> init (scanr id endlive fs)) (mapToList insTransFs) (mapToList bbEndLive)
+  where
+    mapToList m = map (m Map.!) bids
+    bids = map bidOf bblocks
+    bidInss = Map.fromList (zip bids (map bbInss bblocks))
+    bidNexts = Map.fromList (zip bids (map bbNexts bblocks))
+    rwSets = Map.map (map (\ins -> (intoSet (fread ins), intoSet (fwrite ins)))) bidInss
+    insTransFs = Map.map (map (\(rs, ws) live -> (live Set.\\ ws) <> rs)) rwSets
+    bbTransFs = Map.map (foldr (.) id) insTransFs
+    computeFlow state = let l = iterate flowStep state in fst . head . dropWhile (uncurry (/=)) $ zip l (tail l)
+    flowStep state = foldl updateFlow state bids
+    updateFlow state bid = Map.insert bid ((bbTransFs Map.! bid) (Set.unions (map (state Map.!) (bidNexts Map.! bid)))) state
diff --git a/Main.hs b/Main.hs
index 14f3202..c378dde 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,11 +1,15 @@
 module Main where
 
 import Control.Monad
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 import System.Environment
 import System.Exit
 
 import Compiler
 import CompilerMacros
+import Intermediate
+import Liveness
 import Optimiser
 import Parser
 import VM
@@ -34,6 +38,29 @@ parseOptions' (_, Just _) (_:_) = putStrLn "At most one filename argument expect
 parseOptions :: [String] -> IO (Options, Maybe FilePath)
 parseOptions = parseOptions' (Options False False, Nothing)
 
+liveness :: IRProgram -> Map.Map Int [Set.Set Int]
+liveness (IRProgram bbs _ _) =
+    let sets = livenessAnalysis bbs bidOf itemsOf outEdges fread fwrite
+    in Map.fromList (zip (map bidOf bbs) sets)
+  where
+    itemsOf (BB _ inss term) = map Right inss ++ [Left term]
+    fread (Right (_, IAssign r)) = collect [r]
+    fread (Right (_, IParam _)) = []
+    fread (Right (_, IClosure _)) = []
+    fread (Right (_, IData _)) = []
+    fread (Right (_, ICallC r rs)) = collect (r : rs)
+    fread (Right (_, IAllocClo _ rs)) = collect rs
+    fread (Right (_, IDiscard r)) = collect [r]
+    fread (Left (IBr r _ _)) = collect [r]
+    fread (Left (IJmp _)) = []
+    fread (Left (IRet r)) = collect [r]
+    fread (Left (ITailC r rs)) = collect (r : rs)
+    fread (Left IExit) = []
+    fread (Left IUnknown) = []
+    fwrite (Right (r, _)) = collect [r]
+    fwrite (Left _) = []
+    collect rs = [i | RTemp i <- rs]
+
 main :: IO ()
 main = do
     (opts, mfname) <- getArgs >>= parseOptions
@@ -45,4 +72,5 @@ main = do
     irprog <- either die return (compileProgram prog')
     let opt = optimise irprog
     when (optIR opts) $ print opt
+    print (liveness opt)
     vmRun opt
diff --git a/Optimiser.hs b/Optimiser.hs
index 626cb50..f09128f 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -178,17 +178,6 @@ dedupDatas (IRProgram origbbs gfds datatbl) = IRProgram (map goBB origbbs) gfds
     goI (ref, IData i) = (ref, IData (valueIdx Map.! (datatbl !! i)))
     goI ins = ins
 
-outEdges :: BB -> [Int]
-outEdges (BB _ _ term) = outEdgesT term
-
-outEdgesT :: Terminator -> [Int]
-outEdgesT (IBr _ a b) = [a, b]
-outEdgesT (IJmp a) = [a]
-outEdgesT (IRet _) = []
-outEdgesT (ITailC _ _) = []
-outEdgesT IExit = []
-outEdgesT IUnknown = []
-
 readTempsBB :: BB -> [Int]
 readTempsBB (BB _ inss term) = concatMap (readTempsIC . snd) inss ++ readTempsT term
 
diff --git a/lisphs.cabal b/lisphs.cabal
index 640ceee..3bde869 100644
--- a/lisphs.cabal
+++ b/lisphs.cabal
@@ -13,4 +13,4 @@ executable            lisp
     ghc-options:      -Wall -O2
     build-depends:    base >= 4 && < 5,
                       containers, filepath, mtl, parsec, text
-    other-modules:    AST, Compiler, CompilerMacros, DString, Intermediate, Optimiser, Parser, VM
+    other-modules:    AST, Compiler, CompilerMacros, DString, Intermediate, Liveness, Optimiser, Parser, VM