diff --git a/Kroha.cabal b/Kroha.cabal index 1e530f1..1f981cd 100644 --- a/Kroha.cabal +++ b/Kroha.cabal @@ -27,6 +27,7 @@ executable Kroha other-modules: Kroha Kroha.Ast + Kroha.Backends.Nasm Kroha.Instructions Kroha.Parser Kroha.Scope diff --git a/src/Kroha.hs b/src/Kroha.hs index 97272d3..848ff83 100644 --- a/src/Kroha.hs +++ b/src/Kroha.hs @@ -10,14 +10,11 @@ import Kroha.Scope (linkProgram, linksTree) import Kroha.Stack (stack) import Kroha.Types (resolve, typeCasts) import Kroha.Instructions(instructions) +import Kroha.Backends.Nasm (runNasm) kroha :: String -> Either String String -kroha src = fmap (concat . (\x -> do - (section, _, instructions) <- x - let showed = drawTree $ fmap show instructions - return $ section ++ ":\n" ++ showed) - ) compile +kroha src = compile where compile = do program <- first id $ parse src scopes <- first show $ linkProgram program @@ -25,4 +22,4 @@ kroha src = fmap (concat . (\x -> do types <- first show $ resolve 16 . typeCasts $ mzip (linksTree program) scopes let stackRanges = stack 16 program let prepared = instructions stackRanges scopes program - return prepared + return (runNasm prepared) diff --git a/src/Kroha/Backends/Nasm.hs b/src/Kroha/Backends/Nasm.hs new file mode 100644 index 0000000..d97ae86 --- /dev/null +++ b/src/Kroha/Backends/Nasm.hs @@ -0,0 +1,67 @@ +module Kroha.Backends.Nasm where + +import Data.Tree +import Data.List (groupBy, intercalate) +import Control.Monad.Fix (fix) +import Control.Monad (join) +import Data.List.Extra (groupSort) + +import Kroha.Ast +import Kroha.Instructions hiding (target) + +bytes :: Int -> Int +bytes x = ceiling ((toEnum x) / 8) + +label (CommonLabel l) = l +label (BeginLabel l) = l ++ "_begin" +label (EndLabel l) = l ++ "_end" + +target :: Target -> String +target (LiteralTarget (IntegerLiteral num)) = show num +target (StackTarget (offset, _)) = "[bp - " ++ show (bytes offset) ++ "]" +target (RegisterTarget reg) = reg +target (VariableTarget name) = '[' : name ++ "]" + +jump :: Comparator -> String +jump Equals = "je" +jump NotEquals = "jne" +jump Less = "jl" +jump Greater = "jg" + +nasm16I (Body _ i) = [] +nasm16I (Assembly asm) = [asm] +nasm16I (Label lbl) = [label lbl ++ ":"] +nasm16I (Move l r) = ["mov " ++ target l ++ ", " ++ target r] +nasm16I (CallI l args) = (fmap (((++) "push ") . target) . 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 l ++ ", " ++ target r, jump c ++ " " ++ label lbl] + +nasmBodyWrap body = body + +makeFix :: Tree [Instruction] -> [String] +makeFix (Node i c) = join . fmap asmFix $ i + where asmFix (Body _ i) = fmap ((++) indent) . bodyWrap $ makeFix (c !! i) + asmFix i = asm i + (asm, indent, bodyWrap) = (nasm16I, " ", id) + +nasmSection :: Section -> [[String]] -> String +nasmSection section declarations = header <> body <> "\n\n" + where header = "section ." ++ section ++ "\n" + body = intercalate "\n" . fmap (intercalate "\n") $ declarations + +nasmType :: TypeName -> String +nasmType (TypeName "int8" ) = "db" +nasmType (TypeName "int16") = "dw" + +nasmDeclaration :: Tree [Instruction] -> Declaration -> [String] +nasmDeclaration t (Frame l _) = [l ++ ":"] ++ makeFix t ++ ["leave", "ret"] +nasmDeclaration _ (GlobalVariable n t (IntegerLiteral l)) = [n ++ ": " ++ nasmType t ++ " " ++ show l] +nasmDeclaration _ (ConstantVariable n t (IntegerLiteral l)) = [n ++ ": " ++ nasmType t ++ " " ++ show l] +nasmDeclaration _ (ManualFrame l c) = [l ++ ":", c] +nasmDeclaration _ (ManualVariable v _ c) = [v ++ ": " ++ c] + + +runNasm :: [(Section, Declaration, Tree [Instruction])] -> String +runNasm = join . map mapper + where mapper (s, d, t) = nasmSection s [nasmDeclaration t d] +