From ecd369e0fbdc71c74ccd327899f8915045a01630 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Fri, 29 Nov 2019 21:06:54 +0100 Subject: WIP liveness analysis implementation --- Intermediate.hs | 11 +++++++++++ Liveness.hs | 39 +++++++++++++++++++++++++++++++++++++++ Main.hs | 28 ++++++++++++++++++++++++++++ Optimiser.hs | 11 ----------- lisphs.cabal | 2 +- 5 files changed, 79 insertions(+), 12 deletions(-) create mode 100644 Liveness.hs 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 -- cgit v1.2.3-54-g00ecf