From 8fe1fc0c2b0b10f64c43498481e738221fe03bb3 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Mon, 12 Sep 2022 20:16:42 +0100 Subject: Track local variables, WIP code gen --- src/Micro/Asm/Sdcc.hs | 100 +++++++++++++++++++++++++++++--------------------- src/Micro/Ast.hs | 4 +- src/Micro/Compiler.hs | 12 +++--- src/Micro/Parser.hs | 26 ++++++------- test/Language.hs | 14 +++---- 5 files changed, 86 insertions(+), 70 deletions(-) diff --git a/src/Micro/Asm/Sdcc.hs b/src/Micro/Asm/Sdcc.hs index 1fb05dd..a645129 100644 --- a/src/Micro/Asm/Sdcc.hs +++ b/src/Micro/Asm/Sdcc.hs @@ -1,16 +1,13 @@ module Micro.Asm.Sdcc where -import qualified Data.Map as Map import qualified Micro.Ast as A -import Micro.Env (Sym (..), SymMap) -toIdent :: A.Ident -> Bool -> String -toIdent id False = "_" ++ id -toIdent id True = id +toIdent :: A.Ident -> String +toIdent id = "_" ++ id toLabel :: A.Ident -> Bool -> String -toLabel id False = toIdent id False ++ "::" -toLabel id True = id ++ ":" +toLabel id False = toIdent id ++ "::" +toLabel id True = toIdent id ++ ":" toData :: A.Type -> String toData (A.Type t) @@ -19,48 +16,67 @@ toData (A.Type t) | otherwise = ".ds 2" toData (A.FuncType _ _) = ".ds 2" -toInit :: A.Type -> String -toInit (A.Type t) - | t == "bool" || t == "u8" || t == "s8" = ".db" - | t == "u16" || t == "s16" = ".dw" - | otherwise = ".dw" -toInit (A.FuncType _ _) = ".dw" - -onlyData :: SymMap -> [Sym] -onlyData symm = - filter (\sym -> symRef sym) $ - Map.elems symm +toInit :: A.Type -> A.Expr -> String +toInit (A.Type t) (A.Num v _) + | t == "bool" || t == "u8" || t == "s8" = ".db " ++ show v + | t == "u16" || t == "s16" = ".dw " ++ show v + | otherwise = ".dw " ++ show v +toInit _ v = ".dw " ++ show v header :: String -> [String] header version = [";", "; File created by Micro v" ++ version ++ " (SDCC)", ";"] -module' :: A.Expr -> [String] -module' (A.Module name _) = ["\t.module " ++ name, "\t.optsdcc -mz80"] -module' _ = ["\t.module main"] -- won't happen +module' :: String -> String +module' name = "\t.module " ++ name -exports :: SymMap -> [String] -exports symm = - [""] - ++ ( map (\sym -> "\t.globl " ++ toIdent (symId sym) False) $ - Map.elems $ Map.filter (\sym -> not $ symPriv sym) symm - ) +optsdcc :: String +optsdcc = "\t.optsdcc -mz80" -dataVars :: SymMap -> [String] -dataVars symm = - ["\n\t.area _DATA", "\t.area _INITIALIZED"] - ++ ( map (\sym -> toLabel (symId sym) (symPriv sym) ++ "\n\t" ++ toData (symType sym)) $ - onlyData symm - ) +area :: String -> String +area name = "\n\t.area " ++ name -initVars :: SymMap -> [String] -initVars symm = - ["\n\t.area _INITIALIZER"] - ++ ( map (\sym -> "__xinit_" ++ toLabel (symId sym) True ++ "\n\t" ++ toInit (symType sym) ++ " FIXME") $ onlyData symm - ) - ++ ["\n\t.area _GSINIT", "\t.area _GSFINAL"] +globl :: String -> String +globl id = "\t.globl " ++ id code :: [String] -code = ["\n\t.area _CODE"] +code = [area "_CODE"] + +data Output = Output + { oPre :: [String], + oInit :: [String], + oData :: [String], + oCode :: [String] + } + +emit :: A.Expr -> Output +emit x = + case x of + (A.Module name _) -> o {oPre = [module' name, optsdcc, ""]} + (A.Func ident params ret body priv anon pos) -> do + let out = map emit body + let code = concat (map oCode out) + o + { oPre = if priv then [] else [globl $ toIdent ident], + oCode = [toLabel ident priv] ++ code ++ (if last code /= "\tret" then ["\tret"] else []) + } + (A.Var id typ val priv False _) -> + o + { oPre = if priv then [] else [globl $ toIdent id], + oData = [toLabel id priv, "\t" ++ toData typ], + oInit = ["__xinit" ++ toLabel id True, "\t" ++ toInit typ val] + } + (A.Call (A.Variable id _) _ _) -> o {oCode = ["\tcall " ++ toIdent id]} + (A.Return (Just value) _) -> o {oCode = ["\tld hl, ???", "\tret"]} + (A.Return Nothing _) -> o {oCode = ["\tret"]} + _ -> o + where + o = Output [] [] [] [] -generate :: String -> SymMap -> [A.Expr] -> String -generate version symm ast = unlines $ header version ++ module' (head ast) ++ exports symm ++ dataVars symm ++ code ++ initVars symm +generate :: String -> [A.Expr] -> String +generate version ast = do + out <- pure $ map emit ast + pre <- pure $ concat $ map oPre out + dat <- pure $ ["\n\t.area _DATA", "\t.area _INITIALIZED"] ++ concat (map oData out) + code <- pure $ ["\n\t.area _CODE"] ++ concat (map oCode out) + init <- pure $ ["\n\t.area _INITIALIZER"] ++ concat (map oInit out) ++ ["\n\t.area _GSINIT", "\t.area _GSFINAL"] + unlines $ header version ++ pre ++ dat ++ code ++ init diff --git a/src/Micro/Ast.hs b/src/Micro/Ast.hs index 45697de..ec9141e 100644 --- a/src/Micro/Ast.hs +++ b/src/Micro/Ast.hs @@ -24,8 +24,8 @@ data Expr | Bool' Bool SourcePos | BinOp Op SourcePos Expr Expr | Variable Ident SourcePos - | -- v type value private pos - Var Ident Type Expr Bool SourcePos + | -- v type value private local pos + Var Ident Type Expr Bool Bool SourcePos | -- fn [params] return body private anomyous pos Func Ident [FuncParam] (Maybe Type) [Expr] Bool Bool SourcePos | Call Expr [Expr] SourcePos diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs index 89ba802..98fdae8 100644 --- a/src/Micro/Compiler.hs +++ b/src/Micro/Compiler.hs @@ -153,9 +153,9 @@ compileOne x = do Just err -> addError $ Error TypeError err pos Nothing -> pure rtyp _ -> addError $ Error NonCallable "non callable value in function call" pos - (A.Var ident typ val priv pos) -> do + (A.Var ident typ val priv local pos) -> do st <- get - (ev, errs) <- return $ foldlEither addSymUniq (stEnv st, stErr st) [Sym ident typ priv True pos] + (ev, errs) <- return $ foldlEither addSymUniq (stEnv st, stErr st) [Sym ident typ priv local pos] errs <- return $ if not (definedType typ) @@ -206,9 +206,9 @@ foldConstant x = fid <- foldConstant ident fargs <- traverse foldConstant args Right $ A.Call fid fargs pos - (A.Var ident typ val priv pos) -> do + (A.Var ident typ val priv local pos) -> do fv <- foldConstant val - Right $ A.Var ident typ fv priv pos + Right $ A.Var ident typ fv priv local pos (A.Return value pos) -> do fv <- traverse foldConstant value Right $ A.Return fv pos @@ -231,6 +231,6 @@ compileToAst ast = do compile :: [A.Expr] -> Either [Error] String compile ast = do - sym <- evalState (compileAll ast) startState + _ <- evalState (compileAll ast) startState fast <- left (\e -> [e]) $ traverse foldConstant ast - return $ generate version sym fast + return $ generate version fast diff --git a/src/Micro/Parser.hs b/src/Micro/Parser.hs index 89f5bc0..2ac6b13 100644 --- a/src/Micro/Parser.hs +++ b/src/Micro/Parser.hs @@ -106,7 +106,7 @@ fdef ident priv anon pos = do do x <- fStatement pure $ [x] - <|> grVar True + <|> grVar True True return $ Func ident args rtyp (concat $ body) priv anon pos function :: Bool -> Parser Expr @@ -117,26 +117,26 @@ function priv = do fdef ident priv False pos -- ident: type = value -varWithValue :: Bool -> Parser Expr -varWithValue priv = do +varWithValue :: Bool -> Bool -> Parser Expr +varWithValue local priv = do (ident, typ, _, pos) <- arg reservedOp "=" "assignation" value <- expr - return $ Var ident typ value priv pos + return $ Var ident typ value priv local pos -- group variable declaration -grVar :: Bool -> Parser [Expr] -grVar priv = do +grVar :: Bool -> Bool -> Parser [Expr] +grVar local priv = do reserved "var" - xs <- parens $ commaSep $ varWithValue priv + xs <- parens $ commaSep $ varWithValue local priv reservedOp ";" return $ xs -- variable declaration -var :: Bool -> Parser Expr -var priv = do +var :: Bool -> Bool -> Parser Expr +var local priv = do reserved "var" - x <- varWithValue priv + x <- varWithValue priv local reservedOp ";" return $ x @@ -194,12 +194,12 @@ exprStmt = do -- statements that appear in functions fStatement :: Parser Expr -fStatement = try exprStmt <|> var True <|> return' +fStatement = try exprStmt <|> var True True <|> return' -- top level statement statement :: Parser Expr statement = - try exprStmt <|> try (privateDf var) + try exprStmt <|> try (privateDf (var False)) <|> return' -- this will raise an error module' :: Parser Expr @@ -217,7 +217,7 @@ program = do do x <- try (privateDf function) <|> statement pure $ [x] - <|> privateDfn grVar + <|> privateDfn (grVar False) return $ [m] ++ (concat $ n) parse :: Parser [Expr] diff --git a/test/Language.hs b/test/Language.hs index 1965883..3e6a898 100644 --- a/test/Language.hs +++ b/test/Language.hs @@ -176,7 +176,7 @@ testCases = "module main\n\ \var a: u8 = 10;" [ A.Module "main" $ newPos "-" 1 1, - A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 13) False $ newPos "-" 2 5 + A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 13) False False $ newPos "-" 2 5 ], TestLabel "parse a private variable declaration" $ TestCase $ @@ -184,7 +184,7 @@ testCases = "module main\n\ \private var a: u8 = 10;" [ A.Module "main" $ newPos "-" 1 1, - A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 21) True $ newPos "-" 2 13 + A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 21) False True $ newPos "-" 2 13 ], TestLabel "parse a group variable declaration" $ TestCase $ @@ -193,8 +193,8 @@ testCases = \var (a: u8 = 10,\n\ \b: bool = true);" [ A.Module "main" $ newPos "-" 1 1, - A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 14) False $ newPos "-" 2 6, - A.Var "b" (A.Type "bool") (A.Bool' True $ newPos "-" 3 11) False $ newPos "-" 3 1 + A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 14) False False $ newPos "-" 2 6, + A.Var "b" (A.Type "bool") (A.Bool' True $ newPos "-" 3 11) False False $ newPos "-" 3 1 ], TestLabel "parse a group of private variable declaration" $ TestCase $ @@ -203,8 +203,8 @@ testCases = \private var (a: u8 = 10,\n\ \b: bool = true);" [ A.Module "main" $ newPos "-" 1 1, - A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 22) True $ newPos "-" 2 14, - A.Var "b" (A.Type "bool") (A.Bool' True $ newPos "-" 3 11) True $ newPos "-" 3 1 + A.Var "a" (A.Type "u8") (A.Num 10 $ newPos "-" 2 22) True False $ newPos "-" 2 14, + A.Var "b" (A.Type "bool") (A.Bool' True $ newPos "-" 3 11) True False $ newPos "-" 3 1 ], TestLabel "parse assignation" $ TestCase $ @@ -213,7 +213,7 @@ testCases = \var a: u8 = 0;\n\ \a = 10;" [ A.Module "main" $ newPos "-" 1 1, - A.Var "a" (A.Type "u8") (A.Num 0 $ newPos "-" 2 13) False $ newPos "-" 2 5, + A.Var "a" (A.Type "u8") (A.Num 0 $ newPos "-" 2 13) False False $ newPos "-" 2 5, A.BinOp A.Assign (newPos "-" 3 5) (A.Variable "a" $ newPos "-" 3 1) (A.Num 10 $ newPos "-" 3 5) ], TestLabel "fold constant addition" $ -- cgit v1.2.3