From fdf56ce9d0de459dc5bd65537847ded7b02ad5c2 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 2 Oct 2024 22:56:15 +0200 Subject: Negate integral expressions --- lib/Language/Elna/AST.hs | 169 ---------------- lib/Language/Elna/Allocator.hs | 39 ---- lib/Language/Elna/Backend/Allocator.hs | 41 ++++ lib/Language/Elna/Backend/Intermediate.hs | 46 +++++ lib/Language/Elna/CodeGenerator.hs | 143 ------------- lib/Language/Elna/Frontend/AST.hs | 169 ++++++++++++++++ lib/Language/Elna/Frontend/NameAnalysis.hs | 216 ++++++++++++++++++++ lib/Language/Elna/Frontend/Parser.hs | 223 +++++++++++++++++++++ lib/Language/Elna/Frontend/SymbolTable.hs | 88 ++++++++ lib/Language/Elna/Frontend/TypeAnalysis.hs | 186 +++++++++++++++++ lib/Language/Elna/Frontend/Types.hs | 29 +++ lib/Language/Elna/Glue.hs | 270 +++++++++++++++++++++++++ lib/Language/Elna/Intermediate.hs | 311 ----------------------------- lib/Language/Elna/NameAnalysis.hs | 216 -------------------- lib/Language/Elna/Parser.hs | 220 -------------------- lib/Language/Elna/PrinterWriter.hs | 276 ------------------------- lib/Language/Elna/RiscV/CodeGenerator.hs | 156 +++++++++++++++ lib/Language/Elna/RiscV/ElfWriter.hs | 276 +++++++++++++++++++++++++ lib/Language/Elna/SymbolTable.hs | 88 -------- lib/Language/Elna/TypeAnalysis.hs | 186 ----------------- lib/Language/Elna/Types.hs | 29 --- 21 files changed, 1700 insertions(+), 1677 deletions(-) delete mode 100644 lib/Language/Elna/AST.hs delete mode 100644 lib/Language/Elna/Allocator.hs create mode 100644 lib/Language/Elna/Backend/Allocator.hs create mode 100644 lib/Language/Elna/Backend/Intermediate.hs delete mode 100644 lib/Language/Elna/CodeGenerator.hs create mode 100644 lib/Language/Elna/Frontend/AST.hs create mode 100644 lib/Language/Elna/Frontend/NameAnalysis.hs create mode 100644 lib/Language/Elna/Frontend/Parser.hs create mode 100644 lib/Language/Elna/Frontend/SymbolTable.hs create mode 100644 lib/Language/Elna/Frontend/TypeAnalysis.hs create mode 100644 lib/Language/Elna/Frontend/Types.hs create mode 100644 lib/Language/Elna/Glue.hs delete mode 100644 lib/Language/Elna/Intermediate.hs delete mode 100644 lib/Language/Elna/NameAnalysis.hs delete mode 100644 lib/Language/Elna/Parser.hs delete mode 100644 lib/Language/Elna/PrinterWriter.hs create mode 100644 lib/Language/Elna/RiscV/CodeGenerator.hs create mode 100644 lib/Language/Elna/RiscV/ElfWriter.hs delete mode 100644 lib/Language/Elna/SymbolTable.hs delete mode 100644 lib/Language/Elna/TypeAnalysis.hs delete mode 100644 lib/Language/Elna/Types.hs (limited to 'lib') diff --git a/lib/Language/Elna/AST.hs b/lib/Language/Elna/AST.hs deleted file mode 100644 index 4861318..0000000 --- a/lib/Language/Elna/AST.hs +++ /dev/null @@ -1,169 +0,0 @@ -module Language.Elna.AST - ( Declaration(..) - , Identifier(..) - , Parameter(..) - , Program(..) - , Statement(..) - , TypeExpression(..) - , VariableDeclaration(..) - {-, VariableAccess(..) - , Condition(..)-} - , Expression(..) - , Literal(..) - ) where - -import Data.Int (Int32) -import Data.List (intercalate) -import Data.Word ({-Word16, -}Word32) -import Language.Elna.Location (Identifier(..), showArrayType) - -newtype Program = Program [Declaration] - deriving Eq - -instance Show Program - where - show (Program declarations) = unlines (show <$> declarations) - -data Declaration - = ProcedureDeclaration Identifier [Parameter] [VariableDeclaration] [Statement] - -- | TypeDefinition Identifier TypeExpression - deriving Eq - -instance Show Declaration - where - {- show (TypeDefinition identifier typeExpression) = - concat ["type ", show identifier, " = ", show typeExpression, ";"] -} - show (ProcedureDeclaration procedureName parameters variables body) - = "proc " <> show procedureName <> showParameters parameters <> " {\n" - <> unlines ((" " <>) . show <$> variables) - <> unlines ((" " <>) . show <$> body) - <> "}" - -data Parameter = Parameter Identifier TypeExpression Bool - deriving Eq - -instance Show Parameter - where - show (Parameter identifier typeName ref) = concat - [ if ref then "ref " else "" - , show identifier, ": ", show typeName - ] - -showParameters :: [Parameter] -> String -showParameters parameters = - "(" <> intercalate ", " (show <$> parameters) <> ")" - -data TypeExpression - = NamedType Identifier - | ArrayType Word32 TypeExpression - deriving Eq - -instance Show TypeExpression - where - show (NamedType typeName) = show typeName - show (ArrayType elementCount typeName) = showArrayType elementCount typeName - -data Statement - = EmptyStatement - {-| AssignmentStatement VariableAccess Expression - | IfStatement Condition Statement (Maybe Statement) - | WhileStatement Condition Statement - | CompoundStatement [Statement]-} - | CallStatement Identifier [Expression] - deriving Eq - -instance Show Statement - where - show EmptyStatement = ";" - {-show (AssignmentStatement lhs rhs) = - concat [show lhs, " := ", show rhs, ";"] - show (IfStatement condition if' else') = concat - [ "if (", show condition, ") " - , show if' - , maybe "" ((<> " else ") . show) else' - ] - show (WhileStatement expression statement) = - concat ["while (", show expression, ") ", show statement, ";"] - show (CompoundStatement statements) = - concat ["{\n", unlines (show <$> statements), " }"]-} - show (CallStatement name parameters) = show name <> "(" - <> intercalate ", " (show <$> parameters) <> ")" - -data VariableDeclaration = - VariableDeclaration Identifier TypeExpression - deriving Eq - -newtype Literal - = IntegerLiteral Int32 - {- | HexadecimalLiteral Int32 - | CharacterLiteral Word16 - | BooleanLiteral Bool -} - deriving Eq - -instance Show Literal - where - show (IntegerLiteral integer) = show integer - {- show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer "" - show (CharacterLiteral character) = - '\'' : chr (fromEnum character) : ['\''] - show (BooleanLiteral boolean) - | boolean = "true" - | otherwise = "false" -} - -instance Show VariableDeclaration - where - show (VariableDeclaration identifier typeExpression) = - concat ["var ", show identifier, ": " <> show typeExpression, ";"] - -data Expression - = LiteralExpression Literal - | SumExpression Expression Expression - | SubtractionExpression Expression Expression -{- | VariableExpression VariableAccess - | NegationExpression Expression - | ProductExpression Expression Expression - | DivisionExpression Expression Expression -} - deriving Eq - -instance Show Expression - where - show (LiteralExpression literal) = show literal - show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs] - show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs] - {- show (VariableExpression variable) = show variable - show (NegationExpression negation) = '-' : show negation - show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs] - show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs] -} -{- -import Data.Char (chr) -import Numeric (showHex) - -data VariableAccess - = VariableAccess Identifier - | ArrayAccess VariableAccess Expression - deriving Eq - -instance Show VariableAccess - where - show (VariableAccess variableName) = show variableName - show (ArrayAccess arrayAccess elementIndex) = - concat [show arrayAccess, "[", show elementIndex, "]"] - -data Condition - = EqualCondition Expression Expression - | NonEqualCondition Expression Expression - | LessCondition Expression Expression - | GreaterCondition Expression Expression - | LessOrEqualCondition Expression Expression - | GreaterOrEqualCondition Expression Expression - deriving Eq - -instance Show Condition - where - show (EqualCondition lhs rhs) = concat [show lhs, " = ", show rhs] - show (NonEqualCondition lhs rhs) = concat [show lhs, " # ", show rhs] - show (LessCondition lhs rhs) = concat [show lhs, " < ", show rhs] - show (GreaterCondition lhs rhs) = concat [show lhs, " > ", show rhs] - show (LessOrEqualCondition lhs rhs) = concat [show lhs, " <= ", show rhs] - show (GreaterOrEqualCondition lhs rhs) = concat [show lhs, " >= ", show rhs] --} diff --git a/lib/Language/Elna/Allocator.hs b/lib/Language/Elna/Allocator.hs deleted file mode 100644 index 3b32de4..0000000 --- a/lib/Language/Elna/Allocator.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Language.Elna.Allocator - ( MachineConfiguration(..) - , Store(..) - , allocate - ) where - -import Data.HashMap.Strict (HashMap) -import Data.Vector (Vector) -import Language.Elna.Intermediate (Operand(..), Quadruple(..), Variable(..)) -import Language.Elna.Location (Identifier(..)) - -newtype Store r = Store r - -newtype MachineConfiguration r = MachineConfiguration - { temporaryRegister :: r - } - -allocate - :: forall r - . MachineConfiguration r - -> HashMap Identifier (Vector (Quadruple Variable)) - -> HashMap Identifier (Vector (Quadruple (Store r))) -allocate MachineConfiguration{..} = fmap function - where - function :: Vector (Quadruple Variable) -> Vector (Quadruple (Store r)) - function = fmap quadruple - quadruple :: Quadruple Variable -> Quadruple (Store r) - quadruple StartQuadruple = StartQuadruple - quadruple StopQuadruple = StopQuadruple - quadruple (ParameterQuadruple operand1) = - ParameterQuadruple (operand operand1) - quadruple (CallQuadruple name count) = CallQuadruple name count - quadruple (AddQuadruple operand1 operand2 _) = - AddQuadruple (operand operand1) (operand operand2) (Store temporaryRegister) - quadruple (SubtractionQuadruple operand1 operand2 _) = - SubtractionQuadruple (operand operand1) (operand operand2) (Store temporaryRegister) - operand :: Operand Variable -> Operand (Store r) - operand (IntOperand x) = IntOperand x - operand (VariableOperand _) = VariableOperand (Store temporaryRegister) diff --git a/lib/Language/Elna/Backend/Allocator.hs b/lib/Language/Elna/Backend/Allocator.hs new file mode 100644 index 0000000..9ad849e --- /dev/null +++ b/lib/Language/Elna/Backend/Allocator.hs @@ -0,0 +1,41 @@ +module Language.Elna.Backend.Allocator + ( MachineConfiguration(..) + , Store(..) + , allocate + ) where + +import Data.HashMap.Strict (HashMap) +import Data.Vector (Vector) +import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..), Variable(..)) +import Language.Elna.Location (Identifier(..)) + +newtype Store r = Store r + +newtype MachineConfiguration r = MachineConfiguration + { temporaryRegister :: r + } + +allocate + :: forall r + . MachineConfiguration r + -> HashMap Identifier (Vector (Quadruple Variable)) + -> HashMap Identifier (Vector (Quadruple (Store r))) +allocate MachineConfiguration{..} = fmap function + where + function :: Vector (Quadruple Variable) -> Vector (Quadruple (Store r)) + function = fmap quadruple + quadruple :: Quadruple Variable -> Quadruple (Store r) + quadruple StartQuadruple = StartQuadruple + quadruple StopQuadruple = StopQuadruple + quadruple (ParameterQuadruple operand1) = + ParameterQuadruple (operand operand1) + quadruple (CallQuadruple name count) = CallQuadruple name count + quadruple (AddQuadruple operand1 operand2 _) = + AddQuadruple (operand operand1) (operand operand2) (Store temporaryRegister) + quadruple (SubtractionQuadruple operand1 operand2 _) = + SubtractionQuadruple (operand operand1) (operand operand2) (Store temporaryRegister) + quadruple (NegationQuadruple operand1 _) = + NegationQuadruple (operand operand1) (Store temporaryRegister) + operand :: Operand Variable -> Operand (Store r) + operand (IntOperand x) = IntOperand x + operand (VariableOperand _) = VariableOperand (Store temporaryRegister) diff --git a/lib/Language/Elna/Backend/Intermediate.hs b/lib/Language/Elna/Backend/Intermediate.hs new file mode 100644 index 0000000..01a026b --- /dev/null +++ b/lib/Language/Elna/Backend/Intermediate.hs @@ -0,0 +1,46 @@ +module Language.Elna.Backend.Intermediate + ( Operand(..) + , Quadruple(..) + {- , Label(..) -} + , Variable(..) + ) where + +import Data.Int (Int32) +import Data.Word (Word32) +import Data.Text (Text) + +newtype Variable = TempVariable Word32 -- | Variable Text + deriving Eq + +instance Show Variable + where + -- show (Variable variable) = '$' : Text.unpack variable + show (TempVariable variable) = '$' : show variable + +data Operand v + = IntOperand Int32 + | VariableOperand v + deriving (Eq, Show) + +data Quadruple v + = StartQuadruple + | StopQuadruple + | ParameterQuadruple (Operand v) + | CallQuadruple Text Word32 + | AddQuadruple (Operand v) (Operand v) v + | SubtractionQuadruple (Operand v) (Operand v) v + | NegationQuadruple (Operand v) v + {-| GoToQuadruple Label + | AssignQuadruple Operand Variable + | ArrayQuadruple Variable Operand Variable + | ArrayAssignQuadruple Operand Operand Variable + | ProductQuadruple Operand Operand Variable + | DivisionQuadruple Operand Operand Variable + | EqualQuadruple Operand Operand Label + | NonEqualQuadruple Operand Operand Label + | LessQuadruple Operand Operand Label + | GreaterQuadruple Operand Operand Label + | LessOrEqualQuadruple Operand Operand Label + | GreaterOrEqualQuadruple Operand Operand Label + | LabelQuadruple Label -} + deriving (Eq, Show) diff --git a/lib/Language/Elna/CodeGenerator.hs b/lib/Language/Elna/CodeGenerator.hs deleted file mode 100644 index a561cb8..0000000 --- a/lib/Language/Elna/CodeGenerator.hs +++ /dev/null @@ -1,143 +0,0 @@ -module Language.Elna.CodeGenerator - ( Statement(..) - , generateRiscV - , riscVConfiguration - ) where - -import Data.ByteString (ByteString) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Int (Int32) -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import qualified Data.Text.Encoding as Text.Encoding -import Language.Elna.Allocator (MachineConfiguration(..), Store(..)) -import Language.Elna.Location (Identifier(..)) -import Language.Elna.Intermediate (Operand(..), Quadruple(..)) -import qualified Language.Elna.Architecture.RiscV as RiscV -import Data.Bits (Bits(..)) - -data Directive - = GlobalDirective - | FunctionDirective - deriving (Eq, Show) - -data Statement - = Instruction RiscV.Instruction - | JumpLabel ByteString [Directive] - deriving Eq - -riscVConfiguration :: MachineConfiguration RiscV.XRegister -riscVConfiguration = MachineConfiguration - { temporaryRegister = RiscV.T0 - } - -type RiscVStore = Store RiscV.XRegister -type RiscVQuadruple = Quadruple RiscVStore -type RiscVOperand = Operand RiscVStore - -generateRiscV :: HashMap Identifier (Vector RiscVQuadruple) -> Vector Statement -generateRiscV = HashMap.foldlWithKey' go Vector.empty - where - go accumulator (Identifier key) value = - let code = Vector.cons (JumpLabel (Text.Encoding.encodeUtf8 key) [GlobalDirective, FunctionDirective]) - $ Vector.foldMap quadruple value - in accumulator <> code - -quadruple :: RiscVQuadruple -> Vector Statement -quadruple StartQuadruple = Vector.fromList - [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4)) - , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0) - , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA) - , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP 4) - ] -quadruple (ParameterQuadruple operand1) = - let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0 - in mappend statements $ Vector.fromList - [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4)) - , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister) - ] -quadruple (CallQuadruple callName numberOfArguments) = Vector.fromList - [ Instruction (RiscV.CallInstruction callName) - , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (numberOfArguments * 4)) - ] -quadruple StopQuadruple = Vector.fromList - [ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0) - , Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4) - , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP 4) - , Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0) - ] -quadruple (AddQuadruple operand1 operand2 (Store register)) - | IntOperand immediateOperand1 <- operand1 - , IntOperand immediateOperand2 <- operand2 = - lui (immediateOperand1 + immediateOperand2) register - | VariableOperand variableOperand1 <- operand1 - , VariableOperand variableOperand2 <- operand2 = - let Store operandRegister1 = variableOperand1 - Store operandRegister2 = variableOperand2 - in pure $ Instruction - $ RiscV.BaseInstruction RiscV.Op - $ RiscV.R register RiscV.ADD operandRegister1 operandRegister2 (RiscV.Funct7 0b0000000) - | VariableOperand variableOperand1 <- operand1 - , IntOperand immediateOperand2 <- operand2 = - addImmediateRegister variableOperand1 immediateOperand2 - | IntOperand immediateOperand1 <- operand1 - , VariableOperand variableOperand2 <- operand2 = - addImmediateRegister variableOperand2 immediateOperand1 - where - addImmediateRegister variableOperand immediateOperand = - let statements = lui immediateOperand register - Store operandRegister = variableOperand - in Vector.snoc statements - $ Instruction - $ RiscV.BaseInstruction RiscV.Op - $ RiscV.R register RiscV.ADD register operandRegister (RiscV.Funct7 0b0000000) -quadruple (SubtractionQuadruple operand1 operand2 (Store register)) - | IntOperand immediateOperand1 <- operand1 - , IntOperand immediateOperand2 <- operand2 = - lui (immediateOperand1 - immediateOperand2) register - | VariableOperand variableOperand1 <- operand1 - , VariableOperand variableOperand2 <- operand2 = - let Store operandRegister1 = variableOperand1 - Store operandRegister2 = variableOperand2 - in pure $ Instruction - $ RiscV.BaseInstruction RiscV.Op - $ RiscV.R register RiscV.SUB operandRegister1 operandRegister2 (RiscV.Funct7 0b0100000) - | IntOperand immediateOperand1 <- operand1 - , VariableOperand variableOperand2 <- operand2 = - let statements1 = lui immediateOperand1 register - Store operandRegister2 = variableOperand2 - in Vector.snoc statements1 - $ Instruction - $ RiscV.BaseInstruction RiscV.Op - $ RiscV.R register RiscV.SUB register operandRegister2 (RiscV.Funct7 0b0100000) - | VariableOperand variableOperand1 <- operand1 - , IntOperand immediateOperand2 <- operand2 = - let statements2 = lui (negate immediateOperand2) register - Store operandRegister1 = variableOperand1 - in Vector.snoc statements2 - $ Instruction - $ RiscV.BaseInstruction RiscV.Op - $ RiscV.R register RiscV.ADD register operandRegister1 (RiscV.Funct7 0b0000000) - -loadImmediateOrRegister :: RiscVOperand -> RiscV.XRegister -> (RiscV.XRegister, Vector Statement) -loadImmediateOrRegister (IntOperand intValue) targetRegister = - (targetRegister, lui intValue targetRegister) -loadImmediateOrRegister (VariableOperand (Store register)) _ = (register, Vector.empty) - -lui :: Int32 -> RiscV.XRegister -> Vector Statement -lui intValue targetRegister - | intValue >= -2048 - , intValue <= 2047 = Vector.singleton - $ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI RiscV.Zero lo) - | intValue .&. 0x800 /= 0 = Vector.fromList - [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral $ succ hi) - , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo) - ] - | otherwise = Vector.fromList - [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral hi) - , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo) - ] - where - hi = intValue `shiftR` 12 - lo = fromIntegral intValue diff --git a/lib/Language/Elna/Frontend/AST.hs b/lib/Language/Elna/Frontend/AST.hs new file mode 100644 index 0000000..738ddcc --- /dev/null +++ b/lib/Language/Elna/Frontend/AST.hs @@ -0,0 +1,169 @@ +module Language.Elna.Frontend.AST + ( Declaration(..) + , Identifier(..) + , Parameter(..) + , Program(..) + , Statement(..) + , TypeExpression(..) + , VariableDeclaration(..) + {-, VariableAccess(..) + , Condition(..)-} + , Expression(..) + , Literal(..) + ) where + +import Data.Int (Int32) +import Data.List (intercalate) +import Data.Word ({-Word16, -}Word32) +import Language.Elna.Location (Identifier(..), showArrayType) + +newtype Program = Program [Declaration] + deriving Eq + +instance Show Program + where + show (Program declarations) = unlines (show <$> declarations) + +data Declaration + = ProcedureDeclaration Identifier [Parameter] [VariableDeclaration] [Statement] + -- | TypeDefinition Identifier TypeExpression + deriving Eq + +instance Show Declaration + where + {- show (TypeDefinition identifier typeExpression) = + concat ["type ", show identifier, " = ", show typeExpression, ";"] -} + show (ProcedureDeclaration procedureName parameters variables body) + = "proc " <> show procedureName <> showParameters parameters <> " {\n" + <> unlines ((" " <>) . show <$> variables) + <> unlines ((" " <>) . show <$> body) + <> "}" + +data Parameter = Parameter Identifier TypeExpression Bool + deriving Eq + +instance Show Parameter + where + show (Parameter identifier typeName ref) = concat + [ if ref then "ref " else "" + , show identifier, ": ", show typeName + ] + +showParameters :: [Parameter] -> String +showParameters parameters = + "(" <> intercalate ", " (show <$> parameters) <> ")" + +data TypeExpression + = NamedType Identifier + | ArrayType Word32 TypeExpression + deriving Eq + +instance Show TypeExpression + where + show (NamedType typeName) = show typeName + show (ArrayType elementCount typeName) = showArrayType elementCount typeName + +data Statement + = EmptyStatement + {-| AssignmentStatement VariableAccess Expression + | IfStatement Condition Statement (Maybe Statement) + | WhileStatement Condition Statement + | CompoundStatement [Statement]-} + | CallStatement Identifier [Expression] + deriving Eq + +instance Show Statement + where + show EmptyStatement = ";" + {-show (AssignmentStatement lhs rhs) = + concat [show lhs, " := ", show rhs, ";"] + show (IfStatement condition if' else') = concat + [ "if (", show condition, ") " + , show if' + , maybe "" ((<> " else ") . show) else' + ] + show (WhileStatement expression statement) = + concat ["while (", show expression, ") ", show statement, ";"] + show (CompoundStatement statements) = + concat ["{\n", unlines (show <$> statements), " }"]-} + show (CallStatement name parameters) = show name <> "(" + <> intercalate ", " (show <$> parameters) <> ")" + +data VariableDeclaration = + VariableDeclaration Identifier TypeExpression + deriving Eq + +newtype Literal + = IntegerLiteral Int32 + {- | HexadecimalLiteral Int32 + | CharacterLiteral Word16 + | BooleanLiteral Bool -} + deriving Eq + +instance Show Literal + where + show (IntegerLiteral integer) = show integer + {- show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer "" + show (CharacterLiteral character) = + '\'' : chr (fromEnum character) : ['\''] + show (BooleanLiteral boolean) + | boolean = "true" + | otherwise = "false" -} + +instance Show VariableDeclaration + where + show (VariableDeclaration identifier typeExpression) = + concat ["var ", show identifier, ": " <> show typeExpression, ";"] + +data Expression + = LiteralExpression Literal + | SumExpression Expression Expression + | SubtractionExpression Expression Expression + | NegationExpression Expression +{- | VariableExpression VariableAccess + | ProductExpression Expression Expression + | DivisionExpression Expression Expression -} + deriving Eq + +instance Show Expression + where + show (LiteralExpression literal) = show literal + show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs] + show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs] + show (NegationExpression negation) = '-' : show negation + {- show (VariableExpression variable) = show variable + show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs] + show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs] -} +{- +import Data.Char (chr) +import Numeric (showHex) + +data VariableAccess + = VariableAccess Identifier + | ArrayAccess VariableAccess Expression + deriving Eq + +instance Show VariableAccess + where + show (VariableAccess variableName) = show variableName + show (ArrayAccess arrayAccess elementIndex) = + concat [show arrayAccess, "[", show elementIndex, "]"] + +data Condition + = EqualCondition Expression Expression + | NonEqualCondition Expression Expression + | LessCondition Expression Expression + | GreaterCondition Expression Expression + | LessOrEqualCondition Expression Expression + | GreaterOrEqualCondition Expression Expression + deriving Eq + +instance Show Condition + where + show (EqualCondition lhs rhs) = concat [show lhs, " = ", show rhs] + show (NonEqualCondition lhs rhs) = concat [show lhs, " # ", show rhs] + show (LessCondition lhs rhs) = concat [show lhs, " < ", show rhs] + show (GreaterCondition lhs rhs) = concat [show lhs, " > ", show rhs] + show (LessOrEqualCondition lhs rhs) = concat [show lhs, " <= ", show rhs] + show (GreaterOrEqualCondition lhs rhs) = concat [show lhs, " >= ", show rhs] +-} diff --git a/lib/Language/Elna/Frontend/NameAnalysis.hs b/lib/Language/Elna/Frontend/NameAnalysis.hs new file mode 100644 index 0000000..2915331 --- /dev/null +++ b/lib/Language/Elna/Frontend/NameAnalysis.hs @@ -0,0 +1,216 @@ +module Language.Elna.Frontend.NameAnalysis + ( nameAnalysis + , Error(..) + ) where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Vector as Vector +import qualified Language.Elna.Frontend.AST as AST +import qualified Language.Elna.Frontend.SymbolTable as SymbolTable +import Language.Elna.Frontend.SymbolTable + ( SymbolTable + , Info(..) + , ParameterInfo(..) + ) +import Control.Monad.Trans.Except (Except, runExcept, throwE) +import Data.Functor ((<&>)) +import Language.Elna.Location (Identifier(..)) +import Language.Elna.Frontend.Types (Type(..)) +import Data.Foldable (traverse_) +import Control.Monad (foldM, unless) + +data Error + = UndefinedTypeError Identifier + | UnexpectedTypeInfoError Info + | IdentifierAlreadyDefinedError Identifier + | UndefinedSymbolError Identifier + | UnexpectedArrayByValue Identifier + deriving Eq + +instance Show Error + where + show (UndefinedTypeError identifier) = + concat ["Type \"", show identifier, "\" is not defined"] + show (UnexpectedTypeInfoError info) = show info + <> " expected to be a type" + show (IdentifierAlreadyDefinedError identifier) = + concat ["The identifier \"", show identifier, "\" is already defined"] + show (UndefinedSymbolError identifier) = + concat ["Symbol \"", show identifier, "\" is not defined"] + show (UnexpectedArrayByValue identifier) = concat + [ "Array \"" + , show identifier + , "\" cannot be passed by value, only by reference" + ] + +newtype NameAnalysis a = NameAnalysis + { runNameAnalysis :: Except Error a + } + +instance Functor NameAnalysis + where + fmap f (NameAnalysis x) = NameAnalysis $ f <$> x + +instance Applicative NameAnalysis + where + pure = NameAnalysis . pure + (NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x + +instance Monad NameAnalysis + where + (NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f) + +nameAnalysis :: AST.Program -> Either Error SymbolTable +nameAnalysis = runExcept + . runNameAnalysis + . program SymbolTable.builtInSymbolTable + +program :: SymbolTable -> AST.Program -> NameAnalysis SymbolTable +program symbolTable (AST.Program declarations) = do + globalTable <- foldM procedureDeclaration symbolTable declarations + foldM declaration globalTable declarations + +procedureDeclaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable +procedureDeclaration globalTable (AST.ProcedureDeclaration identifier parameters _ _) = do + parametersInfo <- mapM (parameter globalTable) parameters + let procedureInfo = ProcedureInfo SymbolTable.empty + $ Vector.fromList parametersInfo + maybe (NameAnalysis $ throwE $ IdentifierAlreadyDefinedError identifier) pure + $ SymbolTable.enter identifier procedureInfo globalTable + +declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable +declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do + variableInfo <- mapM (variableDeclaration globalTable) variables + parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters + procedureTable <- fmap (SymbolTable.scope globalTable) + $ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure + $ SymbolTable.fromList + $ parameterInfo <> variableInfo + traverse_ (statement procedureTable) body + pure $ SymbolTable.update (updater procedureTable) identifier globalTable + where + updater procedureTable (ProcedureInfo _ parameters') = Just + $ ProcedureInfo procedureTable parameters' + updater _ _ = Nothing + +parameterToVariableInfo :: SymbolTable -> AST.Parameter -> NameAnalysis (Identifier, Info) +parameterToVariableInfo symbolTable (AST.Parameter identifier typeExpression isReferenceParameter') + = (identifier,) . VariableInfo isReferenceParameter' + <$> dataType symbolTable typeExpression + +variableDeclaration :: SymbolTable -> AST.VariableDeclaration -> NameAnalysis (Identifier, Info) +variableDeclaration globalTable (AST.VariableDeclaration identifier typeExpression) + = (identifier,) . VariableInfo False + <$> dataType globalTable typeExpression + +parameter :: SymbolTable -> AST.Parameter -> NameAnalysis ParameterInfo +parameter environmentSymbolTable (AST.Parameter identifier typeExpression isReferenceParameter') = do + parameterType <- dataType environmentSymbolTable typeExpression + case parameterType of + ArrayType _ _ + | not isReferenceParameter' -> NameAnalysis + $ throwE $ UnexpectedArrayByValue identifier + _ -> + let parameterInfo = ParameterInfo + { name = identifier + , type' = parameterType + , isReferenceParameter = isReferenceParameter' + } + in pure parameterInfo + +dataType :: SymbolTable -> AST.TypeExpression -> NameAnalysis Type +dataType environmentSymbolTable (AST.NamedType baseType) = do + case SymbolTable.lookup baseType environmentSymbolTable of + Just baseInfo + | TypeInfo baseType' <- baseInfo -> pure baseType' + | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo + _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType +dataType environmentSymbolTable (AST.ArrayType arraySize baseType) = + dataType environmentSymbolTable baseType <&> ArrayType arraySize + +checkSymbol :: SymbolTable -> Identifier -> NameAnalysis () +checkSymbol globalTable identifier + = unless (SymbolTable.member identifier globalTable) + $ NameAnalysis $ throwE + $ UndefinedSymbolError identifier + +expression :: SymbolTable -> AST.Expression -> NameAnalysis () +expression _ (AST.LiteralExpression _) = pure () +expression globalTable (AST.SumExpression lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +expression globalTable (AST.SubtractionExpression lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +expression globalTable (AST.NegationExpression negation) = + expression globalTable negation +{- expression globalTable (AST.VariableExpression variableExpression) = + variableAccess globalTable variableExpression +expression globalTable (AST.ProductExpression lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +expression globalTable (AST.DivisionExpression lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +-} +statement :: SymbolTable -> AST.Statement -> NameAnalysis () +statement _ AST.EmptyStatement = pure () +statement globalTable (AST.CallStatement name arguments) + = checkSymbol globalTable name + >> traverse_ (expression globalTable) arguments +{- statement globalTable (AST.AssignmentStatement lvalue rvalue) + = variableAccess globalTable lvalue + >> expression globalTable rvalue +statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement) + = condition globalTable ifCondition + >> statement globalTable ifStatement + >> maybe (pure ()) (statement globalTable) elseStatement +statement globalTable (AST.WhileStatement whileCondition loop) + = condition globalTable whileCondition + >> statement globalTable loop +statement globalTable (AST.CompoundStatement statements) = + traverse_ (statement globalTable) statements + +variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis () +variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) + = variableAccess globalTable arrayExpression + >> expression globalTable indexExpression +variableAccess globalTable (AST.VariableAccess identifier) = + checkSymbol globalTable identifier + +condition :: SymbolTable -> AST.Condition -> NameAnalysis () +condition globalTable (AST.EqualCondition lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +condition globalTable (AST.NonEqualCondition lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +condition globalTable (AST.LessCondition lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +condition globalTable (AST.GreaterCondition lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +condition globalTable (AST.LessOrEqualCondition lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs +condition globalTable (AST.GreaterOrEqualCondition lhs rhs) + = expression globalTable lhs + >> expression globalTable rhs + +enter :: Identifier -> Info -> SymbolTable -> NameAnalysis SymbolTable +enter identifier info table + = maybe (identifierAlreadyDefinedError identifier) pure + $ SymbolTable.enter identifier info table + +identifierAlreadyDefinedError :: Identifier -> NameAnalysis a +identifierAlreadyDefinedError = NameAnalysis + . lift + . throwE + . IdentifierAlreadyDefinedError + +variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info) +variableDeclaration (AST.VariableDeclaration identifier typeExpression) + = (identifier,) . VariableInfo False + <$> dataType typeExpression +-} diff --git a/lib/Language/Elna/Frontend/Parser.hs b/lib/Language/Elna/Frontend/Parser.hs new file mode 100644 index 0000000..4093f25 --- /dev/null +++ b/lib/Language/Elna/Frontend/Parser.hs @@ -0,0 +1,223 @@ +module Language.Elna.Frontend.Parser + ( Parser + , programP + ) where + +import Control.Monad (void) +import Control.Monad.Combinators.Expr (Operator(..), makeExprParser) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Void (Void) +import Language.Elna.Frontend.AST + ( Declaration(..) + , Identifier(..) + , Parameter(..) + , Program(..) + , Statement(..) + , TypeExpression(..) + , VariableDeclaration(..) + {-, VariableAccess(..) + , Condition(..)-} + , Expression(..) + , Literal(..) + ) +import Text.Megaparsec + ( Parsec + , () + , MonadParsec(..) + , eof + , optional + , between + , sepBy + , choice + ) +import qualified Text.Megaparsec.Char.Lexer as Lexer +import Text.Megaparsec.Char + ( alphaNumChar +-- , char + , letterChar + , space1 +-- , string + ) +import Control.Applicative (Alternative(..)) +import Data.Maybe (isJust) +-- import Data.Functor (($>)) + +type Parser = Parsec Void Text + +literalP :: Parser Literal +literalP + = {- HexadecimalLiteral <$> (string "0x" *> lexeme Lexer.hexadecimal) + <|> -} IntegerLiteral <$> Lexer.signed space integerP + {- <|> CharacterLiteral <$> lexeme charP + <|> BooleanLiteral <$> (symbol "true" $> True) + <|> BooleanLiteral <$> (symbol "false" $> False) + where + charP = fromIntegral . fromEnum + <$> between (char '\'') (char '\'') Lexer.charLiteral -} +{- +typeDefinitionP :: Parser Declaration +typeDefinitionP = TypeDefinition + <$> (symbol "type" *> identifierP) + <*> (symbol "=" *> typeExpressionP) + <* semicolonP + "type definition" +-} +termP :: Parser Expression +termP = choice + [ parensP expressionP + , LiteralExpression <$> literalP + -- , VariableExpression <$> variableAccessP + ] + +operatorTable :: [[Operator Parser Expression]] +operatorTable = + [ unaryOperator + -- , factorOperator + , termOperator + ] + where + unaryOperator = + [ prefix "-" NegationExpression + , prefix "+" id + ] + {- factorOperator = + [ binary "*" ProductExpression + , binary "/" DivisionExpression + ] -} + termOperator = + [ binary "+" SumExpression + , binary "-" SubtractionExpression + ] + prefix name f = Prefix (f <$ symbol name) + binary name f = InfixL (f <$ symbol name) + +expressionP :: Parser Expression +expressionP = makeExprParser termP operatorTable +{- +variableAccessP :: Parser VariableAccess +variableAccessP = do + identifier <- identifierP + indices <- many $ bracketsP expressionP + pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices + +conditionP :: Parser Condition +conditionP = do + lhs <- expressionP + conditionCons <- choice comparisonOperator + conditionCons lhs <$> expressionP + where + comparisonOperator = + [ symbol "<" >> pure LessCondition + , symbol "<=" >> pure LessOrEqualCondition + , symbol ">" >> pure GreaterCondition + , symbol ">=" >> pure GreaterOrEqualCondition + , symbol "=" >> pure EqualCondition + , symbol "#" >> pure NonEqualCondition + ] +-} +symbol :: Text -> Parser Text +symbol = Lexer.symbol space + +space :: Parser () +space = Lexer.space space1 (Lexer.skipLineComment "//") + $ Lexer.skipBlockComment "/*" "*/" + +lexeme :: forall a. Parser a -> Parser a +lexeme = Lexer.lexeme space + +blockP :: forall a. Parser a -> Parser a +blockP = between (symbol "{") (symbol "}") + +parensP :: forall a. Parser a -> Parser a +parensP = between (symbol "(") (symbol ")") + +bracketsP :: forall a. Parser a -> Parser a +bracketsP = between (symbol "[") (symbol "]") + +colonP :: Parser () +colonP = void $ symbol ":" + +commaP :: Parser () +commaP = void $ symbol "," + +semicolonP :: Parser () +semicolonP = void $ symbol ";" + +integerP :: Integral a => Parser a +integerP = lexeme Lexer.decimal + +identifierP :: Parser Identifier +identifierP = + let wordParser = (:) <$> letterChar <*> many alphaNumChar "identifier" + in fmap Identifier $ lexeme $ Text.pack <$> wordParser + +procedureP :: Parser () +procedureP = void $ symbol "proc" + +parameterP :: Parser Parameter +parameterP = paramCons + <$> optional (symbol "ref") + <*> identifierP + <*> (colonP *> typeExpressionP) + where + paramCons ref name typeName = Parameter name typeName (isJust ref) + +typeExpressionP :: Parser TypeExpression +typeExpressionP = arrayTypeExpression + <|> NamedType <$> identifierP + "type expression" + where + arrayTypeExpression = ArrayType + <$> (symbol "array" *> bracketsP integerP) + <*> (symbol "of" *> typeExpressionP) + +procedureDeclarationP :: Parser Declaration +procedureDeclarationP = procedureCons + <$> (procedureP *> identifierP) + <*> parensP (sepBy parameterP commaP) + <*> blockP ((,) <$> many variableDeclarationP <*> many statementP) + "procedure definition" + where + procedureCons procedureName parameters (variables, body) = + ProcedureDeclaration procedureName parameters variables body + +statementP :: Parser Statement +statementP + = EmptyStatement <$ semicolonP + {-<|> CompoundStatement <$> blockP (many statementP) + <|> try assignmentP + <|> try ifElseP + <|> try whileP -} + <|> try callP + "statement" + where + callP = CallStatement + <$> identifierP + <*> parensP (sepBy expressionP commaP) + <* semicolonP + {-ifElseP = IfStatement + <$> (symbol "if" *> parensP conditionP) + <*> statementP + <*> optional (symbol "else" *> statementP) + whileP = WhileStatement + <$> (symbol "while" *> parensP conditionP) + <*> statementP + assignmentP = AssignmentStatement + <$> variableAccessP + <* symbol ":=" + <*> expressionP + <* semicolonP -} + +variableDeclarationP :: Parser VariableDeclaration +variableDeclarationP = VariableDeclaration + <$> (symbol "var" *> identifierP) + <*> (colonP *> typeExpressionP) + <* semicolonP + "variable declaration" + +declarationP :: Parser Declaration +declarationP = procedureDeclarationP -- <|> typeDefinitionP + +programP :: Parser Program +programP = Program <$> many declarationP <* eof diff --git a/lib/Language/Elna/Frontend/SymbolTable.hs b/lib/Language/Elna/Frontend/SymbolTable.hs new file mode 100644 index 0000000..9ace33f --- /dev/null +++ b/lib/Language/Elna/Frontend/SymbolTable.hs @@ -0,0 +1,88 @@ +module Language.Elna.Frontend.SymbolTable + ( SymbolTable + , Info(..) + , ParameterInfo(..) + , builtInSymbolTable + , empty + , enter + , fromList + , lookup + , member + , scope + , toMap + , update + ) where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (isJust) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Language.Elna.Location (Identifier(..)) +import Language.Elna.Frontend.Types (Type(..), intType) +import Prelude hiding (lookup) + +data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info) + deriving (Eq, Show) + +empty :: SymbolTable +empty = SymbolTable Nothing HashMap.empty + +update :: (Info -> Maybe Info) -> Identifier -> SymbolTable -> SymbolTable +update updater key (SymbolTable parent mappings) = SymbolTable parent + $ HashMap.update updater key mappings + +scope :: SymbolTable -> SymbolTable -> SymbolTable +scope parent (SymbolTable _ mappings) = SymbolTable (Just parent) mappings + +builtInSymbolTable :: SymbolTable +builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList + [ ("printi", ProcedureInfo empty Vector.empty) + , ("int", TypeInfo intType) + ] + +toMap :: SymbolTable -> HashMap Identifier Info +toMap (SymbolTable _ map') = map' + +enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable +enter identifier info table@(SymbolTable parent hashTable) + | member identifier table = Nothing + | otherwise = Just + $ SymbolTable parent (HashMap.insert identifier info hashTable) + +lookup :: Identifier -> SymbolTable -> Maybe Info +lookup identifier (SymbolTable parent table) + | Just found <- HashMap.lookup identifier table = Just found + | Just parent' <- parent = lookup identifier parent' + | otherwise = Nothing + +member :: Identifier -> SymbolTable -> Bool +member identifier table = + isJust $ lookup identifier table + +fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable +fromList elements + | Just identifierDuplicates' <- identifierDuplicates = + Left identifierDuplicates' + | otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements + where + identifierDuplicates = NonEmpty.nonEmpty + $ fmap NonEmpty.head + $ filter ((> 1) . NonEmpty.length) + $ NonEmpty.group . sort + $ fst <$> elements + +data ParameterInfo = ParameterInfo + { name :: Identifier + , type' :: Type + , isReferenceParameter :: Bool + } deriving (Eq, Show) + +data Info + = TypeInfo Type + | VariableInfo Bool Type + | ProcedureInfo SymbolTable (Vector ParameterInfo) + deriving (Eq, Show) diff --git a/lib/Language/Elna/Frontend/TypeAnalysis.hs b/lib/Language/Elna/Frontend/TypeAnalysis.hs new file mode 100644 index 0000000..7d0b050 --- /dev/null +++ b/lib/Language/Elna/Frontend/TypeAnalysis.hs @@ -0,0 +1,186 @@ +module Language.Elna.Frontend.TypeAnalysis + ( typeAnalysis + , -- Error(..) + ) where + +import qualified Language.Elna.Frontend.AST as AST +import Language.Elna.Frontend.SymbolTable ({-Info(..), ParameterInfo(..), -}SymbolTable) + +typeAnalysis :: SymbolTable -> AST.Program -> () -- Maybe Error +typeAnalysis _globalTable = const () {- either Just (const Nothing) + . runExcept + . flip runReaderT globalTable + . runTypeAnalysis + . program -} + +{- +import Control.Applicative (Alternative(..)) +import Control.Monad.Trans.Except (Except, runExcept, throwE) +import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT, withReaderT, ask) +import qualified Data.Vector as Vector +import Language.Elna.Location (Identifier(..)) +import qualified Language.Elna.SymbolTable as SymbolTable +import Language.Elna.Types (Type(..), booleanType, intType) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad (unless, when) +import Data.Foldable (traverse_) + +data Error + = ArithmeticExpressionError Type + | ComparisonExpressionError Type Type + | UnexpectedVariableInfoError Info + | UnexpectedProcedureInfoError Info + | UndefinedSymbolError Identifier + | InvalidConditionTypeError Type + | InvalidAssignmentError Type + | ExpectedLvalueError AST.Expression + | ParameterCountMismatchError Int Int + | ArgumentTypeMismatchError Type Type + | ArrayIndexError Type + | ArrayAccessError Type + deriving (Eq, Show) + +newtype TypeAnalysis a = TypeAnalysis + { runTypeAnalysis :: ReaderT SymbolTable (Except Error) a + } + +instance Functor TypeAnalysis + where + fmap f (TypeAnalysis x) = TypeAnalysis $ f <$> x + +instance Applicative TypeAnalysis + where + pure = TypeAnalysis . pure + (TypeAnalysis f) <*> (TypeAnalysis x) = TypeAnalysis $ f <*> x + +instance Monad TypeAnalysis + where + (TypeAnalysis x) >>= f = TypeAnalysis $ x >>= (runTypeAnalysis . f) + +program :: AST.Program -> TypeAnalysis () +program (AST.Program declarations) = traverse_ declaration declarations + +declaration :: AST.Declaration -> TypeAnalysis () +declaration (AST.ProcedureDefinition procedureName _ _ body) = do + globalTable <- TypeAnalysis ask + case SymbolTable.lookup procedureName globalTable of + Just (ProcedureInfo localTable _) -> TypeAnalysis + $ withReaderT (const localTable) + $ runTypeAnalysis + $ traverse_ (statement globalTable) body + Just anotherInfo -> TypeAnalysis $ lift $ throwE + $ UnexpectedProcedureInfoError anotherInfo + Nothing -> TypeAnalysis $ lift $ throwE + $ UndefinedSymbolError procedureName +declaration _ = pure () + +statement :: SymbolTable -> AST.Statement -> TypeAnalysis () +statement globalTable = \case + AST.EmptyStatement -> pure () + AST.AssignmentStatement lhs rhs -> do + lhsType <- variableAccess globalTable lhs + rhsType <- expression globalTable rhs + unless (lhsType == intType) + $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType + unless (rhsType == intType) + $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType + AST.IfStatement ifCondition ifStatement elseStatement -> do + conditionType <- condition globalTable ifCondition + unless (conditionType == booleanType) + $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType + statement globalTable ifStatement + maybe (pure ()) (statement globalTable) elseStatement + AST.WhileStatement whileCondition whileStatement -> do + conditionType <- condition globalTable whileCondition + unless (conditionType == booleanType) + $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType + statement globalTable whileStatement + AST.CompoundStatement statements -> traverse_ (statement globalTable) statements + AST.CallStatement procedureName arguments -> + case SymbolTable.lookup procedureName globalTable of + Just (ProcedureInfo _ parameters) + | parametersLength <- Vector.length parameters + , argumentsLength <- length arguments + , Vector.length parameters /= length arguments -> TypeAnalysis $ lift $ throwE + $ ParameterCountMismatchError parametersLength argumentsLength + | otherwise -> traverse_ (uncurry checkArgument) + $ Vector.zip parameters (Vector.fromList arguments) + Just anotherInfo -> TypeAnalysis $ lift $ throwE + $ UnexpectedVariableInfoError anotherInfo + Nothing -> TypeAnalysis $ lift $ throwE + $ UndefinedSymbolError procedureName + where + checkArgument ParameterInfo{..} argument = do + argumentType <- expression globalTable argument + unless (argumentType == type') + $ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType + when (isReferenceParameter && not (isLvalue argument)) + $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument + isLvalue (AST.VariableExpression _) = True + isLvalue _ = False + +variableAccess :: SymbolTable -> AST.VariableAccess -> TypeAnalysis Type +variableAccess globalTable (AST.VariableAccess identifier) = do + localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier + case localLookup <|> SymbolTable.lookup identifier globalTable of + Just (VariableInfo _ variableType) -> pure variableType + Just anotherInfo -> TypeAnalysis $ lift $ throwE + $ UnexpectedVariableInfoError anotherInfo + Nothing -> TypeAnalysis $ lift $ throwE + $ UndefinedSymbolError identifier +variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = do + arrayType <- variableAccess globalTable arrayExpression + indexType <- expression globalTable indexExpression + unless (indexType == intType) + $ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType + case arrayType of + ArrayType _ baseType -> pure baseType + nonArrayType -> TypeAnalysis $ lift $ throwE + $ ArrayAccessError nonArrayType + +expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type +expression globalTable = \case + AST.VariableExpression variableExpression -> do + variableAccess globalTable variableExpression + AST.LiteralExpression literal' -> literal literal' + AST.NegationExpression negation -> do + operandType <- expression globalTable negation + if operandType == intType + then pure intType + else TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError operandType + AST.SumExpression lhs rhs -> arithmeticExpression lhs rhs + AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs + AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs + AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs + where + arithmeticExpression lhs rhs = do + lhsType <- expression globalTable lhs + unless (lhsType == intType) + $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError lhsType + rhsType <- expression globalTable rhs + unless (rhsType == intType) + $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError rhsType + pure intType + +condition :: SymbolTable -> AST.Condition -> TypeAnalysis Type +condition globalTable = \case + AST.EqualCondition lhs rhs -> comparisonExpression lhs rhs + AST.NonEqualCondition lhs rhs -> comparisonExpression lhs rhs + AST.LessCondition lhs rhs -> comparisonExpression lhs rhs + AST.GreaterCondition lhs rhs -> comparisonExpression lhs rhs + AST.LessOrEqualCondition lhs rhs -> comparisonExpression lhs rhs + AST.GreaterOrEqualCondition lhs rhs -> comparisonExpression lhs rhs + where + comparisonExpression lhs rhs = do + lhsType <- expression globalTable lhs + rhsType <- expression globalTable rhs + if lhsType == intType && rhsType == intType + then pure booleanType + else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType + +literal :: AST.Literal -> TypeAnalysis Type +literal (AST.IntegerLiteral _) = pure intType +literal (AST.HexadecimalLiteral _) = pure intType +literal (AST.CharacterLiteral _) = pure intType +literal (AST.BooleanLiteral _) = pure booleanType +-} diff --git a/lib/Language/Elna/Frontend/Types.hs b/lib/Language/Elna/Frontend/Types.hs new file mode 100644 index 0000000..a3cc730 --- /dev/null +++ b/lib/Language/Elna/Frontend/Types.hs @@ -0,0 +1,29 @@ +module Language.Elna.Frontend.Types + ( Type(..) + , addressByteSize + , booleanType + , intType + ) where + +import Data.Text (Text) +import Data.Word (Word32) +import Language.Elna.Location (showArrayType) + +addressByteSize :: Int +addressByteSize = 4 + +data Type + = PrimitiveType Text Int + | ArrayType Word32 Type + deriving Eq + +instance Show Type + where + show (PrimitiveType typeName _) = show typeName + show (ArrayType elementCount typeName) = showArrayType elementCount typeName + +intType :: Type +intType = PrimitiveType "int" 4 + +booleanType :: Type +booleanType = PrimitiveType "boolean" 1 diff --git a/lib/Language/Elna/Glue.hs b/lib/Language/Elna/Glue.hs new file mode 100644 index 0000000..2313b2b --- /dev/null +++ b/lib/Language/Elna/Glue.hs @@ -0,0 +1,270 @@ +module Language.Elna.Glue + ( glue + ) where + +import Control.Monad.Trans.State (State, get, modify', runState) +import Data.Bifunctor (Bifunctor(..)) +import Data.Foldable (Foldable(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (catMaybes) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Word (Word32) +import qualified Language.Elna.Frontend.AST as AST +import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..), Variable(..)) +import Language.Elna.Frontend.SymbolTable (SymbolTable{-, Info(..) -}) + +newtype Glue a = Glue + { runGlue :: State Word32 a } + +instance Functor Glue + where + fmap f (Glue x) = Glue $ f <$> x + +instance Applicative Glue + where + pure = Glue . pure + (Glue f) <*> (Glue x) = Glue $ f <*> x + +instance Monad Glue + where + (Glue x) >>= f = Glue $ x >>= (runGlue . f) + +glue :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable)) +glue globalTable + = fst + . flip runState 0 + . runGlue + . program globalTable + +program + :: SymbolTable + -> AST.Program + -> Glue (HashMap AST.Identifier (Vector (Quadruple Variable))) +program globalTable (AST.Program declarations) = HashMap.fromList . catMaybes + <$> traverse (declaration globalTable) declarations + +declaration + :: SymbolTable + -> AST.Declaration + -> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable))) +declaration globalTable (AST.ProcedureDeclaration procedureName _ _ statements) + = Just + . (procedureName,) + . Vector.cons StartQuadruple + . flip Vector.snoc StopQuadruple + . fold + <$> traverse (statement globalTable) statements +-- declaration (AST.TypeDefinition _ _) accumulator = pure accumulator + +statement :: SymbolTable -> AST.Statement -> Glue (Vector (Quadruple Variable)) +statement _ AST.EmptyStatement = pure mempty +statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do + visitedArguments <- traverse (expression localTable) arguments + let (parameterStatements, argumentStatements) + = bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat + $ unzip visitedArguments + in pure + $ Vector.snoc (argumentStatements <> parameterStatements) + $ CallQuadruple callName + $ fromIntegral + $ Vector.length argumentStatements +{- statement localTable (AST.AssignmentStatement variableAccess' assignee) = do + (rhsOperand, rhsStatements) <- expression localTable assignee + let variableType' = variableType variableAccess' localTable + accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty + pure $ rhsStatements <> case accessResult of + (AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) -> + Vector.snoc accumulatedStatements + $ ArrayAssignQuadruple rhsOperand accumulatedIndex + $ Variable identifier + (AST.Identifier identifier, Nothing, accumulatedStatements) -> + Vector.snoc accumulatedStatements + $ AssignQuadruple rhsOperand + $ Variable identifier +statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do + (conditionStatements, jumpConstructor) <- condition localTable ifCondition + ifLabel <- createLabel + endLabel <- createLabel + ifStatements <- statement localTable ifStatement + possibleElseStatements <- traverse (statement localTable) elseStatement + pure $ conditionStatements <> case possibleElseStatements of + Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements + <> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel] + <> Vector.snoc ifStatements (LabelQuadruple endLabel) + Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel] + <> Vector.snoc ifStatements (LabelQuadruple endLabel) +statement localTable (AST.WhileStatement whileCondition whileStatement) = do + (conditionStatements, jumpConstructor) <- condition localTable whileCondition + startLabel <- createLabel + endLabel <- createLabel + conditionLabel <- createLabel + whileStatements <- statement localTable whileStatement + pure $ Vector.fromList [LabelQuadruple conditionLabel] + <> conditionStatements + <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel] + <> whileStatements + <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel] +statement localTable (AST.CompoundStatement statements) = + fold <$> traverse (statement localTable) statements -} + +createTemporary :: Glue Variable +createTemporary = do + currentCounter <- Glue get + Glue $ modify' (+ 1) + pure $ TempVariable currentCounter + +{- +import Language.Elna.Types (Type(..)) +import qualified Language.Elna.SymbolTable as SymbolTable +import GHC.Records (HasField(..)) +import qualified Data.Text.Lazy.Builder.Int as Text.Builder +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Text.Lazy as Text.Lazy + +newtype Label = Label Text + deriving Eq + +instance Show Label + where + show (Label label) = '.' : Text.unpack label + +createLabel :: Glue Label +createLabel = do + currentCounter <- Glue $ gets labelCounter + Glue $ modify' modifier + pure + $ Label + $ Text.Lazy.toStrict + $ Text.Builder.toLazyText + $ Text.Builder.decimal currentCounter + where + modifier generator = generator + { labelCounter = getField @"labelCounter" generator + 1 + } + +condition + :: SymbolTable + -> AST.Condition + -> Glue (Vector Quadruple, Label -> Quadruple) +condition localTable (AST.EqualCondition lhs rhs) = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + pure + ( lhsStatements <> rhsStatements + , EqualQuadruple lhsOperand rhsOperand + ) +condition localTable (AST.NonEqualCondition lhs rhs) = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + pure + ( lhsStatements <> rhsStatements + , NonEqualQuadruple lhsOperand rhsOperand + ) +condition localTable (AST.LessCondition lhs rhs) = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand) +condition localTable (AST.GreaterCondition lhs rhs) = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + pure + ( lhsStatements <> rhsStatements + , GreaterQuadruple lhsOperand rhsOperand + ) +condition localTable (AST.LessOrEqualCondition lhs rhs) = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + pure + ( lhsStatements <> rhsStatements + , LessOrEqualQuadruple lhsOperand rhsOperand + ) +condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + pure + ( lhsStatements <> rhsStatements + , GreaterOrEqualQuadruple lhsOperand rhsOperand + ) + +variableAccess + :: SymbolTable + -> AST.VariableAccess + -> Maybe Operand + -> Type + -> Vector Quadruple + -> Glue (AST.Identifier, Maybe Operand, Vector Quadruple) +variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements = + pure (identifier, accumulatedIndex, accumulatedStatements) +variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = do + (indexPlace, statements) <- expression localTable index1 + variableAccess localTable access1 (Just indexPlace) baseType statements +variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = do + (indexPlace, statements') <- expression localTable arrayIndex + resultVariable <- createTemporary + let resultOperand = VariableOperand resultVariable + indexCalculation = Vector.fromList + [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable + , AddQuadruple indexPlace resultOperand resultVariable + ] + in variableAccess localTable arrayAccess' (Just resultOperand) baseType + $ statements <> indexCalculation <> statements' +variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type." + +variableType :: AST.VariableAccess -> SymbolTable -> Type +variableType (AST.VariableAccess identifier) symbolTable + | Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type' + | otherwise = error "Undefined type." +variableType (AST.ArrayAccess arrayAccess' _) symbolTable = + variableType arrayAccess' symbolTable +-} +expression :: SymbolTable -> AST.Expression -> Glue (Operand Variable, Vector (Quadruple Variable)) +expression localTable = \case + (AST.LiteralExpression literal') -> pure (literal literal', mempty) + (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs + (AST.SubtractionExpression lhs rhs) -> + binaryExpression SubtractionQuadruple lhs rhs + (AST.NegationExpression negation) -> do + (operand, statements) <- expression localTable negation + tempVariable <- createTemporary + let negationQuadruple = NegationQuadruple operand tempVariable + pure + ( VariableOperand tempVariable + , Vector.snoc statements negationQuadruple + ) +{- (AST.VariableExpression variableExpression) -> do + let variableType' = variableType variableExpression localTable + variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty + case variableAccess' of + (AST.Identifier identifier, Nothing, statements) -> + pure (VariableOperand (Variable identifier), statements) + (AST.Identifier identifier, Just operand, statements) -> do + arrayAddress <- createTemporary + let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress + pure + ( VariableOperand arrayAddress + , Vector.snoc statements arrayStatement + ) + (AST.ProductExpression lhs rhs) -> + binaryExpression ProductQuadruple lhs rhs + (AST.DivisionExpression lhs rhs) -> + binaryExpression DivisionQuadruple lhs rhs -} + where + binaryExpression f lhs rhs = do + (lhsOperand, lhsStatements) <- expression localTable lhs + (rhsOperand, rhsStatements) <- expression localTable rhs + tempVariable <- createTemporary + let newQuadruple = f lhsOperand rhsOperand tempVariable + pure + ( VariableOperand tempVariable + , Vector.snoc (lhsStatements <> rhsStatements) newQuadruple + ) + +literal :: AST.Literal -> Operand Variable +literal (AST.IntegerLiteral integer) = IntOperand integer +{-literal (AST.HexadecimalLiteral integer) = IntOperand integer +literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character +literal (AST.BooleanLiteral boolean) + | boolean = IntOperand 1 + | otherwise = IntOperand 0 -} diff --git a/lib/Language/Elna/Intermediate.hs b/lib/Language/Elna/Intermediate.hs deleted file mode 100644 index 32c951e..0000000 --- a/lib/Language/Elna/Intermediate.hs +++ /dev/null @@ -1,311 +0,0 @@ -module Language.Elna.Intermediate - ( Operand(..) - , Quadruple(..) - {- , Label(..) -} - , Variable(..) - , intermediate - ) where - -import Data.Bifunctor (Bifunctor(..)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Data.Int (Int32) -import Data.Word (Word32) -import Data.Text (Text) -import qualified Language.Elna.AST as AST -import Language.Elna.SymbolTable (SymbolTable{-, Info(..) -}) -import Data.Foldable (Foldable(..)) -import Control.Monad.Trans.State (State, get, modify', runState) -import Data.Maybe (catMaybes) - -newtype Variable = TempVariable Word32 -- | Variable Text - deriving Eq - -instance Show Variable - where - -- show (Variable variable) = '$' : Text.unpack variable - show (TempVariable variable) = '$' : show variable - -data Operand v - = IntOperand Int32 - | VariableOperand v - deriving (Eq, Show) - -data Quadruple v - = StartQuadruple - | StopQuadruple - | ParameterQuadruple (Operand v) - | CallQuadruple Text Word32 - | AddQuadruple (Operand v) (Operand v) v - | SubtractionQuadruple (Operand v) (Operand v) v - {-| GoToQuadruple Label - | AssignQuadruple Operand Variable - | ArrayQuadruple Variable Operand Variable - | ArrayAssignQuadruple Operand Operand Variable - | ProductQuadruple Operand Operand Variable - | DivisionQuadruple Operand Operand Variable - | NegationQuadruple Operand Variable - | EqualQuadruple Operand Operand Label - | NonEqualQuadruple Operand Operand Label - | LessQuadruple Operand Operand Label - | GreaterQuadruple Operand Operand Label - | LessOrEqualQuadruple Operand Operand Label - | GreaterOrEqualQuadruple Operand Operand Label - | LabelQuadruple Label -} - deriving (Eq, Show) - -newtype Intermediate a = Intermediate - { runIntermediate :: State Word32 a } - -instance Functor Intermediate - where - fmap f (Intermediate x) = Intermediate $ f <$> x - -instance Applicative Intermediate - where - pure = Intermediate . pure - (Intermediate f) <*> (Intermediate x) = Intermediate $ f <*> x - -instance Monad Intermediate - where - (Intermediate x) >>= f = Intermediate $ x >>= (runIntermediate . f) - -intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable)) -intermediate globalTable - = fst - . flip runState 0 - . runIntermediate - . program globalTable - -program - :: SymbolTable - -> AST.Program - -> Intermediate (HashMap AST.Identifier (Vector (Quadruple Variable))) -program globalTable (AST.Program declarations) = HashMap.fromList . catMaybes - <$> traverse (declaration globalTable) declarations - -declaration - :: SymbolTable - -> AST.Declaration - -> Intermediate (Maybe (AST.Identifier, Vector (Quadruple Variable))) -declaration globalTable (AST.ProcedureDeclaration procedureName _ _ statements) - = Just - . (procedureName,) - . Vector.cons StartQuadruple - . flip Vector.snoc StopQuadruple - . fold - <$> traverse (statement globalTable) statements --- declaration (AST.TypeDefinition _ _) accumulator = pure accumulator - -statement :: SymbolTable -> AST.Statement -> Intermediate (Vector (Quadruple Variable)) -statement _ AST.EmptyStatement = pure mempty -statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do - visitedArguments <- traverse (expression localTable) arguments - let (parameterStatements, argumentStatements) - = bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat - $ unzip visitedArguments - in pure - $ Vector.snoc (argumentStatements <> parameterStatements) - $ CallQuadruple callName - $ fromIntegral - $ Vector.length argumentStatements -{- statement localTable (AST.AssignmentStatement variableAccess' assignee) = do - (rhsOperand, rhsStatements) <- expression localTable assignee - let variableType' = variableType variableAccess' localTable - accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty - pure $ rhsStatements <> case accessResult of - (AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) -> - Vector.snoc accumulatedStatements - $ ArrayAssignQuadruple rhsOperand accumulatedIndex - $ Variable identifier - (AST.Identifier identifier, Nothing, accumulatedStatements) -> - Vector.snoc accumulatedStatements - $ AssignQuadruple rhsOperand - $ Variable identifier -statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do - (conditionStatements, jumpConstructor) <- condition localTable ifCondition - ifLabel <- createLabel - endLabel <- createLabel - ifStatements <- statement localTable ifStatement - possibleElseStatements <- traverse (statement localTable) elseStatement - pure $ conditionStatements <> case possibleElseStatements of - Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements - <> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel] - <> Vector.snoc ifStatements (LabelQuadruple endLabel) - Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel] - <> Vector.snoc ifStatements (LabelQuadruple endLabel) -statement localTable (AST.WhileStatement whileCondition whileStatement) = do - (conditionStatements, jumpConstructor) <- condition localTable whileCondition - startLabel <- createLabel - endLabel <- createLabel - conditionLabel <- createLabel - whileStatements <- statement localTable whileStatement - pure $ Vector.fromList [LabelQuadruple conditionLabel] - <> conditionStatements - <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel] - <> whileStatements - <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel] -statement localTable (AST.CompoundStatement statements) = - fold <$> traverse (statement localTable) statements -} - -createTemporary :: Intermediate Variable -createTemporary = do - currentCounter <- Intermediate get - Intermediate $ modify' (+ 1) - pure $ TempVariable currentCounter - -{- -import Language.Elna.Types (Type(..)) -import qualified Language.Elna.SymbolTable as SymbolTable -import GHC.Records (HasField(..)) -import qualified Data.Text.Lazy.Builder.Int as Text.Builder -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Data.Text.Lazy as Text.Lazy - -newtype Label = Label Text - deriving Eq - -instance Show Label - where - show (Label label) = '.' : Text.unpack label - -createLabel :: Intermediate Label -createLabel = do - currentCounter <- Intermediate $ gets labelCounter - Intermediate $ modify' modifier - pure - $ Label - $ Text.Lazy.toStrict - $ Text.Builder.toLazyText - $ Text.Builder.decimal currentCounter - where - modifier generator = generator - { labelCounter = getField @"labelCounter" generator + 1 - } - -condition - :: SymbolTable - -> AST.Condition - -> Intermediate (Vector Quadruple, Label -> Quadruple) -condition localTable (AST.EqualCondition lhs rhs) = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - pure - ( lhsStatements <> rhsStatements - , EqualQuadruple lhsOperand rhsOperand - ) -condition localTable (AST.NonEqualCondition lhs rhs) = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - pure - ( lhsStatements <> rhsStatements - , NonEqualQuadruple lhsOperand rhsOperand - ) -condition localTable (AST.LessCondition lhs rhs) = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand) -condition localTable (AST.GreaterCondition lhs rhs) = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - pure - ( lhsStatements <> rhsStatements - , GreaterQuadruple lhsOperand rhsOperand - ) -condition localTable (AST.LessOrEqualCondition lhs rhs) = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - pure - ( lhsStatements <> rhsStatements - , LessOrEqualQuadruple lhsOperand rhsOperand - ) -condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - pure - ( lhsStatements <> rhsStatements - , GreaterOrEqualQuadruple lhsOperand rhsOperand - ) - -variableAccess - :: SymbolTable - -> AST.VariableAccess - -> Maybe Operand - -> Type - -> Vector Quadruple - -> Intermediate (AST.Identifier, Maybe Operand, Vector Quadruple) -variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements = - pure (identifier, accumulatedIndex, accumulatedStatements) -variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = do - (indexPlace, statements) <- expression localTable index1 - variableAccess localTable access1 (Just indexPlace) baseType statements -variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = do - (indexPlace, statements') <- expression localTable arrayIndex - resultVariable <- createTemporary - let resultOperand = VariableOperand resultVariable - indexCalculation = Vector.fromList - [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable - , AddQuadruple indexPlace resultOperand resultVariable - ] - in variableAccess localTable arrayAccess' (Just resultOperand) baseType - $ statements <> indexCalculation <> statements' -variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type." - -variableType :: AST.VariableAccess -> SymbolTable -> Type -variableType (AST.VariableAccess identifier) symbolTable - | Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type' - | otherwise = error "Undefined type." -variableType (AST.ArrayAccess arrayAccess' _) symbolTable = - variableType arrayAccess' symbolTable --} -expression :: SymbolTable -> AST.Expression -> Intermediate (Operand Variable, Vector (Quadruple Variable)) -expression localTable = \case - (AST.LiteralExpression literal') -> pure (literal literal', mempty) - (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs - (AST.SubtractionExpression lhs rhs) -> - binaryExpression SubtractionQuadruple lhs rhs -{- (AST.VariableExpression variableExpression) -> do - let variableType' = variableType variableExpression localTable - variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty - case variableAccess' of - (AST.Identifier identifier, Nothing, statements) -> - pure (VariableOperand (Variable identifier), statements) - (AST.Identifier identifier, Just operand, statements) -> do - arrayAddress <- createTemporary - let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress - pure - ( VariableOperand arrayAddress - , Vector.snoc statements arrayStatement - ) - (AST.NegationExpression negation) -> do - (operand, statements) <- expression localTable negation - tempVariable <- createTemporary - let negationQuadruple = NegationQuadruple operand tempVariable - pure - ( VariableOperand tempVariable - , Vector.snoc statements negationQuadruple - ) - (AST.ProductExpression lhs rhs) -> - binaryExpression ProductQuadruple lhs rhs - (AST.DivisionExpression lhs rhs) -> - binaryExpression DivisionQuadruple lhs rhs -} - where - binaryExpression f lhs rhs = do - (lhsOperand, lhsStatements) <- expression localTable lhs - (rhsOperand, rhsStatements) <- expression localTable rhs - tempVariable <- createTemporary - let newQuadruple = f lhsOperand rhsOperand tempVariable - pure - ( VariableOperand tempVariable - , Vector.snoc (lhsStatements <> rhsStatements) newQuadruple - ) - -literal :: AST.Literal -> Operand Variable -literal (AST.IntegerLiteral integer) = IntOperand integer -{-literal (AST.HexadecimalLiteral integer) = IntOperand integer -literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character -literal (AST.BooleanLiteral boolean) - | boolean = IntOperand 1 - | otherwise = IntOperand 0 -} diff --git a/lib/Language/Elna/NameAnalysis.hs b/lib/Language/Elna/NameAnalysis.hs deleted file mode 100644 index 10045e9..0000000 --- a/lib/Language/Elna/NameAnalysis.hs +++ /dev/null @@ -1,216 +0,0 @@ -module Language.Elna.NameAnalysis - ( nameAnalysis - , Error(..) - ) where - -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Vector as Vector -import qualified Language.Elna.SymbolTable as SymbolTable -import qualified Language.Elna.AST as AST -import Language.Elna.SymbolTable - ( SymbolTable - , Info(..) - , ParameterInfo(..) - ) -import Control.Monad.Trans.Except (Except, runExcept, throwE) -import Data.Functor ((<&>)) -import Language.Elna.Location (Identifier(..)) -import Language.Elna.Types (Type(..)) -import Data.Foldable (traverse_) -import Control.Monad (foldM, unless) - -data Error - = UndefinedTypeError Identifier - | UnexpectedTypeInfoError Info - | IdentifierAlreadyDefinedError Identifier - | UndefinedSymbolError Identifier - | UnexpectedArrayByValue Identifier - deriving Eq - -instance Show Error - where - show (UndefinedTypeError identifier) = - concat ["Type \"", show identifier, "\" is not defined"] - show (UnexpectedTypeInfoError info) = show info - <> " expected to be a type" - show (IdentifierAlreadyDefinedError identifier) = - concat ["The identifier \"", show identifier, "\" is already defined"] - show (UndefinedSymbolError identifier) = - concat ["Symbol \"", show identifier, "\" is not defined"] - show (UnexpectedArrayByValue identifier) = concat - [ "Array \"" - , show identifier - , "\" cannot be passed by value, only by reference" - ] - -newtype NameAnalysis a = NameAnalysis - { runNameAnalysis :: Except Error a - } - -instance Functor NameAnalysis - where - fmap f (NameAnalysis x) = NameAnalysis $ f <$> x - -instance Applicative NameAnalysis - where - pure = NameAnalysis . pure - (NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x - -instance Monad NameAnalysis - where - (NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f) - -nameAnalysis :: AST.Program -> Either Error SymbolTable -nameAnalysis = runExcept - . runNameAnalysis - . program SymbolTable.builtInSymbolTable - -program :: SymbolTable -> AST.Program -> NameAnalysis SymbolTable -program symbolTable (AST.Program declarations) = do - globalTable <- foldM procedureDeclaration symbolTable declarations - foldM declaration globalTable declarations - -procedureDeclaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable -procedureDeclaration globalTable (AST.ProcedureDeclaration identifier parameters _ _) = do - parametersInfo <- mapM (parameter globalTable) parameters - let procedureInfo = ProcedureInfo SymbolTable.empty - $ Vector.fromList parametersInfo - maybe (NameAnalysis $ throwE $ IdentifierAlreadyDefinedError identifier) pure - $ SymbolTable.enter identifier procedureInfo globalTable - -declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable -declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do - variableInfo <- mapM (variableDeclaration globalTable) variables - parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters - procedureTable <- fmap (SymbolTable.scope globalTable) - $ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure - $ SymbolTable.fromList - $ parameterInfo <> variableInfo - traverse_ (statement procedureTable) body - pure $ SymbolTable.update (updater procedureTable) identifier globalTable - where - updater procedureTable (ProcedureInfo _ parameters') = Just - $ ProcedureInfo procedureTable parameters' - updater _ _ = Nothing - -parameterToVariableInfo :: SymbolTable -> AST.Parameter -> NameAnalysis (Identifier, Info) -parameterToVariableInfo symbolTable (AST.Parameter identifier typeExpression isReferenceParameter') - = (identifier,) . VariableInfo isReferenceParameter' - <$> dataType symbolTable typeExpression - -variableDeclaration :: SymbolTable -> AST.VariableDeclaration -> NameAnalysis (Identifier, Info) -variableDeclaration globalTable (AST.VariableDeclaration identifier typeExpression) - = (identifier,) . VariableInfo False - <$> dataType globalTable typeExpression - -parameter :: SymbolTable -> AST.Parameter -> NameAnalysis ParameterInfo -parameter environmentSymbolTable (AST.Parameter identifier typeExpression isReferenceParameter') = do - parameterType <- dataType environmentSymbolTable typeExpression - case parameterType of - ArrayType _ _ - | not isReferenceParameter' -> NameAnalysis - $ throwE $ UnexpectedArrayByValue identifier - _ -> - let parameterInfo = ParameterInfo - { name = identifier - , type' = parameterType - , isReferenceParameter = isReferenceParameter' - } - in pure parameterInfo - -dataType :: SymbolTable -> AST.TypeExpression -> NameAnalysis Type -dataType environmentSymbolTable (AST.NamedType baseType) = do - case SymbolTable.lookup baseType environmentSymbolTable of - Just baseInfo - | TypeInfo baseType' <- baseInfo -> pure baseType' - | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo - _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType -dataType environmentSymbolTable (AST.ArrayType arraySize baseType) = - dataType environmentSymbolTable baseType <&> ArrayType arraySize - -checkSymbol :: SymbolTable -> Identifier -> NameAnalysis () -checkSymbol globalTable identifier - = unless (SymbolTable.member identifier globalTable) - $ NameAnalysis $ throwE - $ UndefinedSymbolError identifier - -expression :: SymbolTable -> AST.Expression -> NameAnalysis () -expression _ (AST.LiteralExpression _) = pure () -expression globalTable (AST.SumExpression lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -expression globalTable (AST.SubtractionExpression lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -{- expression globalTable (AST.VariableExpression variableExpression) = - variableAccess globalTable variableExpression -expression globalTable (AST.NegationExpression negation) = - expression globalTable negation -expression globalTable (AST.ProductExpression lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -expression globalTable (AST.DivisionExpression lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs --} -statement :: SymbolTable -> AST.Statement -> NameAnalysis () -statement _ AST.EmptyStatement = pure () -statement globalTable (AST.CallStatement name arguments) - = checkSymbol globalTable name - >> traverse_ (expression globalTable) arguments -{- statement globalTable (AST.AssignmentStatement lvalue rvalue) - = variableAccess globalTable lvalue - >> expression globalTable rvalue -statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement) - = condition globalTable ifCondition - >> statement globalTable ifStatement - >> maybe (pure ()) (statement globalTable) elseStatement -statement globalTable (AST.WhileStatement whileCondition loop) - = condition globalTable whileCondition - >> statement globalTable loop -statement globalTable (AST.CompoundStatement statements) = - traverse_ (statement globalTable) statements - -variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis () -variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) - = variableAccess globalTable arrayExpression - >> expression globalTable indexExpression -variableAccess globalTable (AST.VariableAccess identifier) = - checkSymbol globalTable identifier - -condition :: SymbolTable -> AST.Condition -> NameAnalysis () -condition globalTable (AST.EqualCondition lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -condition globalTable (AST.NonEqualCondition lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -condition globalTable (AST.LessCondition lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -condition globalTable (AST.GreaterCondition lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -condition globalTable (AST.LessOrEqualCondition lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs -condition globalTable (AST.GreaterOrEqualCondition lhs rhs) - = expression globalTable lhs - >> expression globalTable rhs - -enter :: Identifier -> Info -> SymbolTable -> NameAnalysis SymbolTable -enter identifier info table - = maybe (identifierAlreadyDefinedError identifier) pure - $ SymbolTable.enter identifier info table - -identifierAlreadyDefinedError :: Identifier -> NameAnalysis a -identifierAlreadyDefinedError = NameAnalysis - . lift - . throwE - . IdentifierAlreadyDefinedError - -variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info) -variableDeclaration (AST.VariableDeclaration identifier typeExpression) - = (identifier,) . VariableInfo False - <$> dataType typeExpression --} diff --git a/lib/Language/Elna/Parser.hs b/lib/Language/Elna/Parser.hs deleted file mode 100644 index 3c98fff..0000000 --- a/lib/Language/Elna/Parser.hs +++ /dev/null @@ -1,220 +0,0 @@ -module Language.Elna.Parser - ( Parser - , programP - ) where - -import Control.Monad (void) -import Control.Monad.Combinators.Expr (Operator(..), makeExprParser) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Void (Void) -import Language.Elna.AST - ( Declaration(..) - , Identifier(..) - , Parameter(..) - , Program(..) - , Statement(..) - , TypeExpression(..) - , VariableDeclaration(..) - {-, VariableAccess(..) - , Condition(..)-} - , Expression(..) - , Literal(..) - ) -import Text.Megaparsec - ( Parsec - , () - , MonadParsec(..) - , eof - , optional - , between - , sepBy - , choice - ) -import qualified Text.Megaparsec.Char.Lexer as Lexer -import Text.Megaparsec.Char - ( alphaNumChar --- , char - , letterChar - , space1 --- , string - ) -import Control.Applicative (Alternative(..)) -import Data.Maybe (isJust) --- import Data.Functor (($>)) - -type Parser = Parsec Void Text - -literalP :: Parser Literal -literalP - = {- HexadecimalLiteral <$> (string "0x" *> lexeme Lexer.hexadecimal) - <|> -} IntegerLiteral <$> lexeme Lexer.decimal - {- <|> CharacterLiteral <$> lexeme charP - <|> BooleanLiteral <$> (symbol "true" $> True) - <|> BooleanLiteral <$> (symbol "false" $> False) - where - charP = fromIntegral . fromEnum - <$> between (char '\'') (char '\'') Lexer.charLiteral -} -{- -typeDefinitionP :: Parser Declaration -typeDefinitionP = TypeDefinition - <$> (symbol "type" *> identifierP) - <*> (symbol "=" *> typeExpressionP) - <* semicolonP - "type definition" --} -termP :: Parser Expression -termP = choice - [ parensP expressionP - , LiteralExpression <$> literalP - -- , VariableExpression <$> variableAccessP - ] - -operatorTable :: [[Operator Parser Expression]] -operatorTable = - [{- unaryOperator - , factorOperator - ,-} termOperator - ] - where - {- unaryOperator = - [ prefix "-" NegationExpression - , prefix "+" id - ] - factorOperator = - [ binary "*" ProductExpression - , binary "/" DivisionExpression - ] -} - termOperator = - [ binary "+" SumExpression - , binary "-" SubtractionExpression - ] - -- prefix name f = Prefix (f <$ symbol name) - binary name f = InfixL (f <$ symbol name) - -expressionP :: Parser Expression -expressionP = makeExprParser termP operatorTable -{- -variableAccessP :: Parser VariableAccess -variableAccessP = do - identifier <- identifierP - indices <- many $ bracketsP expressionP - pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices - -conditionP :: Parser Condition -conditionP = do - lhs <- expressionP - conditionCons <- choice comparisonOperator - conditionCons lhs <$> expressionP - where - comparisonOperator = - [ symbol "<" >> pure LessCondition - , symbol "<=" >> pure LessOrEqualCondition - , symbol ">" >> pure GreaterCondition - , symbol ">=" >> pure GreaterOrEqualCondition - , symbol "=" >> pure EqualCondition - , symbol "#" >> pure NonEqualCondition - ] --} -symbol :: Text -> Parser Text -symbol = Lexer.symbol space - -space :: Parser () -space = Lexer.space space1 (Lexer.skipLineComment "//") - $ Lexer.skipBlockComment "/*" "*/" - -lexeme :: forall a. Parser a -> Parser a -lexeme = Lexer.lexeme space - -blockP :: forall a. Parser a -> Parser a -blockP = between (symbol "{") (symbol "}") - -parensP :: forall a. Parser a -> Parser a -parensP = between (symbol "(") (symbol ")") - -bracketsP :: forall a. Parser a -> Parser a -bracketsP = between (symbol "[") (symbol "]") - -colonP :: Parser () -colonP = void $ symbol ":" - -commaP :: Parser () -commaP = void $ symbol "," - -semicolonP :: Parser () -semicolonP = void $ symbol ";" - -identifierP :: Parser Identifier -identifierP = - let wordParser = (:) <$> letterChar <*> many alphaNumChar "identifier" - in fmap Identifier $ lexeme $ Text.pack <$> wordParser - -procedureP :: Parser () -procedureP = void $ symbol "proc" - -parameterP :: Parser Parameter -parameterP = paramCons - <$> optional (symbol "ref") - <*> identifierP - <*> (colonP *> typeExpressionP) - where - paramCons ref name typeName = Parameter name typeName (isJust ref) - -typeExpressionP :: Parser TypeExpression -typeExpressionP = arrayTypeExpression - <|> NamedType <$> identifierP - "type expression" - where - arrayTypeExpression = ArrayType - <$> (symbol "array" *> bracketsP (lexeme Lexer.decimal)) - <*> (symbol "of" *> typeExpressionP) - -procedureDeclarationP :: Parser Declaration -procedureDeclarationP = procedureCons - <$> (procedureP *> identifierP) - <*> parensP (sepBy parameterP commaP) - <*> blockP ((,) <$> many variableDeclarationP <*> many statementP) - "procedure definition" - where - procedureCons procedureName parameters (variables, body) = - ProcedureDeclaration procedureName parameters variables body - -statementP :: Parser Statement -statementP - = EmptyStatement <$ semicolonP - {-<|> CompoundStatement <$> blockP (many statementP) - <|> try assignmentP - <|> try ifElseP - <|> try whileP -} - <|> try callP - "statement" - where - callP = CallStatement - <$> identifierP - <*> parensP (sepBy expressionP commaP) - <* semicolonP - {-ifElseP = IfStatement - <$> (symbol "if" *> parensP conditionP) - <*> statementP - <*> optional (symbol "else" *> statementP) - whileP = WhileStatement - <$> (symbol "while" *> parensP conditionP) - <*> statementP - assignmentP = AssignmentStatement - <$> variableAccessP - <* symbol ":=" - <*> expressionP - <* semicolonP -} - -variableDeclarationP :: Parser VariableDeclaration -variableDeclarationP = VariableDeclaration - <$> (symbol "var" *> identifierP) - <*> (colonP *> typeExpressionP) - <* semicolonP - "variable declaration" - -declarationP :: Parser Declaration -declarationP = procedureDeclarationP -- <|> typeDefinitionP - -programP :: Parser Program -programP = Program <$> many declarationP <* eof diff --git a/lib/Language/Elna/PrinterWriter.hs b/lib/Language/Elna/PrinterWriter.hs deleted file mode 100644 index 40b60de..0000000 --- a/lib/Language/Elna/PrinterWriter.hs +++ /dev/null @@ -1,276 +0,0 @@ --- | Writer assembler to an object file. -module Language.Elna.PrinterWriter - ( riscv32Elf - ) where - -import Data.Word (Word8) -import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Builder as ByteString.Builder -import qualified Data.ByteString.Lazy as LazyByteString -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Language.Elna.Object.Elf - ( ByteOrder(..) - , Elf32_Addr - , Elf32_Ehdr(..) - , Elf32_Half - , Elf32_Word - , Elf32_Sym(..) - , ElfMachine(..) - , ElfType(..) - , ElfVersion(..) - , ElfIdentification(..) - , ElfClass(..) - , ElfData(..) - , Elf32_Shdr(..) - , ElfSectionType(..) - , ElfSymbolBinding(..) - , ElfSymbolType(..) - , Elf32_Rel(..) - , ElfWriter(..) - , ElfHeaderResult(..) - , elf32Sym - , elfHeaderSize - , elfSectionsSize - , stInfo - , rInfo - , elf32Rel - , shfInfoLink - , addSectionHeader - ) -import System.IO (Handle) -import qualified Language.Elna.Architecture.RiscV as RiscV -import qualified Data.Text.Encoding as Text.Encoding -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.State (get) -import Language.Elna.CodeGenerator (Statement(..)) -import qualified Data.HashSet as HashSet -import GHC.Records (HasField(..)) - -data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8 -data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word - -riscv32Elf :: Vector Statement -> Handle -> ElfWriter Elf32_Ehdr -riscv32Elf code objectHandle = text - >>= uncurry symrel - >>= strtab - >> shstrtab - >>= riscv32Header - where - shstrtab :: ElfWriter Elf32_Half - shstrtab = do - ElfHeaderResult{..} <- ElfWriter get - let stringTable = sectionNames <> ".shstrtab\0" - nextHeader = Elf32_Shdr - { sh_type = SHT_STRTAB - , sh_size = fromIntegral $ ByteString.length stringTable - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = fromIntegral $ ByteString.length sectionNames - , sh_link = 0 - , sh_info = 0 - , sh_flags = 0 - , sh_entsize = 0 - , sh_addralign = 1 - , sh_addr = 0 - } - liftIO $ ByteString.hPut objectHandle stringTable - addSectionHeader ".shstrtab" nextHeader - pure $ fromIntegral $ Vector.length sectionHeaders - riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr - riscv32Header shstrndx = do - ElfHeaderResult{..} <- ElfWriter get - pure $ Elf32_Ehdr - { e_version = EV_CURRENT - , e_type = ET_REL - , e_shstrndx = shstrndx - , e_shoff = elfSectionsSize sectionHeaders - , e_shnum = fromIntegral (Vector.length sectionHeaders) - , e_shentsize = 40 - , e_phoff = 0 - , e_phnum = 0 - , e_phentsize = 32 - , e_machine = EM_RISCV - , e_ident = ElfIdentification ELFCLASS32 ELFDATA2LSB - , e_flags = 0x4 -- EF_RISCV_FLOAT_ABI_DOUBLE - , e_entry = 0 - , e_ehsize = fromIntegral elfHeaderSize - } - takeStringZ stringTable Elf32_Sym{ st_name } - = ByteString.takeWhile (/= 0) - $ ByteString.drop (fromIntegral st_name) stringTable - resolveRelocation (ElfHeaderResult stringTable entries) unresolvedRelocation - | UnresolvedRelocation symbolName offset type' <- unresolvedRelocation - , Just entry <- Vector.findIndex ((== symbolName) . takeStringZ stringTable) entries = - Right $ Elf32_Rel - { r_offset = offset - , r_info = rInfo (fromIntegral entry) type' - } - | otherwise = Left unresolvedRelocation - symtab entries = do - ElfHeaderResult{..} <- ElfWriter get - let encodedSymbols = LazyByteString.toStrict - $ ByteString.Builder.toLazyByteString - $ foldMap (elf32Sym LSB) entries - symHeader = Elf32_Shdr - { sh_type = SHT_SYMTAB - , sh_size = fromIntegral $ ByteString.length encodedSymbols - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = fromIntegral $ ByteString.length sectionNames - , sh_link = fromIntegral $ Vector.length sectionHeaders + 2 - , sh_info = 1 - , sh_flags = 0 - , sh_entsize = 16 - , sh_addralign = 4 - , sh_addr = 0 - } - liftIO $ ByteString.hPut objectHandle encodedSymbols - addSectionHeader ".symtab" symHeader - pure $ fromIntegral $ Vector.length sectionHeaders - symrel symbols relocations = do - let UnresolvedRelocations relocationList index = relocations - ElfHeaderResult stringTable entries = symbols - - sectionHeadersLength <- symtab entries - ElfHeaderResult{..} <- ElfWriter get - - let encodedRelocations = LazyByteString.toStrict - $ ByteString.Builder.toLazyByteString - $ Vector.foldMap (either (const mempty) (elf32Rel LSB)) - $ resolveRelocation symbols <$> relocationList - relHeader = Elf32_Shdr - { sh_type = SHT_REL - , sh_size = fromIntegral $ ByteString.length encodedRelocations - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = fromIntegral $ ByteString.length sectionNames - , sh_link = sectionHeadersLength - , sh_info = index - , sh_flags = shfInfoLink - , sh_entsize = 8 - , sh_addralign = 4 - , sh_addr = 0 - } - liftIO $ ByteString.hPut objectHandle encodedRelocations - addSectionHeader ".rel.text" relHeader - pure stringTable - strtab stringTable = do - ElfHeaderResult{..} <- ElfWriter get - let strHeader = Elf32_Shdr - { sh_type = SHT_STRTAB - , sh_size = fromIntegral $ ByteString.length stringTable - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = fromIntegral $ ByteString.length sectionNames - , sh_link = 0 - , sh_info = 0 - , sh_flags = 0 - , sh_entsize = 0 - , sh_addralign = 1 - , sh_addr = 0 - } - liftIO $ ByteString.hPut objectHandle stringTable - addSectionHeader ".strtab" strHeader - text = do - ElfHeaderResult{..} <- ElfWriter get - let textTabIndex = fromIntegral $ Vector.length sectionHeaders - initialHeaders = ElfHeaderResult "\0" - $ Vector.singleton - $ Elf32_Sym - { st_value = 0 - , st_size = 0 - , st_shndx = 0 - , st_other = 0 - , st_name = 0 - , st_info = 0 - } - (encoded, updatedRelocations, symbols, definitions) = - encodeAsm textTabIndex (mempty, Vector.empty, initialHeaders, HashSet.empty) code - - filterPredicate = not - . (`ByteString.isInfixOf` getField @"sectionNames" symbols) - . ("\0" <>) . (<> "\0") - symbolResult = HashSet.foldl' encodeEmptyDefinitions symbols - $ HashSet.filter filterPredicate definitions - size = fromIntegral $ LazyByteString.length encoded - newHeader = Elf32_Shdr - { sh_type = SHT_PROGBITS - , sh_size = size - , sh_offset = elfSectionsSize sectionHeaders - , sh_name = fromIntegral $ ByteString.length sectionNames - , sh_link = 0 - , sh_info = 0 - , sh_flags = 0b110 - , sh_entsize = 0 - , sh_addralign = 4 - , sh_addr = 0 - } - liftIO $ ByteString.hPut objectHandle $ LazyByteString.toStrict encoded - addSectionHeader ".text" newHeader - pure (symbolResult, UnresolvedRelocations updatedRelocations $ fromIntegral $ Vector.length sectionHeaders) - encodeEmptyDefinitions (ElfHeaderResult names entries) definition = - let nextEntry = Elf32_Sym - { st_value = 0 - , st_size = 0 - , st_shndx = 0 - , st_other = 0 - , st_name = fromIntegral (ByteString.length names) - , st_info = stInfo STB_GLOBAL STT_FUNC - } - in ElfHeaderResult (names <> definition <> "\0") - $ Vector.snoc entries nextEntry - encodeAsm shndx (encoded, relocations, ElfHeaderResult names symbols, definitions) instructions - | Just (instruction, rest) <- Vector.uncons instructions = - case instruction of - Instruction _ -> - let (encoded', relocations', rest', definitions') = - encodeInstructions (encoded, relocations, instructions, definitions) - in encodeAsm shndx (encoded', relocations', ElfHeaderResult names symbols, definitions') rest' - JumpLabel labelName _ -> - let (encoded', relocations', rest', definitions') = - encodeInstructions (encoded, relocations, rest, definitions) - newEntry = Elf32_Sym - { st_value = fromIntegral $ LazyByteString.length encoded - , st_size = fromIntegral $ LazyByteString.length encoded' - , st_shndx = shndx - , st_other = 0 - , st_name = fromIntegral $ ByteString.length names - , st_info = stInfo STB_GLOBAL STT_FUNC - } - result = - ( encoded <> encoded' - , relocations <> relocations' - , ElfHeaderResult (names <> labelName <> "\0") (Vector.snoc symbols newEntry) - , definitions' - ) - in encodeAsm shndx result rest' - | otherwise = (encoded, relocations, ElfHeaderResult names symbols, definitions) - encodeInstructions (encoded, relocations, instructions, definitions) - | Just (Instruction instruction, rest) <- Vector.uncons instructions = - let offset = fromIntegral $ LazyByteString.length encoded - unresolvedRelocation = case instruction of - RiscV.RelocatableInstruction _ instructionType - | RiscV.Higher20 _ symbolName <- instructionType - -> Just -- R_RISCV_HI20 - $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26 - | RiscV.Lower12I _ _ _ symbolName <- instructionType - -> Just -- R_RISCV_LO12_I - $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27 - | RiscV.Lower12S symbolName _ _ _ <- instructionType - -> Just -- R_RISCV_LO12_S - $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28 - RiscV.CallInstruction symbolName - -> Just -- R_RISCV_CALL_PLT - $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 19 - RiscV.BaseInstruction _ _ -> Nothing - chunk = ByteString.Builder.toLazyByteString - $ RiscV.instruction instruction - result = - ( encoded <> chunk - , maybe relocations (Vector.snoc relocations) unresolvedRelocation - , rest - , addDefinition unresolvedRelocation definitions - ) - in encodeInstructions result - | otherwise = (encoded, relocations, Vector.drop 1 instructions, definitions) - addDefinition (Just (UnresolvedRelocation symbolName _ _)) = - HashSet.insert symbolName - addDefinition Nothing = id diff --git a/lib/Language/Elna/RiscV/CodeGenerator.hs b/lib/Language/Elna/RiscV/CodeGenerator.hs new file mode 100644 index 0000000..d20488c --- /dev/null +++ b/lib/Language/Elna/RiscV/CodeGenerator.hs @@ -0,0 +1,156 @@ +module Language.Elna.RiscV.CodeGenerator + ( Statement(..) + , generateRiscV + , riscVConfiguration + ) where + +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int32) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified Data.Text.Encoding as Text.Encoding +import qualified Language.Elna.Architecture.RiscV as RiscV +import Language.Elna.Backend.Allocator (MachineConfiguration(..), Store(..)) +import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..)) +import Language.Elna.Location (Identifier(..)) +import Data.Bits (Bits(..)) + +data Directive + = GlobalDirective + | FunctionDirective + deriving (Eq, Show) + +data Statement + = Instruction RiscV.Instruction + | JumpLabel ByteString [Directive] + deriving Eq + +riscVConfiguration :: MachineConfiguration RiscV.XRegister +riscVConfiguration = MachineConfiguration + { temporaryRegister = RiscV.T0 + } + +type RiscVStore = Store RiscV.XRegister +type RiscVQuadruple = Quadruple RiscVStore +type RiscVOperand = Operand RiscVStore + +generateRiscV :: HashMap Identifier (Vector RiscVQuadruple) -> Vector Statement +generateRiscV = HashMap.foldlWithKey' go Vector.empty + where + go accumulator (Identifier key) value = + let code = Vector.cons (JumpLabel (Text.Encoding.encodeUtf8 key) [GlobalDirective, FunctionDirective]) + $ Vector.foldMap quadruple value + in accumulator <> code + +quadruple :: RiscVQuadruple -> Vector Statement +quadruple StartQuadruple = Vector.fromList + [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4)) + , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0) + , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA) + , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP 4) + ] +quadruple (ParameterQuadruple operand1) = + let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0 + in mappend statements $ Vector.fromList + [ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4)) + , Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister) + ] +quadruple (CallQuadruple callName numberOfArguments) = Vector.fromList + [ Instruction (RiscV.CallInstruction callName) + , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (numberOfArguments * 4)) + ] +quadruple StopQuadruple = Vector.fromList + [ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0) + , Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4) + , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP 4) + , Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0) + ] +quadruple (AddQuadruple operand1 operand2 (Store register)) + | IntOperand immediateOperand1 <- operand1 + , IntOperand immediateOperand2 <- operand2 = + lui (immediateOperand1 + immediateOperand2) register + | VariableOperand variableOperand1 <- operand1 + , VariableOperand variableOperand2 <- operand2 = + let Store operandRegister1 = variableOperand1 + Store operandRegister2 = variableOperand2 + in pure $ Instruction + $ RiscV.BaseInstruction RiscV.Op + $ RiscV.R register RiscV.ADD operandRegister1 operandRegister2 (RiscV.Funct7 0b0000000) + | VariableOperand variableOperand1 <- operand1 + , IntOperand immediateOperand2 <- operand2 = + addImmediateRegister variableOperand1 immediateOperand2 + | IntOperand immediateOperand1 <- operand1 + , VariableOperand variableOperand2 <- operand2 = + addImmediateRegister variableOperand2 immediateOperand1 + where + addImmediateRegister variableOperand immediateOperand = + let statements = lui immediateOperand register + Store operandRegister = variableOperand + in Vector.snoc statements + $ Instruction + $ RiscV.BaseInstruction RiscV.Op + $ RiscV.R register RiscV.ADD register operandRegister + $ RiscV.Funct7 0b0000000 +quadruple (SubtractionQuadruple operand1 operand2 (Store register)) + | IntOperand immediateOperand1 <- operand1 + , IntOperand immediateOperand2 <- operand2 = + lui (immediateOperand1 - immediateOperand2) register + | VariableOperand variableOperand1 <- operand1 + , VariableOperand variableOperand2 <- operand2 = + let Store operandRegister1 = variableOperand1 + Store operandRegister2 = variableOperand2 + in pure $ Instruction + $ RiscV.BaseInstruction RiscV.Op + $ RiscV.R register RiscV.SUB operandRegister1 operandRegister2 + $ RiscV.Funct7 0b0100000 + | IntOperand immediateOperand1 <- operand1 + , VariableOperand variableOperand2 <- operand2 = + let statements1 = lui immediateOperand1 register + Store operandRegister2 = variableOperand2 + in Vector.snoc statements1 + $ Instruction + $ RiscV.BaseInstruction RiscV.Op + $ RiscV.R register RiscV.SUB register operandRegister2 + $ RiscV.Funct7 0b0100000 + | VariableOperand variableOperand1 <- operand1 + , IntOperand immediateOperand2 <- operand2 = + let statements2 = lui (negate immediateOperand2) register + Store operandRegister1 = variableOperand1 + in Vector.snoc statements2 + $ Instruction + $ RiscV.BaseInstruction RiscV.Op + $ RiscV.R register RiscV.ADD register operandRegister1 + $ RiscV.Funct7 0b0000000 +quadruple (NegationQuadruple operand1 (Store register)) + | IntOperand immediateOperand1 <- operand1 = lui (negate immediateOperand1) register + | VariableOperand variableOperand1 <- operand1 = + let Store operandRegister1 = variableOperand1 + in Vector.singleton + $ Instruction + $ RiscV.BaseInstruction RiscV.Op + $ RiscV.R register RiscV.SUB RiscV.Zero operandRegister1 + $ RiscV.Funct7 0b0100000 + +loadImmediateOrRegister :: RiscVOperand -> RiscV.XRegister -> (RiscV.XRegister, Vector Statement) +loadImmediateOrRegister (IntOperand intValue) targetRegister = + (targetRegister, lui intValue targetRegister) +loadImmediateOrRegister (VariableOperand (Store register)) _ = (register, Vector.empty) + +lui :: Int32 -> RiscV.XRegister -> Vector Statement +lui intValue targetRegister + | intValue >= -2048 + , intValue <= 2047 = Vector.singleton + $ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI RiscV.Zero lo) + | intValue .&. 0x800 /= 0 = Vector.fromList + [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral $ succ hi) + , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo) + ] + | otherwise = Vector.fromList + [ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral hi) + , Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo) + ] + where + hi = intValue `shiftR` 12 + lo = fromIntegral intValue diff --git a/lib/Language/Elna/RiscV/ElfWriter.hs b/lib/Language/Elna/RiscV/ElfWriter.hs new file mode 100644 index 0000000..a83aca3 --- /dev/null +++ b/lib/Language/Elna/RiscV/ElfWriter.hs @@ -0,0 +1,276 @@ +-- | Writer assembler to an object file. +module Language.Elna.RiscV.ElfWriter + ( riscv32Elf + ) where + +import Data.Word (Word8) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as ByteString.Builder +import qualified Data.ByteString.Lazy as LazyByteString +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Language.Elna.Object.Elf + ( ByteOrder(..) + , Elf32_Addr + , Elf32_Ehdr(..) + , Elf32_Half + , Elf32_Word + , Elf32_Sym(..) + , ElfMachine(..) + , ElfType(..) + , ElfVersion(..) + , ElfIdentification(..) + , ElfClass(..) + , ElfData(..) + , Elf32_Shdr(..) + , ElfSectionType(..) + , ElfSymbolBinding(..) + , ElfSymbolType(..) + , Elf32_Rel(..) + , ElfWriter(..) + , ElfHeaderResult(..) + , elf32Sym + , elfHeaderSize + , elfSectionsSize + , stInfo + , rInfo + , elf32Rel + , shfInfoLink + , addSectionHeader + ) +import System.IO (Handle) +import qualified Language.Elna.Architecture.RiscV as RiscV +import qualified Data.Text.Encoding as Text.Encoding +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.State (get) +import Language.Elna.RiscV.CodeGenerator (Statement(..)) +import qualified Data.HashSet as HashSet +import GHC.Records (HasField(..)) + +data UnresolvedRelocation = UnresolvedRelocation ByteString Elf32_Addr Word8 +data UnresolvedRelocations = UnresolvedRelocations (Vector UnresolvedRelocation) Elf32_Word + +riscv32Elf :: Vector Statement -> Handle -> ElfWriter Elf32_Ehdr +riscv32Elf code objectHandle = text + >>= uncurry symrel + >>= strtab + >> shstrtab + >>= riscv32Header + where + shstrtab :: ElfWriter Elf32_Half + shstrtab = do + ElfHeaderResult{..} <- ElfWriter get + let stringTable = sectionNames <> ".shstrtab\0" + nextHeader = Elf32_Shdr + { sh_type = SHT_STRTAB + , sh_size = fromIntegral $ ByteString.length stringTable + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0 + , sh_entsize = 0 + , sh_addralign = 1 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle stringTable + addSectionHeader ".shstrtab" nextHeader + pure $ fromIntegral $ Vector.length sectionHeaders + riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr + riscv32Header shstrndx = do + ElfHeaderResult{..} <- ElfWriter get + pure $ Elf32_Ehdr + { e_version = EV_CURRENT + , e_type = ET_REL + , e_shstrndx = shstrndx + , e_shoff = elfSectionsSize sectionHeaders + , e_shnum = fromIntegral (Vector.length sectionHeaders) + , e_shentsize = 40 + , e_phoff = 0 + , e_phnum = 0 + , e_phentsize = 32 + , e_machine = EM_RISCV + , e_ident = ElfIdentification ELFCLASS32 ELFDATA2LSB + , e_flags = 0x4 -- EF_RISCV_FLOAT_ABI_DOUBLE + , e_entry = 0 + , e_ehsize = fromIntegral elfHeaderSize + } + takeStringZ stringTable Elf32_Sym{ st_name } + = ByteString.takeWhile (/= 0) + $ ByteString.drop (fromIntegral st_name) stringTable + resolveRelocation (ElfHeaderResult stringTable entries) unresolvedRelocation + | UnresolvedRelocation symbolName offset type' <- unresolvedRelocation + , Just entry <- Vector.findIndex ((== symbolName) . takeStringZ stringTable) entries = + Right $ Elf32_Rel + { r_offset = offset + , r_info = rInfo (fromIntegral entry) type' + } + | otherwise = Left unresolvedRelocation + symtab entries = do + ElfHeaderResult{..} <- ElfWriter get + let encodedSymbols = LazyByteString.toStrict + $ ByteString.Builder.toLazyByteString + $ foldMap (elf32Sym LSB) entries + symHeader = Elf32_Shdr + { sh_type = SHT_SYMTAB + , sh_size = fromIntegral $ ByteString.length encodedSymbols + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = fromIntegral $ Vector.length sectionHeaders + 2 + , sh_info = 1 + , sh_flags = 0 + , sh_entsize = 16 + , sh_addralign = 4 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle encodedSymbols + addSectionHeader ".symtab" symHeader + pure $ fromIntegral $ Vector.length sectionHeaders + symrel symbols relocations = do + let UnresolvedRelocations relocationList index = relocations + ElfHeaderResult stringTable entries = symbols + + sectionHeadersLength <- symtab entries + ElfHeaderResult{..} <- ElfWriter get + + let encodedRelocations = LazyByteString.toStrict + $ ByteString.Builder.toLazyByteString + $ Vector.foldMap (either (const mempty) (elf32Rel LSB)) + $ resolveRelocation symbols <$> relocationList + relHeader = Elf32_Shdr + { sh_type = SHT_REL + , sh_size = fromIntegral $ ByteString.length encodedRelocations + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = sectionHeadersLength + , sh_info = index + , sh_flags = shfInfoLink + , sh_entsize = 8 + , sh_addralign = 4 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle encodedRelocations + addSectionHeader ".rel.text" relHeader + pure stringTable + strtab stringTable = do + ElfHeaderResult{..} <- ElfWriter get + let strHeader = Elf32_Shdr + { sh_type = SHT_STRTAB + , sh_size = fromIntegral $ ByteString.length stringTable + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0 + , sh_entsize = 0 + , sh_addralign = 1 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle stringTable + addSectionHeader ".strtab" strHeader + text = do + ElfHeaderResult{..} <- ElfWriter get + let textTabIndex = fromIntegral $ Vector.length sectionHeaders + initialHeaders = ElfHeaderResult "\0" + $ Vector.singleton + $ Elf32_Sym + { st_value = 0 + , st_size = 0 + , st_shndx = 0 + , st_other = 0 + , st_name = 0 + , st_info = 0 + } + (encoded, updatedRelocations, symbols, definitions) = + encodeAsm textTabIndex (mempty, Vector.empty, initialHeaders, HashSet.empty) code + + filterPredicate = not + . (`ByteString.isInfixOf` getField @"sectionNames" symbols) + . ("\0" <>) . (<> "\0") + symbolResult = HashSet.foldl' encodeEmptyDefinitions symbols + $ HashSet.filter filterPredicate definitions + size = fromIntegral $ LazyByteString.length encoded + newHeader = Elf32_Shdr + { sh_type = SHT_PROGBITS + , sh_size = size + , sh_offset = elfSectionsSize sectionHeaders + , sh_name = fromIntegral $ ByteString.length sectionNames + , sh_link = 0 + , sh_info = 0 + , sh_flags = 0b110 + , sh_entsize = 0 + , sh_addralign = 4 + , sh_addr = 0 + } + liftIO $ ByteString.hPut objectHandle $ LazyByteString.toStrict encoded + addSectionHeader ".text" newHeader + pure (symbolResult, UnresolvedRelocations updatedRelocations $ fromIntegral $ Vector.length sectionHeaders) + encodeEmptyDefinitions (ElfHeaderResult names entries) definition = + let nextEntry = Elf32_Sym + { st_value = 0 + , st_size = 0 + , st_shndx = 0 + , st_other = 0 + , st_name = fromIntegral (ByteString.length names) + , st_info = stInfo STB_GLOBAL STT_FUNC + } + in ElfHeaderResult (names <> definition <> "\0") + $ Vector.snoc entries nextEntry + encodeAsm shndx (encoded, relocations, ElfHeaderResult names symbols, definitions) instructions + | Just (instruction, rest) <- Vector.uncons instructions = + case instruction of + Instruction _ -> + let (encoded', relocations', rest', definitions') = + encodeInstructions (encoded, relocations, instructions, definitions) + in encodeAsm shndx (encoded', relocations', ElfHeaderResult names symbols, definitions') rest' + JumpLabel labelName _ -> + let (encoded', relocations', rest', definitions') = + encodeInstructions (encoded, relocations, rest, definitions) + newEntry = Elf32_Sym + { st_value = fromIntegral $ LazyByteString.length encoded + , st_size = fromIntegral $ LazyByteString.length encoded' + , st_shndx = shndx + , st_other = 0 + , st_name = fromIntegral $ ByteString.length names + , st_info = stInfo STB_GLOBAL STT_FUNC + } + result = + ( encoded <> encoded' + , relocations <> relocations' + , ElfHeaderResult (names <> labelName <> "\0") (Vector.snoc symbols newEntry) + , definitions' + ) + in encodeAsm shndx result rest' + | otherwise = (encoded, relocations, ElfHeaderResult names symbols, definitions) + encodeInstructions (encoded, relocations, instructions, definitions) + | Just (Instruction instruction, rest) <- Vector.uncons instructions = + let offset = fromIntegral $ LazyByteString.length encoded + unresolvedRelocation = case instruction of + RiscV.RelocatableInstruction _ instructionType + | RiscV.Higher20 _ symbolName <- instructionType + -> Just -- R_RISCV_HI20 + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 26 + | RiscV.Lower12I _ _ _ symbolName <- instructionType + -> Just -- R_RISCV_LO12_I + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 27 + | RiscV.Lower12S symbolName _ _ _ <- instructionType + -> Just -- R_RISCV_LO12_S + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 28 + RiscV.CallInstruction symbolName + -> Just -- R_RISCV_CALL_PLT + $ UnresolvedRelocation (Text.Encoding.encodeUtf8 symbolName) offset 19 + RiscV.BaseInstruction _ _ -> Nothing + chunk = ByteString.Builder.toLazyByteString + $ RiscV.instruction instruction + result = + ( encoded <> chunk + , maybe relocations (Vector.snoc relocations) unresolvedRelocation + , rest + , addDefinition unresolvedRelocation definitions + ) + in encodeInstructions result + | otherwise = (encoded, relocations, Vector.drop 1 instructions, definitions) + addDefinition (Just (UnresolvedRelocation symbolName _ _)) = + HashSet.insert symbolName + addDefinition Nothing = id diff --git a/lib/Language/Elna/SymbolTable.hs b/lib/Language/Elna/SymbolTable.hs deleted file mode 100644 index 97d9621..0000000 --- a/lib/Language/Elna/SymbolTable.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Language.Elna.SymbolTable - ( SymbolTable - , Info(..) - , ParameterInfo(..) - , builtInSymbolTable - , empty - , enter - , fromList - , lookup - , member - , scope - , toMap - , update - ) where - -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List (sort) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (isJust) -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Language.Elna.Location (Identifier(..)) -import Language.Elna.Types (Type(..), intType) -import Prelude hiding (lookup) - -data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info) - deriving (Eq, Show) - -empty :: SymbolTable -empty = SymbolTable Nothing HashMap.empty - -update :: (Info -> Maybe Info) -> Identifier -> SymbolTable -> SymbolTable -update updater key (SymbolTable parent mappings) = SymbolTable parent - $ HashMap.update updater key mappings - -scope :: SymbolTable -> SymbolTable -> SymbolTable -scope parent (SymbolTable _ mappings) = SymbolTable (Just parent) mappings - -builtInSymbolTable :: SymbolTable -builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList - [ ("printi", ProcedureInfo empty Vector.empty) - , ("int", TypeInfo intType) - ] - -toMap :: SymbolTable -> HashMap Identifier Info -toMap (SymbolTable _ map') = map' - -enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable -enter identifier info table@(SymbolTable parent hashTable) - | member identifier table = Nothing - | otherwise = Just - $ SymbolTable parent (HashMap.insert identifier info hashTable) - -lookup :: Identifier -> SymbolTable -> Maybe Info -lookup identifier (SymbolTable parent table) - | Just found <- HashMap.lookup identifier table = Just found - | Just parent' <- parent = lookup identifier parent' - | otherwise = Nothing - -member :: Identifier -> SymbolTable -> Bool -member identifier table = - isJust $ lookup identifier table - -fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable -fromList elements - | Just identifierDuplicates' <- identifierDuplicates = - Left identifierDuplicates' - | otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements - where - identifierDuplicates = NonEmpty.nonEmpty - $ fmap NonEmpty.head - $ filter ((> 1) . NonEmpty.length) - $ NonEmpty.group . sort - $ fst <$> elements - -data ParameterInfo = ParameterInfo - { name :: Identifier - , type' :: Type - , isReferenceParameter :: Bool - } deriving (Eq, Show) - -data Info - = TypeInfo Type - | VariableInfo Bool Type - | ProcedureInfo SymbolTable (Vector ParameterInfo) - deriving (Eq, Show) diff --git a/lib/Language/Elna/TypeAnalysis.hs b/lib/Language/Elna/TypeAnalysis.hs deleted file mode 100644 index ac61b62..0000000 --- a/lib/Language/Elna/TypeAnalysis.hs +++ /dev/null @@ -1,186 +0,0 @@ -module Language.Elna.TypeAnalysis - ( typeAnalysis - , -- Error(..) - ) where - -import qualified Language.Elna.AST as AST -import Language.Elna.SymbolTable ({-Info(..), ParameterInfo(..), -}SymbolTable) - -typeAnalysis :: SymbolTable -> AST.Program -> () -- Maybe Error -typeAnalysis _globalTable = const () {- either Just (const Nothing) - . runExcept - . flip runReaderT globalTable - . runTypeAnalysis - . program -} - -{- -import Control.Applicative (Alternative(..)) -import Control.Monad.Trans.Except (Except, runExcept, throwE) -import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT, withReaderT, ask) -import qualified Data.Vector as Vector -import Language.Elna.Location (Identifier(..)) -import qualified Language.Elna.SymbolTable as SymbolTable -import Language.Elna.Types (Type(..), booleanType, intType) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad (unless, when) -import Data.Foldable (traverse_) - -data Error - = ArithmeticExpressionError Type - | ComparisonExpressionError Type Type - | UnexpectedVariableInfoError Info - | UnexpectedProcedureInfoError Info - | UndefinedSymbolError Identifier - | InvalidConditionTypeError Type - | InvalidAssignmentError Type - | ExpectedLvalueError AST.Expression - | ParameterCountMismatchError Int Int - | ArgumentTypeMismatchError Type Type - | ArrayIndexError Type - | ArrayAccessError Type - deriving (Eq, Show) - -newtype TypeAnalysis a = TypeAnalysis - { runTypeAnalysis :: ReaderT SymbolTable (Except Error) a - } - -instance Functor TypeAnalysis - where - fmap f (TypeAnalysis x) = TypeAnalysis $ f <$> x - -instance Applicative TypeAnalysis - where - pure = TypeAnalysis . pure - (TypeAnalysis f) <*> (TypeAnalysis x) = TypeAnalysis $ f <*> x - -instance Monad TypeAnalysis - where - (TypeAnalysis x) >>= f = TypeAnalysis $ x >>= (runTypeAnalysis . f) - -program :: AST.Program -> TypeAnalysis () -program (AST.Program declarations) = traverse_ declaration declarations - -declaration :: AST.Declaration -> TypeAnalysis () -declaration (AST.ProcedureDefinition procedureName _ _ body) = do - globalTable <- TypeAnalysis ask - case SymbolTable.lookup procedureName globalTable of - Just (ProcedureInfo localTable _) -> TypeAnalysis - $ withReaderT (const localTable) - $ runTypeAnalysis - $ traverse_ (statement globalTable) body - Just anotherInfo -> TypeAnalysis $ lift $ throwE - $ UnexpectedProcedureInfoError anotherInfo - Nothing -> TypeAnalysis $ lift $ throwE - $ UndefinedSymbolError procedureName -declaration _ = pure () - -statement :: SymbolTable -> AST.Statement -> TypeAnalysis () -statement globalTable = \case - AST.EmptyStatement -> pure () - AST.AssignmentStatement lhs rhs -> do - lhsType <- variableAccess globalTable lhs - rhsType <- expression globalTable rhs - unless (lhsType == intType) - $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType - unless (rhsType == intType) - $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType - AST.IfStatement ifCondition ifStatement elseStatement -> do - conditionType <- condition globalTable ifCondition - unless (conditionType == booleanType) - $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType - statement globalTable ifStatement - maybe (pure ()) (statement globalTable) elseStatement - AST.WhileStatement whileCondition whileStatement -> do - conditionType <- condition globalTable whileCondition - unless (conditionType == booleanType) - $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType - statement globalTable whileStatement - AST.CompoundStatement statements -> traverse_ (statement globalTable) statements - AST.CallStatement procedureName arguments -> - case SymbolTable.lookup procedureName globalTable of - Just (ProcedureInfo _ parameters) - | parametersLength <- Vector.length parameters - , argumentsLength <- length arguments - , Vector.length parameters /= length arguments -> TypeAnalysis $ lift $ throwE - $ ParameterCountMismatchError parametersLength argumentsLength - | otherwise -> traverse_ (uncurry checkArgument) - $ Vector.zip parameters (Vector.fromList arguments) - Just anotherInfo -> TypeAnalysis $ lift $ throwE - $ UnexpectedVariableInfoError anotherInfo - Nothing -> TypeAnalysis $ lift $ throwE - $ UndefinedSymbolError procedureName - where - checkArgument ParameterInfo{..} argument = do - argumentType <- expression globalTable argument - unless (argumentType == type') - $ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType - when (isReferenceParameter && not (isLvalue argument)) - $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument - isLvalue (AST.VariableExpression _) = True - isLvalue _ = False - -variableAccess :: SymbolTable -> AST.VariableAccess -> TypeAnalysis Type -variableAccess globalTable (AST.VariableAccess identifier) = do - localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier - case localLookup <|> SymbolTable.lookup identifier globalTable of - Just (VariableInfo _ variableType) -> pure variableType - Just anotherInfo -> TypeAnalysis $ lift $ throwE - $ UnexpectedVariableInfoError anotherInfo - Nothing -> TypeAnalysis $ lift $ throwE - $ UndefinedSymbolError identifier -variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = do - arrayType <- variableAccess globalTable arrayExpression - indexType <- expression globalTable indexExpression - unless (indexType == intType) - $ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType - case arrayType of - ArrayType _ baseType -> pure baseType - nonArrayType -> TypeAnalysis $ lift $ throwE - $ ArrayAccessError nonArrayType - -expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type -expression globalTable = \case - AST.VariableExpression variableExpression -> do - variableAccess globalTable variableExpression - AST.LiteralExpression literal' -> literal literal' - AST.NegationExpression negation -> do - operandType <- expression globalTable negation - if operandType == intType - then pure intType - else TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError operandType - AST.SumExpression lhs rhs -> arithmeticExpression lhs rhs - AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs - AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs - AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs - where - arithmeticExpression lhs rhs = do - lhsType <- expression globalTable lhs - unless (lhsType == intType) - $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError lhsType - rhsType <- expression globalTable rhs - unless (rhsType == intType) - $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError rhsType - pure intType - -condition :: SymbolTable -> AST.Condition -> TypeAnalysis Type -condition globalTable = \case - AST.EqualCondition lhs rhs -> comparisonExpression lhs rhs - AST.NonEqualCondition lhs rhs -> comparisonExpression lhs rhs - AST.LessCondition lhs rhs -> comparisonExpression lhs rhs - AST.GreaterCondition lhs rhs -> comparisonExpression lhs rhs - AST.LessOrEqualCondition lhs rhs -> comparisonExpression lhs rhs - AST.GreaterOrEqualCondition lhs rhs -> comparisonExpression lhs rhs - where - comparisonExpression lhs rhs = do - lhsType <- expression globalTable lhs - rhsType <- expression globalTable rhs - if lhsType == intType && rhsType == intType - then pure booleanType - else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType - -literal :: AST.Literal -> TypeAnalysis Type -literal (AST.IntegerLiteral _) = pure intType -literal (AST.HexadecimalLiteral _) = pure intType -literal (AST.CharacterLiteral _) = pure intType -literal (AST.BooleanLiteral _) = pure booleanType --} diff --git a/lib/Language/Elna/Types.hs b/lib/Language/Elna/Types.hs deleted file mode 100644 index ee76ec8..0000000 --- a/lib/Language/Elna/Types.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Language.Elna.Types - ( Type(..) - , addressByteSize - , booleanType - , intType - ) where - -import Data.Text (Text) -import Data.Word (Word32) -import Language.Elna.Location (showArrayType) - -addressByteSize :: Int -addressByteSize = 4 - -data Type - = PrimitiveType Text Int - | ArrayType Word32 Type - deriving Eq - -instance Show Type - where - show (PrimitiveType typeName _) = show typeName - show (ArrayType elementCount typeName) = showArrayType elementCount typeName - -intType :: Type -intType = PrimitiveType "int" 4 - -booleanType :: Type -booleanType = PrimitiveType "boolean" 1 -- cgit v1.2.3