From 5329eea77cb699dbb4060b1162c90d86078faf4e Mon Sep 17 00:00:00 2001 From: Maxim Vorotynsky Date: Mon, 27 Jun 2022 12:09:20 +0000 Subject: [PATCH 1/5] feat(nasm): add registers --- Kroha.cabal | 2 +- package.yaml | 2 +- src/Kroha/Backends/Nasm.hs | 16 +++++++++++++--- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/Kroha.cabal b/Kroha.cabal index 0fcf846..8eefa3f 100644 --- a/Kroha.cabal +++ b/Kroha.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: Kroha -version: 1.3.2.0 +version: 1.3.3.0 description: Please see the README on GitHub at homepage: https://github.com/vorotynsky/Kroha#readme bug-reports: https://github.com/vorotynsky/Kroha/issues diff --git a/package.yaml b/package.yaml index 6911146..c978079 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: Kroha -version: 1.3.2.0 +version: 1.3.3.0 github: "vorotynsky/Kroha" license: GPL-3 author: "Vorotynsky Maxim" diff --git a/src/Kroha/Backends/Nasm.hs b/src/Kroha/Backends/Nasm.hs index 6d82cbe..13b71d4 100644 --- a/src/Kroha/Backends/Nasm.hs +++ b/src/Kroha/Backends/Nasm.hs @@ -69,11 +69,21 @@ litType :: Literal -> Result TypeId litType l@(IntegerLiteral x) | x >= 0 && x < 65536 = Right 2 | otherwise = Left (BackendError (show l ++ " is not in [0; 65536)")) +regsBase16 = zip ((\x -> fmap ((:) x . pure) "lhx") =<< "abcd") (cycle [0, 0, 1]) +regsBase32 = zip ((fmap (\x -> 'e':x:"x")) "abcd") (cycle [3]) +regsBase64 = zip ((fmap (\x -> 'r':x:"x")) "abcd") (cycle [4]) + +regsSpec r = zip ['r':r, 'e':r, r, r++"l"] [4,3,1,0] +regsInfo = concatMap regsSpec ["sp", "bp", "si", "di"] + +regsRf r = zip [r, r++"d", r++"w", r++"b"] [4, 3, 1, 0] +regsR = concatMap regsRf $ fmap ((:) 'r' . show) [8..15] + nasmTypes = TypeConfig - { types = (fmap . first) TypeName [("int8", 8), ("int16", 16), ("+literal+", 16)] + { types = (fmap . first) TypeName [("int8", 8), ("int16", 16), ("+literal+", 16), ("int32", 32), ("int64", 64)] , pointerType = 1 - , registers = zip ((\x -> fmap ((:) x . pure) "lhx") =<< "abcd") (cycle [0, 0, 1]) - , typeCasts = buildG (0, 3) [(0, 2), (1, 2)] + , registers = regsBase16 ++ regsBase32 ++ regsBase64 ++ regsInfo ++ regsR + , typeCasts = buildG (0, 5) [(0, 2), (1, 2), (3, 2), (4, 2)] , literalType = litType } size2type size = fromJust . lookup size . fmap (\(a, b) -> (b, a)) $ types nasmTypes From d490416ade5297c837c81aa840fb6075f5b7ab47 Mon Sep 17 00:00:00 2001 From: Maxim Vorotynsky Date: Mon, 27 Jun 2022 16:17:28 +0000 Subject: [PATCH 2/5] chore: extract main to app --- Kroha.cabal | 2 +- {src => app}/Main.hs | 0 package.yaml | 4 +++- 3 files changed, 4 insertions(+), 2 deletions(-) rename {src => app}/Main.hs (100%) diff --git a/Kroha.cabal b/Kroha.cabal index 8eefa3f..09a2985 100644 --- a/Kroha.cabal +++ b/Kroha.cabal @@ -42,6 +42,7 @@ executable Kroha Kroha.Types Paths_Kroha hs-source-dirs: + app src ghc-options: -XTupleSections -XDeriveTraversable -XRankNTypes -XImplicitParams -XTypeFamilies build-depends: @@ -73,7 +74,6 @@ test-suite Kroha-tests Kroha.Syntax.Statements Kroha.Syntax.Syntax Kroha.Types - Main Paths_Kroha hs-source-dirs: test diff --git a/src/Main.hs b/app/Main.hs similarity index 100% rename from src/Main.hs rename to app/Main.hs diff --git a/package.yaml b/package.yaml index c978079..ed6c9c0 100644 --- a/package.yaml +++ b/package.yaml @@ -35,7 +35,9 @@ dependencies: executables: Kroha: - source-dirs: src + source-dirs: + - app + - src main: Main.hs tests: From 2764e2362c29fc2d3e5afa9f611479adf1bdfd11 Mon Sep 17 00:00:00 2001 From: Maxim Vorotynsky Date: Mon, 27 Jun 2022 19:58:50 +0000 Subject: [PATCH 3/5] refactor: applicative cli arguments --- Kroha.cabal | 3 +++ app/Args.hs | 20 ++++++++++++++++++++ app/Main.hs | 7 ++++--- package.yaml | 1 + 4 files changed, 28 insertions(+), 3 deletions(-) create mode 100644 app/Args.hs diff --git a/Kroha.cabal b/Kroha.cabal index 09a2985..0c5336d 100644 --- a/Kroha.cabal +++ b/Kroha.cabal @@ -25,6 +25,7 @@ source-repository head executable Kroha main-is: Main.hs other-modules: + Args Kroha Kroha.Backends.Common Kroha.Backends.Nasm @@ -52,6 +53,7 @@ executable Kroha , extra >=1.0 && <1.8 , hashmap >=1.0.0 && <1.4 , megaparsec >=8.0.0 && <=10.0.0 + , optparse-applicative >=0.17.0.0 && <0.18.0.0 default-language: Haskell2010 test-suite Kroha-tests @@ -88,4 +90,5 @@ test-suite Kroha-tests , extra >=1.0 && <1.8 , hashmap >=1.0.0 && <1.4 , megaparsec >=8.0.0 && <=10.0.0 + , optparse-applicative >=0.17.0.0 && <0.18.0.0 default-language: Haskell2010 diff --git a/app/Args.hs b/app/Args.hs new file mode 100644 index 0000000..f4119a1 --- /dev/null +++ b/app/Args.hs @@ -0,0 +1,20 @@ +module Args where + +import Options.Applicative + +import Kroha.Backends.Common +import Kroha.Backends.Nasm + +data Options = Options + { files :: [FilePath] } + +optionsParser :: Parser Options +optionsParser = Options + <$> some (argument str (metavar "FILES...")) + +readOptions :: IO Options +readOptions = execParser opts + where opts = info (optionsParser <**> helper) + ( fullDesc + <> progDesc "Compiles programs written in Kroha" + <> header "Kroha language" ) diff --git a/app/Main.hs b/app/Main.hs index 34e935c..6ae7dea 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,6 +5,7 @@ import Data.List (intercalate) import System.Environment (getArgs) import System.Exit (exitFailure) +import Args import Kroha parse :: [(String, String)] -> IO String @@ -16,8 +17,8 @@ parse contents = do main :: IO () main = do - args <- getArgs - contents <- mapM readFile args - parsed <- parse (zip args contents) + options <- readOptions + contents <- mapM readFile (files options) + parsed <- parse (zip (files options) contents) putStrLn "; build with Kroha\n; see: https://github.com/vorotynsky/Kroha \n" putStrLn parsed diff --git a/package.yaml b/package.yaml index ed6c9c0..8393bab 100644 --- a/package.yaml +++ b/package.yaml @@ -32,6 +32,7 @@ dependencies: - extra >= 1.0 && < 1.8 - comonad >= 5 && < 5.1 - hashmap >= 1.0.0 && < 1.4 +- optparse-applicative >= 0.17.0.0 && < 0.18.0.0 executables: Kroha: From bc93517c245d7ae18acf0f96ab399a872a19ab22 Mon Sep 17 00:00:00 2001 From: Maxim Vorotynsky Date: Wed, 29 Jun 2022 09:57:11 +0000 Subject: [PATCH 4/5] feat(app): backend selection --- app/Args.hs | 17 +++++++++++++++-- app/Main.hs | 15 ++++++++------- src/Kroha.hs | 27 +++++++++++++-------------- src/Kroha/Backends/Nasm.hs | 29 +++++++++++++++++------------ test/Case.hs | 3 ++- 5 files changed, 55 insertions(+), 36 deletions(-) diff --git a/app/Args.hs b/app/Args.hs index f4119a1..82275b0 100644 --- a/app/Args.hs +++ b/app/Args.hs @@ -6,11 +6,24 @@ import Kroha.Backends.Common import Kroha.Backends.Nasm data Options = Options - { files :: [FilePath] } + { backend :: Backend + , files :: [FilePath] } + +backends = [("nasm16", nasm 16), ("nasm32", nasm 32), ("nasm64", nasm 64)] + +toRight _ (Just x) = Right x +toRight x Nothing = Left x + +backendParser = option (eitherReader (\x -> toRight "Unknown backend" $ lookup x backends)) + ( long "assembly" + <> metavar "BACKEND" + <> help "Specify backend" + <> value (nasm 64) ) optionsParser :: Parser Options optionsParser = Options - <$> some (argument str (metavar "FILES...")) + <$> backendParser + <*> some (argument str (metavar "FILES...")) readOptions :: IO Options readOptions = execParser opts diff --git a/app/Main.hs b/app/Main.hs index 6ae7dea..18a058b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,18 +7,19 @@ import System.Exit (exitFailure) import Args import Kroha +import Kroha.Backends.Common -parse :: [(String, String)] -> IO String -parse contents = do - let (errors, results) = partitionEithers . fmap (uncurry kroha) $ contents - errors <- traverse putStrLn errors - if null errors then pure () else exitFailure - return $ intercalate "\n\n" results +parse :: Backend -> [(String, String)] -> IO String +parse backend contents = + do let (errors, results) = partitionEithers . fmap (uncurry $ kroha backend) $ contents + errors <- traverse putStrLn errors + if null errors then pure () else exitFailure + return $ intercalate "\n\n" results main :: IO () main = do options <- readOptions contents <- mapM readFile (files options) - parsed <- parse (zip (files options) contents) + parsed <- parse (backend options) (zip (files options) contents) putStrLn "; build with Kroha\n; see: https://github.com/vorotynsky/Kroha \n" putStrLn parsed diff --git a/src/Kroha.hs b/src/Kroha.hs index 1cd6f00..bdbb7cd 100644 --- a/src/Kroha.hs +++ b/src/Kroha.hs @@ -4,8 +4,7 @@ import Data.Bifunctor (first) import Data.Foldable (toList) import Data.HashMap (fromList, lookup) -import Kroha.Backends.Common (runBackend, typeConfig) -import Kroha.Backends.Nasm (nasm) +import Kroha.Backends.Common (Backend, runBackend, typeConfig) import Kroha.Errors (Result, showErrors) import Kroha.Instructions (instructions) import Kroha.Parser.Declarations (parseProgram) @@ -15,20 +14,20 @@ import Kroha.Syntax.Declarations (NodeId, Program, genId, pzip, pzip3) import Kroha.Types (resolve, typeCastsTree) -compile :: Program NodeId -> Result String -compile program = do - scopes <- linkProgram program - let tc = typeConfig nasm - casts <- typeCastsTree tc scopes - _ <- resolve tc (pzip program casts) - let stackRanges = stack tc program - let prepared = instructions (pzip3 stackRanges (fmap snd scopes) program) - return (runBackend nasm prepared) +compile :: Backend -> Program NodeId -> Result String +compile backend program = + do scopes <- linkProgram program + let tc = typeConfig backend + casts <- typeCastsTree tc scopes + _ <- resolve tc (pzip program casts) + let stackRanges = stack tc program + let prepared = instructions (pzip3 stackRanges (fmap snd scopes) program) + return (runBackend backend prepared) -kroha :: String -> String -> Either String String -kroha name src = +kroha :: Backend -> String -> String -> Either String String +kroha backend name src = case parseProgram name src of Left err -> Left err - Right parsed -> first (showErrors (`Data.HashMap.lookup` rangeTable)) $ compile prog + Right parsed -> first (showErrors (`Data.HashMap.lookup` rangeTable)) $ compile backend prog where prog = genId parsed rangeTable = fromList $ toList $ pzip prog parsed diff --git a/src/Kroha/Backends/Nasm.hs b/src/Kroha/Backends/Nasm.hs index 13b71d4..fd4486b 100644 --- a/src/Kroha/Backends/Nasm.hs +++ b/src/Kroha/Backends/Nasm.hs @@ -31,7 +31,7 @@ nasmTypeG , nasmTypeL, untyped :: TypeName -> String where append x s = s ++ x -target :: (TypeName -> String) -> Target -> String +target :: (?bp :: RegisterName) => (TypeName -> String) -> Target -> String target tf (LiteralTarget (IntegerLiteral num)) = show num target tf (StackTarget (offset, s)) = (tf . size2type) s ++ "[bp - " ++ show (bytes offset) ++ "]" target tf (RegisterTarget reg) = reg @@ -43,15 +43,15 @@ jump NotEquals = "jne" jump Less = "jl" jump Greater = "jg" -nasm16I :: Instruction -> [String] -nasm16I (Body _ _) = [] -nasm16I (Assembly asm) = [asm] -nasm16I (Label lbl) = [label lbl ++ ":"] -nasm16I (Move l r) = ["mov " ++ target nasmTypeL l ++ ", " ++ target untyped r] -nasm16I (CallI l args) = (fmap (("push " ++) . target nasmTypeL) . reverse $ args) ++ ["call " ++ label l, "add sp, " ++ show ((length args) * 2)] -nasm16I (Jump l Nothing) = ["jmp " ++ label l] -nasm16I (Jump lbl (Just (l, c, r))) = ["cmp " ++ target nasmTypeL l ++ ", " ++ target untyped r, jump c ++ " " ++ label lbl] -nasm16I (StackAlloc s) = ["enter " ++ show (bytes s) ++ ", 0"] +nasmI :: (?sp :: RegisterName, ?bp :: RegisterName) => Instruction -> [String] +nasmI (Body _ _) = [] +nasmI (Assembly asm) = [asm] +nasmI (Label lbl) = [label lbl ++ ":"] +nasmI (Move l r) = ["mov " ++ target nasmTypeL l ++ ", " ++ target untyped r] +nasmI (CallI l args) = (fmap (("push " ++) . target nasmTypeL) . reverse $ args) ++ ["call " ++ label l, "add " ++ ?sp ++ ", " ++ show ((length args) * 2)] +nasmI (Jump l Nothing) = ["jmp " ++ label l] +nasmI (Jump lbl (Just (l, c, r))) = ["cmp " ++ target nasmTypeL l ++ ", " ++ target untyped r, jump c ++ " " ++ label lbl] +nasmI (StackAlloc s) = ["enter " ++ show (bytes s) ++ ", 0"] nasmSection :: Section -> String -> String nasmSection section body = header <> body <> "\n\n" @@ -88,8 +88,13 @@ nasmTypes = TypeConfig size2type size = fromJust . lookup size . fmap (\(a, b) -> (b, a)) $ types nasmTypes -nasm = Backend - { instruction = nasm16I +nasmInstruction 16 = let ?bp = "bp" in let ?sp = "sp" in nasmI +nasmInstruction 32 = let ?bp = "ebp" in let ?sp = "esp" in nasmI +nasmInstruction 64 = let ?bp = "rbp" in let ?sp = "rsp" in nasmI + + +nasm arch = Backend + { instruction = nasmInstruction arch , bodyWrap = id , indent = " " , section = nasmSection diff --git a/test/Case.hs b/test/Case.hs index d4e6ef4..ad79ea7 100644 --- a/test/Case.hs +++ b/test/Case.hs @@ -9,6 +9,7 @@ import Data.List.Extra (trim) import Data.Maybe (fromJust, isJust) import Data.Tuple.Extra (both) import Kroha (kroha) +import Kroha.Backends.Nasm (nasm) import Test.HUnit type TestName = String @@ -53,7 +54,7 @@ testCase :: TestName -> Test testCase name = TestCase $ do text <- readFile $ toFile ".test.kr" name let (program, expected) = both trim $ extract text - let actual = trim . fromEither $ kroha name program + let actual = trim . fromEither $ kroha (nasm 16) name program assertProgram name expected actual where extract text = fromJust . join . find isJust . fmap (`splitBy` text) $ ["nasm", "errors"] From af229fe99e4335c9e4504fd79ef82eb5d43804e0 Mon Sep 17 00:00:00 2001 From: Maxim Vorotynsky Date: Wed, 29 Jun 2022 19:36:17 +0000 Subject: [PATCH 5/5] feat: output to file --- app/Args.hs | 15 ++++++++++++++- app/Main.hs | 14 +++++++++----- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/app/Args.hs b/app/Args.hs index 82275b0..941451e 100644 --- a/app/Args.hs +++ b/app/Args.hs @@ -5,9 +5,14 @@ import Options.Applicative import Kroha.Backends.Common import Kroha.Backends.Nasm +data Output + = StdOut + | File FilePath + data Options = Options { backend :: Backend - , files :: [FilePath] } + , files :: [FilePath] + , output :: Output } backends = [("nasm16", nasm 16), ("nasm32", nasm 32), ("nasm64", nasm 64)] @@ -20,10 +25,18 @@ backendParser = option (eitherReader (\x -> toRight "Unknown backend" $ lookup x <> help "Specify backend" <> value (nasm 64) ) +outputParser :: Parser FilePath +outputParser = option str + ( long "output" + <> short 'o' + <> metavar "FILE" + <> help "Place the output into ") + optionsParser :: Parser Options optionsParser = Options <$> backendParser <*> some (argument str (metavar "FILES...")) + <*> (flag' StdOut (long "stdout") <|> fmap File outputParser <|> pure (File "./kroha.asm")) readOptions :: IO Options readOptions = execParser opts diff --git a/app/Main.hs b/app/Main.hs index 18a058b..7c203ea 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,8 +9,12 @@ import Args import Kroha import Kroha.Backends.Common -parse :: Backend -> [(String, String)] -> IO String -parse backend contents = +write :: Output -> String -> IO () +write (StdOut ) content = putStrLn content +write (File path) content = writeFile path content + +process :: Backend -> [(String, String)] -> IO String +process backend contents = do let (errors, results) = partitionEithers . fmap (uncurry $ kroha backend) $ contents errors <- traverse putStrLn errors if null errors then pure () else exitFailure @@ -20,6 +24,6 @@ main :: IO () main = do options <- readOptions contents <- mapM readFile (files options) - parsed <- parse (backend options) (zip (files options) contents) - putStrLn "; build with Kroha\n; see: https://github.com/vorotynsky/Kroha \n" - putStrLn parsed + parsed <- process (backend options) (zip (files options) contents) + let result = "; build with Kroha\n; see: https://github.com/vorotynsky/Kroha \n\n" ++ parsed + write (output options) result