From 20e3b287b7abfbccbd7d94aa403262645563a4cc Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 1 Nov 2021 20:47:28 +0000 Subject: Update with basic Parser types --- app/Main.hs | 7 +- gsa-parser.cabal | 2 + src/GSA.hs | 9 ++- src/GSA/Parser.hs | 216 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/GSA/Types.hs | 155 +++++++++++++++++++++++++++++++++++++-- 5 files changed, 379 insertions(+), 10 deletions(-) create mode 100644 src/GSA/Parser.hs diff --git a/app/Main.hs b/app/Main.hs index dc849e7..a81cf7c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,9 @@ import GSA +import qualified Data.Text.IO as T (readFile) +import Data.Text (Text) + main :: IO () -main = putStrLn "heyyyyyy" +main = do + t <- T.readFile "main.gsa" + print $ parse "main.gsa" t diff --git a/gsa-parser.cabal b/gsa-parser.cabal index a171840..e0115df 100644 --- a/gsa-parser.cabal +++ b/gsa-parser.cabal @@ -35,6 +35,7 @@ library exposed-modules: GSA , GSA.Common , GSA.Types + , GSA.Parser build-depends: , containers , mtl @@ -46,6 +47,7 @@ executable gsa-parser-exe hs-source-dirs: app main-is: Main.hs build-depends: gsa-parser + , text ghc-options: -threaded -rtsopts -with-rtsopts=-N test-suite gsa-parser-test diff --git a/src/GSA.hs b/src/GSA.hs index 3262c33..cbf1220 100644 --- a/src/GSA.hs +++ b/src/GSA.hs @@ -1,7 +1,10 @@ module GSA - ( someFunc, + ( module GSA.Parser, + module GSA.Types, + module GSA.Common ) where -someFunc :: IO () -someFunc = putStrLn "hey" +import GSA.Parser +import GSA.Types +import GSA.Common diff --git a/src/GSA/Parser.hs b/src/GSA/Parser.hs new file mode 100644 index 0000000..9b25321 --- /dev/null +++ b/src/GSA/Parser.hs @@ -0,0 +1,216 @@ +module GSA.Parser where + +import Data.Char +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IMap +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import GSA.Types +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +type Parser = Parsec Void Text + +sc :: Parser () +sc = + L.space + space1 + (L.skipLineComment "//") + (L.skipBlockComment "/*" "*/") + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +braces :: Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +integer :: Parser Integer +integer = lexeme L.decimal + +float :: Parser Double +float = lexeme L.float + +signedInteger :: Parser Integer +signedInteger = L.signed sc integer + +signedFloat :: Parser Double +signedFloat = L.signed sc float + +charLiteral :: Parser Char +charLiteral = between (char '\'') (char '\'') L.charLiteral + +stringLiteral :: Parser String +stringLiteral = char '\"' *> manyTill L.charLiteral (char '\"') + +typParser :: Parser Typ +typParser = undefined + +retTypParser :: Parser RetTyp +retTypParser = undefined + +chunkParser :: Parser Chunk +chunkParser = undefined + +signatureParser :: Parser Signature +signatureParser = undefined + +nodeParser :: Parser Node +nodeParser = undefined + +regParser :: Parser Reg +regParser = do + char 'x' + Reg . fromInteger <$> integer + +identParser :: Parser Ident +identParser = undefined + +ptrofsParser :: Parser Ptrofs +ptrofsParser = undefined + +comparisonParser :: Parser Comparison +comparisonParser = + choice + [ string "==" >> return Ceq, + string "!=" >> return Cne, + string "<" >> return Clt, + string "<=" >> return Cle, + string ">" >> return Cgt, + string ">=" >> return Cge + ] + +compParser :: (Comparison -> Condition) -> Text -> Parser (Condition, [Reg]) +compParser f t = do + r1 <- regParser + comp <- comparisonParser >> symbol t + r2 <- regParser + return $ (f comp, [r1, r2]) + +conditionParser :: Parser (Condition, [Reg]) +conditionParser = + choice [ compParser Ccomp "s", + compParser Ccompu "u", + compParser Ccompl "ls", + compParser Ccomplu "lu" + ] + +addressingParser :: Parser Addressing +addressingParser = undefined + +omoveParser :: Parser (Operation, [Reg]) +omoveParser = do + r <- regParser + return (Omove, [r]) + +ointconstParser :: Parser (Operation, [Reg]) +ointconstParser = do + i <- fromInteger <$> integer + return (Ointconst i, []) + +onegParser :: Parser (Operation, [Reg]) +onegParser = do + r <- parens (symbol "-" >> regParser) + return (Oneg, [r]) + +obinopParser :: Operation -> Text -> Parser (Operation, [Reg]) +obinopParser op t = do + r1 <- regParser + r2 <- symbol t >> regParser + return (op, [r1, r2]) + +obinopimmParser :: (Int -> Operation) -> Text -> Parser (Operation, [Reg]) +obinopimmParser op t = do + r1 <- regParser + i <- symbol t >> fromInteger <$> integer + return (op i, [r1]) + +operationParser :: Parser (Operation, [Reg]) +operationParser = + choice + [ omoveParser, + ointconstParser, + onegParser, + obinopParser Osub "-", + obinopParser Omul "*", + obinopimmParser Omulimm "*", + obinopParser Odiv "/s", + obinopParser Odivu "/u", + obinopParser Omod "%s", + obinopParser Omodu "%u", + obinopParser Oand "&", + obinopimmParser Oandimm "&", + obinopParser Oor "|", + obinopimmParser Oorimm "|" + ] + +predicateParser :: Parser Predicate +predicateParser = undefined + +mergeinstructionParser :: Parser Instruction +mergeinstructionParser = undefined + +inopParser :: Int -> Parser Instruction +inopParser i = symbol "nop" >> return (Inop . Node $ i -1) + +gotoParser' :: Parser Node +gotoParser' = symbol "goto" >> integer >>= (return . Node . fromInteger) + +gotoParser :: Parser Instruction +gotoParser = Inop <$> gotoParser' + +icondParser :: Parser Instruction +icondParser = do + (cond, args) <- symbol "if" >> parens conditionParser + n1 <- gotoParser' + n2 <- symbol "else" >> gotoParser' + return $ Icond cond args n1 n2 + +iopParser :: Int -> Parser Instruction +iopParser i = do + r <- regParser + symbol "=" + (op, args) <- operationParser + goto <- optional gotoParser' + case goto of + Just goto' -> return $ Iop op args r goto' + Nothing -> return $ Iop op args r (Node $ i -1) + +instructionParser :: Parser (Int, Instruction) +instructionParser = do + i <- fromInteger <$> integer + symbol ":" + instr <- choice [gotoParser, inopParser i, icondParser, iopParser i] + return (i, instr) + +codeParser :: Parser Code +codeParser = + Code . IMap.fromList <$> many instructionParser + +functionParser :: Parser (Text, Function) +functionParser = do + name <- lexeme (takeWhile1P (Just "Function name") isAlphaNum) + args <- parens $ regParser `sepBy` symbol "," + code <- braces codeParser + return (name, Function signatureMain args 0 code (Node 0) []) + +gsaParser :: Parser Program +gsaParser = Program . Map.fromList <$> many functionParser + +parse :: String -> Text -> Either String Program +parse file t = + case runParser gsaParser file t of + Left a -> Left (show a) + Right a -> Right a diff --git a/src/GSA/Types.hs b/src/GSA/Types.hs index a99cac7..ff6bb15 100644 --- a/src/GSA/Types.hs +++ b/src/GSA/Types.hs @@ -1,7 +1,9 @@ module GSA.Types where import Data.IntMap.Strict (IntMap) +import Data.Map.Strict (Map) import Data.Text (Text) +import Data.Int (Int64) data Typ = Tint @@ -38,6 +40,7 @@ data Chunk | Mfloat64 | Many32 | Many64 + deriving (Eq, Show) signatureMain :: Signature signatureMain = Signature {sigArgs = [], sigRes = Tret Tint} @@ -48,11 +51,153 @@ newtype Reg = Reg {getReg :: Int} deriving (Eq, Show) newtype Ident = Ident {getIdent :: Int} deriving (Eq, Show) -newtype Addressing = Addressing {getAddressing :: Int} deriving (Eq, Show) +newtype Ptrofs = Ptrofs { getPtrofs :: Int } deriving (Eq, Show) + +data Comparison = + Ceq + | Cne + | Clt + | Cle + | Cgt + | Cge + deriving (Eq, Show) + +negateComparison Ceq = Cne +negateComparison Cne = Ceq +negateComparison Clt = Cge +negateComparison Cle = Cgt +negateComparison Cgt = Cle +negateComparison Cge = Clt + +swapComparison Ceq = Ceq +swapComparison Cne = Cne +swapComparison Clt = Cgt +swapComparison Cle = Cge +swapComparison Cgt = Clt +swapComparison Cge = Cle + +data Condition = + Ccomp Comparison + | Ccompu Comparison + | Ccompimm Comparison Int + | Ccompuimm Comparison Int + | Ccompl Comparison + | Ccomplu Comparison + | Ccomplimm Comparison Int64 + | Ccompluimm Comparison Int64 + | Ccompf Comparison + | Cnotcompf Comparison + | Ccompfs Comparison + | Cnotcompfs Comparison + | Cmaskzero Int + | Cmasknotzero Int + deriving (Eq, Show) -newtype Operation = Operation {getOperation :: Int} deriving (Eq, Show) +data Addressing = + Aindexed Integer + | Aindexed2 Integer + | Ascaled Integer Integer + | Aindexed2scaled Integer Integer + | Aglobal Ident Ptrofs + | Abased Ident Ptrofs + | Abasedscaled Integer Ident Ptrofs + | Ainstack Ptrofs + deriving (Eq, Show) -type Condition = Int +data Operation = Omove + | Ointconst Int + | Olongconst Int64 + | Ofloatconst Double + | Osingleconst Float + | Oindirectsymbol Ident + | Ocast8signed + | Ocast8unsigned + | Ocast16signed + | Ocast16unsigned + | Oneg + | Osub + | Omul + | Omulimm Int + | Omulhs + | Omulhu + | Odiv + | Odivu + | Omod + | Omodu + | Oand + | Oandimm Int + | Oor + | Oorimm Int + | Oxor + | Oxorimm Int + | Onot + | Oshl + | Oshlimm Int + | Oshr + | Oshrimm Int + | Oshrximm Int + | Oshru + | Oshruimm Int + | Ororimm Int + | Oshldimm Int + | Olea Addressing + | Omakelong + | Olowlong + | Ohighlong + | Ocast32signed + | Ocast32unsigned + | Onegl + | Oaddlimm Int64 + | Osubl + | Omull + | Omullimm Int64 + | Omullhs + | Omullhu + | Odivl + | Odivlu + | Omodl + | Omodlu + | Oandl + | Oandlimm Int64 + | Oorl + | Oorlimm Int64 + | Oxorl + | Oxorlimm Int64 + | Onotl + | Oshll + | Oshllimm Int + | Oshrl + | Oshrlimm Int + | Oshrxlimm Int + | Oshrlu + | Oshrluimm Int + | Ororlimm Int + | Oleal Addressing + | Onegf + | Oabsf + | Oaddf + | Osubf + | Omulf + | Odivf + | Onegfs + | Oabsfs + | Oaddfs + | Osubfs + | Omulfs + | Odivfs + | Osingleoffloat + | Ofloatofsingle + | Ointoffloat + | Ofloatofint + | Ointofsingle + | Osingleofint + | Olongoffloat + | Ofloatoflong + | Olongofsingle + | Osingleoflong + | Ocmp Condition + | Osel Condition Typ + deriving (Eq, Show) data Pred a = Ptrue @@ -82,8 +227,6 @@ data Instruction | Imfunc [MergeInstruction] deriving (Eq, Show) -newtype MergeBlock = MergeBlock {getMergeBlock :: [MergeInstruction]} deriving (Eq, Show) - newtype Code = Code {getCode :: IntMap Instruction} deriving (Eq, Show) data Function = Function @@ -96,4 +239,4 @@ data Function = Function } deriving (Eq, Show) -newtype Program = Program {getProgram :: [Function]} deriving (Eq, Show) +newtype Program = Program {getProgram :: Map Text Function} deriving (Eq, Show) -- cgit