diff options
| -rw-r--r-- | app/Main.hs | 2 | ||||
| -rw-r--r-- | bruijn.cabal | 1 | ||||
| -rw-r--r-- | src/Eval.hs | 3 | ||||
| -rw-r--r-- | src/Helper.hs | 44 | ||||
| -rw-r--r-- | src/Optimizer.hs | 159 | ||||
| -rw-r--r-- | src/Reducer/HigherOrder.hs | 13 | ||||
| -rw-r--r-- | src/Target.hs | 66 |
7 files changed, 189 insertions, 99 deletions
diff --git a/app/Main.hs b/app/Main.hs index bbaea6a..8731b7c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,7 +26,7 @@ args = <*> switch (long "verbose" <> short 'v' <> help "Increase verbosity") <*> strOption (long "target" <> short 't' <> metavar "TARGET" <> value "" <> help - "Optimize to target using BLoC and BLoCade" + "Compile to target using BLoC and BLoCade" ) <*> strOption ( long "reducer" diff --git a/bruijn.cabal b/bruijn.cabal index d255c78..8f768fb 100644 --- a/bruijn.cabal +++ b/bruijn.cabal @@ -58,6 +58,7 @@ library Reducer.HigherOrder Reducer.ION Reducer.RKNL + Target other-modules: Paths_bruijn hs-source-dirs: diff --git a/src/Eval.hs b/src/Eval.hs index 5091b49..d331e86 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -28,6 +28,7 @@ import System.Console.Haskeline import System.Directory import System.FilePath.Posix ( takeBaseName ) import System.Mem +import Target import Text.Megaparsec hiding ( State , try ) @@ -408,7 +409,7 @@ dumpFile conf wr conv = do case M.lookup entryFunction env of Nothing -> print $ ContextualError (UndefinedIdentifier entryFunction) (Context "" (_nicePath conf)) - Just EnvDef { _exp = e } -> optimizeToTarget conf e >>= wr . conv + Just EnvDef { _exp = e } -> toTarget conf e >>= wr . conv evalFileConf :: EvalConf -> IO () evalFileConf conf = do diff --git a/src/Helper.hs b/src/Helper.hs index a90ce94..3c1f2f2 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -184,23 +184,23 @@ data Instruction = Define Identifier Expression [Instruction] | Evaluate Express data ArgMode = ArgEval | ArgEvalBblc | ArgEvalBlc | ArgDumpBblc | ArgDumpBlc data Args = Args - { _argMode :: ArgMode - , _argNoTests :: Bool - , _argVerbose :: Bool - , _argOptimizeTarget :: String - , _argReducer :: String - , _argPath :: Maybe String + { _argMode :: ArgMode + , _argNoTests :: Bool + , _argVerbose :: Bool + , _argToTarget :: String + , _argReducer :: String + , _argPath :: Maybe String } data EvalConf = EvalConf - { _isRepl :: Bool - , _isVerbose :: Bool - , _evalTests :: Bool - , _nicePath :: String - , _path :: String - , _evalPaths :: [String] - , _optimizeTarget :: String - , _reducer :: String + { _isRepl :: Bool + , _isVerbose :: Bool + , _evalTests :: Bool + , _nicePath :: String + , _path :: String + , _evalPaths :: [String] + , _toTarget :: String + , _reducer :: String } newtype ExpFlags = ExpFlags @@ -225,14 +225,14 @@ newtype EnvCache = EnvCache type EvalState = S.State Environment argsToConf :: Args -> EvalConf -argsToConf args = EvalConf { _isRepl = isNothing $ _argPath args - , _isVerbose = _argVerbose args - , _evalTests = not $ _argNoTests args - , _path = path - , _nicePath = path - , _evalPaths = [] - , _optimizeTarget = _argOptimizeTarget args - , _reducer = _argReducer args +argsToConf args = EvalConf { _isRepl = isNothing $ _argPath args + , _isVerbose = _argVerbose args + , _evalTests = not $ _argNoTests args + , _path = path + , _nicePath = path + , _evalPaths = [] + , _toTarget = _argToTarget args + , _reducer = _argReducer args } where path = fromMaybe "" (_argPath args) 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 diff --git a/src/Reducer/HigherOrder.hs b/src/Reducer/HigherOrder.hs index 91378b7..1699c87 100644 --- a/src/Reducer/HigherOrder.hs +++ b/src/Reducer/HigherOrder.hs @@ -9,6 +9,11 @@ import Helper data HigherOrder = HigherOrderBruijn Int | HigherOrderAbstraction (HigherOrder -> HigherOrder) | HigherOrderApplication HigherOrder HigherOrder data NamedTerm = NamedVariable Int | NamedAbstraction Int NamedTerm | NamedApplication NamedTerm NamedTerm +(!?) :: [a] -> Int -> Maybe a +(!?) [] _ = Nothing +(!?) (x : _ ) 0 = Just x +(!?) (_ : xs) i = xs !? (i - 1) + app :: HigherOrder -> HigherOrder -> HigherOrder app (HigherOrderAbstraction f) = f app f = HigherOrderApplication f @@ -16,7 +21,9 @@ app f = HigherOrderApplication f eval :: Expression -> HigherOrder eval = go [] where - go env (Bruijn x ) = env !! x + go env (Bruijn x) = case env !? x of + Just v -> v + _ -> HigherOrderBruijn x go env (Abstraction e ) = HigherOrderAbstraction $ \x -> go (x : env) e go env (Application e1 e2) = app (go env e1) (go env e2) go _ _ = invalidProgramState @@ -32,7 +39,9 @@ toNamedTerm = go 0 resolveExpression :: NamedTerm -> Expression resolveExpression = resolve [] where - resolve vs (NamedVariable i ) = Bruijn $ vs !! i + resolve vs (NamedVariable i) = Bruijn $ case vs !? i of + Just v -> v + _ -> i resolve vs (NamedAbstraction v t) = Abstraction $ resolve (v : vs) t resolve vs (NamedApplication l r) = Application (resolve vs l) (resolve vs r) diff --git a/src/Target.hs b/src/Target.hs new file mode 100644 index 0000000..ea46161 --- /dev/null +++ b/src/Target.hs @@ -0,0 +1,66 @@ +-- MIT License, Copyright (c) 2024 Marvin Borner +-- BLoC format is used in combination with BLoCade the BLoC-aid. +module Target + ( toTarget + ) where + +import Binary +import Control.Exception +import qualified Data.BitString as Bit +import qualified Data.ByteString.Lazy.Char8 as Byte +import Helper +import System.IO +import System.Process + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +compile :: Expression -> String -> IO (Failable String) +compile 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 + putStrLn "sending binary" + hPutStrLn inH binary + hPutStr inH "\0" + hFlush inH + content <- hGetContents' outH + hClose outH + hClose inH + return $ case content of + "" -> Left $ OptimizerError "blocade returned empty string" + _ -> Right content + _ -> return $ Left $ OptimizerError "can't read from blocade" + +-- 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 + +toTarget :: EvalConf -> Expression -> IO Expression +toTarget conf e = do + let target = _toTarget conf + case target of + "" -> return e -- No target, fallback to unoptimized expression + _ -> do + maybeRes <- compile e target + case maybeRes of + Left err -> do + print err + return e -- Fallback to unoptimized expression + Right res -> return $ toExpression target res |