summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2019-12-14 23:01:36 +0100
committertomsmeding <tom.smeding@gmail.com>2019-12-14 23:23:11 +0100
commit8601d4637314b1bc9ae0d5e5e5aa9d32e740935d (patch)
tree6e7de0c9e2170fc81c18b1f0fd3bd9c604139b79
parent638181c4f19f38898abf5ff41b891eaa62ea9325 (diff)
Some small-function inlininginlining
-rw-r--r--AST.hs22
-rw-r--r--ASTOptimiser.hs145
-rw-r--r--Main.hs35
-rw-r--r--lisphs.cabal2
4 files changed, 189 insertions, 15 deletions
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