From 8601d4637314b1bc9ae0d5e5e5aa9d32e740935d Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Sat, 14 Dec 2019 23:01:36 +0100 Subject: Some small-function inlining --- AST.hs | 22 +++++++++ ASTOptimiser.hs | 145 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Main.hs | 35 ++++++++------ lisphs.cabal | 2 +- 4 files changed, 189 insertions(+), 15 deletions(-) create mode 100644 ASTOptimiser.hs diff --git a/AST.hs b/AST.hs index 2953227..dbe8e34 100644 --- a/AST.hs +++ b/AST.hs @@ -1,5 +1,8 @@ module AST where +import qualified Data.Map.Strict as Map +import Data.Maybe + import Data.List @@ -52,3 +55,22 @@ fromVNum _ = Nothing fromVString :: Value -> Maybe String fromVString (VString s) = Just s fromVString _ = Nothing + +replaceNames :: Map.Map Name Value -> Value -> Value +replaceNames mp origValue = + case origValue of + VList vs -> VList (map (replaceNames mp) vs) + VName n -> fromMaybe origValue (Map.lookup n mp) + VDefine n v -> VDefine n (replaceNames mp v) + VLambda as v -> VLambda as (replaceNames (foldr Map.delete mp as) v) + VLambdaRec rn as v -> VLambdaRec rn as (replaceNames (foldr Map.delete mp (rn : as)) v) + VLet [] v -> VLet [] (replaceNames mp v) + VLet ((n, d) : pairs) v -> + let VLet pairs' v' = replaceNames (Map.delete n mp) (VLet pairs v) + in VLet ((n, replaceNames mp d) : pairs') v' + VNum _ -> origValue + VString _ -> origValue + VQuoted _ -> origValue + VDeclare _ -> origValue + VBuiltin _ -> origValue + VEllipsis -> origValue diff --git a/ASTOptimiser.hs b/ASTOptimiser.hs new file mode 100644 index 0000000..d577f4c --- /dev/null +++ b/ASTOptimiser.hs @@ -0,0 +1,145 @@ +module ASTOptimiser ( + optimiseAST +) where + +import qualified Data.Map.Strict as Map +import Data.Maybe + +import Debug.Trace + +import AST + + +optimiseAST :: Program -> Program +optimiseAST = performInlining + + +performInlining :: Program -> Program +performInlining (Program values) = + Program (snd (mapState inline initState values)) + +data State + -- A variable maps to Nothing if its value is unknown + = State { sEnv :: [Map.Map Name (Maybe (Value, MetaInfo))] } + deriving (Show) + +newtype MetaInfo + = MetaInfo { miWeight :: Int } + deriving (Show) + +initState :: State +initState = State [Map.empty] + +-- Maximum weight of function to be considered for inlining +paramInlineMaxWeight :: Int +paramInlineMaxWeight = 10 -- TODO: very arbitrary + +-- Maximum weight of argument to function to be inlined; the larger this +-- is, the more work we allow to be duplicated over multiple usage sites in +-- the inlined function. +-- TODO: perhaps make this dependent on how many times the value is used in +-- the function to be inlined? +paramInlineArgMaxWeight :: Int +paramInlineArgMaxWeight = 1 + +withScope :: State -> (State -> (State, a)) -> (State, a) +withScope state f = + let (st', ret) = f (state { sEnv = Map.empty : sEnv state }) + in (st' { sEnv = tail (sEnv st') }, ret) + +defineName :: State -> Name -> Maybe Value -> State +defineName state name mvalue = + let desc = (\v -> (v, MetaInfo (computeWeight v))) <$> mvalue + env' = Map.insert name desc (head (sEnv state)) : tail (sEnv state) + in state { sEnv = env' } + +lookupName :: State -> Name -> Maybe (Value, MetaInfo) +lookupName state name = + case catMaybes (map (Map.lookup name) (sEnv state)) of + -- A found 'Nothing' should still result in Nothing being returned + (Just desc : _) -> Just desc + _ -> Nothing + +inline :: State -> Value -> (State, Value) +inline state origValue = + case origValue of + VDefine name value -> + let (state', value') = inline state value + in (defineName state' name (Just value'), VDefine name value') + VList [] -> (state, origValue) + VList (vhead:vtail) + | all ((<= paramInlineArgMaxWeight) . computeWeight) vtail -> + trace ("\x1B[1;31minline: argument weight test passed\x1B[0m: " ++ show origValue) $ + betaReduce . VList . (inlineReplace state vhead :) <$> + mapState inline state vtail + | otherwise -> + trace ("\x1B[1;31minline: argument weight test FAILED\x1B[0m: " ++ show origValue) $ + (state, betaReduce origValue) + VLambda as value -> + withScope state $ \state1 -> + let state1' = foldl (\s n -> defineName s n Nothing) state1 as + in VLambda as <$> inline state1' value + VLambdaRec r as value -> + withScope state $ \state1 -> + -- Also mark r as unknown, since we don't want to inline recursion + let state1' = foldl (\s n -> defineName s n Nothing) state1 (r : as) + in VLambdaRec r as <$> inline state1' value + VLet [] body -> + VLet [] <$> inline state body + VLet ((name, value) : pairs) body -> + withScope state $ \state1 -> + let (state1', value') = inline state1 value + state1'' = defineName state1' name (Just value') + (state1''', VLet pairs' body') = inline state1'' (VLet pairs body) + in (state1''', VLet ((name, value') : pairs') body') + VNum _ -> (state, origValue) + VString _ -> (state, origValue) + VName _ -> (state, origValue) + VQuoted _ -> (state, origValue) + VDeclare _ -> (state, origValue) + VBuiltin _ -> (state, origValue) + VEllipsis -> (state, origValue) + +inlineReplace :: State -> Value -> Value +inlineReplace state origValue@(VName name) = + case lookupName state name of + Just (value, meta) | miWeight meta <= paramInlineMaxWeight -> + trace ("\x1B[1;31minline: function weight small\x1B[0m (" ++ show (miWeight meta) ++ "): " ++ name) $ + value + Just (_, meta) -> + trace ("\x1B[1;31minline: function weight large\x1B[0m (" ++ show (miWeight meta) ++"): " ++ name) $ + origValue + Nothing -> + trace ("\x1B[1;31minline: variable not found\x1B[0m: " ++ name) $ + origValue +inlineReplace _ origValue = origValue + +betaReduce :: Value -> Value +betaReduce (VList (VLambda names body : values)) + | length values == length names = + THIS IS INCORRECT + -- TODO: THIS IS INCORRECT if the replaced value is a name that is + -- shadowed by another variable in the function body. + replaceNames (Map.fromList (zip names values)) body +betaReduce value = value + + +-- TODO: Very arbitrary; should perhaps be tuned +computeWeight :: Value -> Int +computeWeight (VList vs) = 1 + sum (map computeWeight vs) +computeWeight (VNum _) = 1 +computeWeight (VString _) = 1 +computeWeight (VName _) = 1 +computeWeight (VQuoted _) = 1 +computeWeight (VDeclare _) = 0 +computeWeight (VDefine _ v) = computeWeight v +computeWeight (VLambda _ v) = 2 + computeWeight v +computeWeight (VLambdaRec _ _ v) = 2 + computeWeight v +computeWeight (VLet ds v) = sum (map computeWeight (v : map snd ds)) +computeWeight (VBuiltin _) = 1 +computeWeight VEllipsis = 0 + +mapState :: (State -> a -> (State, b)) -> State -> [a] -> (State, [b]) +mapState _ state [] = (state, []) +mapState f state (x:xs) = let (state', y) = f state x + in fmap (y :) (mapState f state' xs) diff --git a/Main.hs b/Main.hs index 20f479b..4d3ef82 100644 --- a/Main.hs +++ b/Main.hs @@ -4,6 +4,7 @@ import Control.Monad import System.Environment import System.Exit +import ASTOptimiser import Compiler import CompilerMacros import Optimiser @@ -17,25 +18,27 @@ usage = do progname <- getProgName putStrLn $ "Usage: " ++ progname ++ " [-h] [-ast] [-ir] [filename.lisp]" putStrLn $ "When no filename is given, will read from stdin." - putStrLn $ " -h Show this help" - putStrLn $ " -ast Print AST after compiler macro's" - putStrLn $ " -irpre Print IR after optimisation, before stackification" - putStrLn $ " -ir Print IR after optimisation and stackification" + putStrLn $ " -h Show this help" + putStrLn $ " -ast Print AST after compiler macro's" + putStrLn $ " -astopt Print AST after compiler macro's" + putStrLn $ " -irpre Print IR after optimisation, before stackification" + putStrLn $ " -ir Print IR after optimisation and stackification" -data Options = Options { optAST :: Bool, optIRPre :: Bool, optIR :: Bool, optFiles :: [FilePath] } +data Options = Options { optAST :: Bool, optASTOpt :: Bool, optIRPre :: Bool, optIR :: Bool, optFiles :: [FilePath] } parseOptions :: Options -> [String] -> IO Options -parseOptions o [] = return o -parseOptions _ ("-h":_) = usage >> exitSuccess -parseOptions o ("-ast":as) = parseOptions (o { optAST = True }) as -parseOptions o ("-irpre":as) = parseOptions (o { optIRPre = True }) as -parseOptions o ("-ir":as) = parseOptions (o { optIR = True }) as -parseOptions _ (('-':a):_) = putStrLn ("Unknown option '" ++ a ++ "'") >> usage >> exitFailure -parseOptions o (f:as) = parseOptions (o { optFiles = optFiles o ++ [f] }) as +parseOptions o [] = return o +parseOptions _ ("-h":_) = usage >> exitSuccess +parseOptions o ("-ast":as) = parseOptions (o { optAST = True }) as +parseOptions o ("-astopt":as) = parseOptions (o { optASTOpt = True }) as +parseOptions o ("-irpre":as) = parseOptions (o { optIRPre = True }) as +parseOptions o ("-ir":as) = parseOptions (o { optIR = True }) as +parseOptions _ (('-':a):_) = putStrLn ("Unknown option '" ++ a ++ "'") >> usage >> exitFailure +parseOptions o (f:as) = parseOptions (o { optFiles = optFiles o ++ [f] }) as main :: IO () main = do - opts <- getArgs >>= parseOptions (Options False False False []) + opts <- getArgs >>= parseOptions (Options False False False False []) mfname <- case optFiles opts of [] -> return Nothing [fname] -> return (Just fname) @@ -47,7 +50,11 @@ main = do let prog' = compilerMacros prog when (optAST opts) $ print prog' - irprog <- either die return (compileProgram prog') + let prog'' = optimiseAST prog' + when (optASTOpt opts) $ print prog'' + + irprog <- either die return (compileProgram prog'') + -- print irprog let opt = optimise irprog when (optIRPre opts) $ print opt diff --git a/lisphs.cabal b/lisphs.cabal index 98d74c8..facdcef 100644 --- a/lisphs.cabal +++ b/lisphs.cabal @@ -18,4 +18,4 @@ executable lisp mtl >= 2.2.2, parsec >= 3.1.14.0, text >= 1.2.4.0 - other-modules: AST, Compiler, CompilerMacros, DString, Intermediate, Liveness, Optimiser, Parser, Stackify, Util, VM + other-modules: AST, ASTOptimiser, Compiler, CompilerMacros, DString, Intermediate, Liveness, Optimiser, Parser, Stackify, Util, VM -- cgit v1.2.3