From eff903fc61b060b6333cb60bfced95e44da000ba Mon Sep 17 00:00:00 2001 From: Marvin Borner Date: Sat, 2 Mar 2024 11:21:44 +0100 Subject: Started non-outsourced optimizer --- src/Optimizer.hs | 159 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 86 insertions(+), 73 deletions(-) (limited to 'src/Optimizer.hs') diff --git a/src/Optimizer.hs b/src/Optimizer.hs index 260c149..b458eb3 100644 --- a/src/Optimizer.hs +++ b/src/Optimizer.hs @@ -1,86 +1,99 @@ -- MIT License, Copyright (c) 2024 Marvin Borner --- Ultimately, the optimizer should not be outsourced but handled directly in Haskell. --- For now, my BLoC format is used in combination with BLoCade the BLoC-aid. - module Optimizer - ( optimizeToTarget - , optimizedReduce + ( optimizedReduce ) where -import Binary -import Control.Exception -import qualified Data.BitString as Bit -import qualified Data.ByteString.Lazy.Char8 as Byte +import qualified Data.Map as M import Helper import Reducer -import System.IO -import System.Process -tryIO :: IO a -> IO (Either IOException a) -tryIO = try +data Direction = L | D | R + deriving (Show, Eq) +type Path = [Direction] -- will be reversed +type Tree = M.Map Expression [Path] + +resolvePath :: Expression -> Path -> Maybe Expression +resolvePath e [] = Just e +resolvePath (Application l _) (L : p) = resolvePath l p +resolvePath (Application _ r) (R : p) = resolvePath r p +resolvePath (Abstraction t ) (D : p) = resolvePath t p +resolvePath _ _ = Nothing + +constructTree :: Expression -> Tree +constructTree = go [] M.empty + where + go p m e@(Application l r) = do + let m' = go (L : p) m l + let m'' = go (R : p) m' r + M.insertWith (++) e [p] m'' + go p m e@(Abstraction t) = do + let m' = go (D : p) m t + M.insertWith (++) e [p] m' + go p m e@(Bruijn i) = M.insertWith (++) e [p] m + go _ _ _ = invalidProgramState + +isClosed :: Expression -> Bool +isClosed = go 0 + where + go i (Bruijn j ) = i > j + go i (Application l r) = go i l && go i r + go i (Abstraction t ) = go (i + 1) t + go _ _ = True + +-- (kinda arbitrary) +isGood :: Expression -> Bool +isGood = go 10 + where + go 0 _ = True + go i (Application (Abstraction l) r) = go (i - 2) l || go (i - 2) r + go i (Application l r) = go (i - 1) l || go (i - 1) r + go i (Abstraction t ) = go (i - 1) t + go _ _ = False --- toBloc :: Expression -> IO (Failable Handle) --- toBloc e = do --- let binary = toBinary e --- tryBloc <- tryIO $ createProcess (proc "bloc" ["-i", "-", "--from-blc"]) --- { std_in = CreatePipe --- , std_out = CreatePipe --- } --- let bloc = case tryBloc of --- Right (Just i, Just o, _, _) -> Just (i, o) --- _ -> Nothing --- case bloc of --- Just (inH, outH) -> do --- hPutStrLn inH binary --- return $ Right outH --- Nothing -> return $ Left $ OptimizerError "can't read/write to bloc" +-- if expression has a parent that appears more often +preferParent :: Expression -> [Path] -> Tree -> Bool +preferParent e ps t = do + let len = length ps + any + (\p -> any + (\p' -> case resolvePath e p' of + Just r -> length (M.findWithDefault [] r t) >= len + Nothing -> False + ) + [R : p, D : p, L : p] + ) + ps -toTarget :: Expression -> String -> IO (Failable String) -toTarget e target = do - res <- tryIO $ createProcess_ - "" - (shell $ "bloc -v -i - --from-blc | blocade -v -i - -t " <> target) - { std_in = CreatePipe - , std_out = CreatePipe - } - case res of - Right (Just inH, Just outH, _, _) -> do - let binary = toBinary e - hSetBuffering inH NoBuffering - hSetBuffering outH NoBuffering - hSetBinaryMode outH True - hIsOpen inH >>= print - hIsWritable inH >>= print - hPutStrLn inH binary - hFlush inH - content <- hGetContents' outH - return $ case content of - "" -> Left $ OptimizerError "blocade returned empty string" - _ -> Right content - _ -> return $ Left $ OptimizerError "can't read from blocade" +commonPath :: Path -> Path -> Path +commonPath p1 p2 = go (reverse p1) (reverse p2) + where + go _ [] = [] + go [] _ = [] + go (x : xs) (y : ys) | x == y = x : go xs ys + | otherwise = [] --- TODO: add more targets (including other PL compilation) -toExpression :: String -> String -> Expression -toExpression "blc" = fromBinary -toExpression "unblc" = fromBinary -toExpression "bblc" = - fromBinary . fromBitString . Bit.bitStringLazy . Byte.pack -toExpression "unbblc" = - fromBinary . fromBitString . Bit.bitStringLazy . Byte.pack -toExpression _ = invalidProgramState +inject :: Expression -> Path -> Expression -> [Path] -> Expression +inject i [] e ps = Application (Abstraction (subst ? (incv e))) i +inject i [L : p] (Application l r) ps = Application (inject i p l ps) r +inject i [R : p] (Application l r) ps = Application l (inject i p r ps) +inject i [D : p] (Abstraction t ) ps = Abstraction (inject i p t ps) +inject _ _ _ _ = invalidProgramState -optimizeToTarget :: EvalConf -> Expression -> IO Expression -optimizeToTarget conf e = do - let target = _optimizeTarget conf - case target of - "" -> return e -- No target, fallback to unoptimized expression - _ -> do - maybeRes <- toTarget e target - case maybeRes of - Left err -> do - print err - return e -- Fallback to unoptimized expression - Right res -> return $ toExpression target res +optimize :: Expression -> IO Expression +optimize e = do + let tree = constructTree e + let filtered = + M.filterWithKey (\k ps -> isClosed k && isGood k && length ps > 1) tree + let filtered' = + M.filterWithKey (\k ps -> not $ preferParent e ps filtered) filtered + -- TODO: simulated annealing just before injection + print $ (\(k, p) -> foldl1 commonPath p) <$> M.toList filtered' + -- inject t (take (length commonPath) ps) e ps -- oder so + pure e +-- optimize e = constructTree e +-- TODO: enable optimizer with flag optimizedReduce :: EvalConf -> Expression -> IO Expression -optimizedReduce conf e = optimizeToTarget conf e >>= reduce conf +optimizedReduce conf e = do + optimize e + reduce conf e -- cgit v1.2.3