From eb39f332cfc6be6190f99581897a1dd513a9128d Mon Sep 17 00:00:00 2001 From: Vorotynsky Maxim Date: Thu, 28 May 2020 15:39:42 +0300 Subject: [PATCH 1/4] feat!: add program scope Added `program {}` Multiple frames support --- app/Main.hs | 6 +++--- src/HLasm/Ast.hs | 3 ++- src/HLasm/Backend/Nasm.hs | 11 +++++++++-- src/HLasm/Instructions.hs | 18 +++++++++++++++--- src/HLasm/Parser.hs | 6 +++++- src/HLasm/Scope.hs | 8 ++++++-- 6 files changed, 40 insertions(+), 12 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7bb31a0..f1d0fcd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,7 @@ import HLasm.Parser import HLasm.Scope (semantic) import HLasm.Types (typeCheck) import HLasm.Frame (StackFrame(Root), buildStackFrames) -import HLasm.Instructions (instructions, BackEnd(..), runBackend) +import HLasm.Instructions (program, BackEnd(..), runBackend) import HLasm.Backend.Nasm parseAll :: String -> String @@ -22,8 +22,8 @@ parseAll = get . first show . pipeline _ <- typeCheck semantic stack <- Right $ (buildStackFrames Root) parsed tree <- Right $ mzipWith (\(e, v, l) (_, sf) -> (e, v, l, sf)) semantic stack - instructions <- instructions tree - runBackend nasm instructions + objProg <- program tree + runBackend nasm objProg main :: IO () main = do diff --git a/src/HLasm/Ast.hs b/src/HLasm/Ast.hs index 01a292c..43173d3 100644 --- a/src/HLasm/Ast.hs +++ b/src/HLasm/Ast.hs @@ -44,7 +44,8 @@ data Condition = Condition (HLValue, CompareType, HLValue) deriving (Show, Eq) data HLElement = - InstructionSet + Program + | InstructionSet | VariableDeclaration HLValuable | Frame (Maybe Label) | If Label diff --git a/src/HLasm/Backend/Nasm.hs b/src/HLasm/Backend/Nasm.hs index 643df60..f886051 100644 --- a/src/HLasm/Backend/Nasm.hs +++ b/src/HLasm/Backend/Nasm.hs @@ -3,8 +3,9 @@ module HLasm.Backend.Nasm (nasm) where import HLasm.Ast (CompareType (..)) +import HLasm.Error import HLasm.Frame -import HLasm.Instructions +import HLasm.Instructions hiding (program) bytes :: Int -> Int bytes x = ceiling ((toEnum x) / 8) @@ -54,5 +55,11 @@ join s [] = "" join s [x] = x join s (x:xs) = x ++ s ++ join s xs +section :: Section -> Result String +section (Text x) = Right . join "\n" . ((:) "section .text\n") . concat $ fmap instruction x + +program :: ObjProgram -> Result String +program (ObjProgram sections) = fmap (join "\n\n") . traverse section $ sections + nasm :: BackEnd -nasm = BackEnd (\x -> Right . join "\n" . concat $ fmap instruction x) +nasm = BackEnd program diff --git a/src/HLasm/Instructions.hs b/src/HLasm/Instructions.hs index f2f84bd..fb6b601 100644 --- a/src/HLasm/Instructions.hs +++ b/src/HLasm/Instructions.hs @@ -3,9 +3,11 @@ module HLasm.Instructions ( Offset(..), Target(..), InstructionSet(..) , Instructions(..) +, Section(..) +, ObjProgram(..) , BackEnd(..) , runBackend -, instructions +, program ) where import Control.Monad.Extra (concatMapM) @@ -40,7 +42,12 @@ data Instructions = type InstructionSet = [Instructions] -newtype BackEnd = BackEnd (InstructionSet -> Result String) +data Section = + Text InstructionSet + +newtype ObjProgram = ObjProgram [Section] + +newtype BackEnd = BackEnd (ObjProgram -> Result String) runBackend (BackEnd f) x = f x @@ -61,6 +68,7 @@ valuableTarget (sf, vd) (NameValue name) = findTarget sf vd name loop :: Label -> Result (InstructionSet) -> Result (InstructionSet) loop lbl i = let begin = lbl ++ "begin" in fmap (\x -> [Label begin] ++ x ++ [Jump begin Nothing, Label (lbl ++ "end")]) $ i + instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet) instructions (Node ((InstructionSet ), _, _, _) xs) = concatMapM instructions xs instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Right [] @@ -83,9 +91,13 @@ instructions (Node ((If lbl), _, _, _) xs) = do (conds, bodies') <- Right $ traverse (uncurry branch) (zip [1..] xs) bodies <- fmap (concat) . sequence $ bodies' Right $ conds ++ [Jump (lbl ++ "end") Nothing] ++ bodies ++ [Label (lbl ++ "end")] - where condition lbl pt (Condition (left, cmp, right)) = let find = valuableTarget pt in [Compare (find left) (find right), Jump lbl (Just cmp)] wrapif i = fmap (\b -> [Label (lbl ++ show i)] ++ b ++ [Jump (lbl ++ "end") Nothing]) . concatMapM instructions branch i (Node ((IfBranch (Just cond)), d, _, f) xs) = (condition (lbl ++ show i) (f, d) cond, wrapif i xs) branch i (Node ((IfBranch Nothing), _, _, _) xs) = ([Jump (lbl ++ show i) Nothing], wrapif i xs) + + +program :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result ObjProgram +program (Node ((Program), _, _, _) xs) = fmap (\i -> ObjProgram [Text i]) $ concatMapM instructions xs +program _ = undefined diff --git a/src/HLasm/Parser.hs b/src/HLasm/Parser.hs index 5d03cb4..b9e4cd1 100644 --- a/src/HLasm/Parser.hs +++ b/src/HLasm/Parser.hs @@ -86,5 +86,9 @@ hlasm = reduce [ asmCall, call, HLasm.Parser.break, assignment ] where reduce (x:xs) = foldl (<|>) x xs + +globals = frame hlasm <|> asmCallas +program = (\a -> Node Program a) <$> (keyword "program" *> braces (many globals)) + parse :: String -> Result SyntaxTree -parse = first ParseError . Text.Parsec.parse hlasm "" +parse = first ParseError . Text.Parsec.parse program "" diff --git a/src/HLasm/Scope.hs b/src/HLasm/Scope.hs index 6d812f7..5272a8d 100644 --- a/src/HLasm/Scope.hs +++ b/src/HLasm/Scope.hs @@ -25,6 +25,7 @@ data ScopeData = FluentScope type ScopeTree = Tree ScopeData elementToScope :: HLElement -> ScopeData +elementToScope (Program) = FluentScope elementToScope (InstructionSet) = FluentScope elementToScope (VariableDeclaration value) = IntroduceVariable value elementToScope (Frame (Just label)) = IntroduceLabel label @@ -59,10 +60,13 @@ foldz g f a [x] = [f a x] foldz g f a (x:xs) = elem : (foldz g f (g elem) xs) where elem = f a x -fromScopeData :: Scope -> Tree (HLElement, ScopeData) -> Tree (HLElement, Scope) -fromScopeData s t@(Node (el@InstructionSet, sd) xs@(_:_)) = -- non-empty InstructionSet +chainScope s (Node (el, sd) xs) = Node (el, currScope) (foldz (\(Node (_,s) _) -> s) (fromScopeData) s xs) where currScope = Scope sd s el + +fromScopeData :: Scope -> Tree (HLElement, ScopeData) -> Tree (HLElement, Scope) +fromScopeData s t@(Node (el@Program , sd) xs@(_:_)) = chainScope s t +fromScopeData s t@(Node (el@InstructionSet, sd) xs@(_:_)) = chainScope s t fromScopeData s (Node (el, sd) xs) = Node (el, currScope) (fmap (fromScopeData currScope) xs) where currScope = Scope sd s el From 2aeec5a9a5d264500410c6d192333e5578d416ef Mon Sep 17 00:00:00 2001 From: Vorotynsky Maxim Date: Thu, 28 May 2020 15:47:17 +0300 Subject: [PATCH 2/4] refactor!: registers - nasm backend: downgrade to 16-bits - added support for system reigisters in `registerSize` --- src/HLasm/Backend/Nasm.hs | 6 +++--- src/HLasm/Types.hs | 17 +++++++++++------ 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/HLasm/Backend/Nasm.hs b/src/HLasm/Backend/Nasm.hs index f886051..1010746 100644 --- a/src/HLasm/Backend/Nasm.hs +++ b/src/HLasm/Backend/Nasm.hs @@ -20,7 +20,7 @@ choosePtr = f . bytes target :: Target -> String target (NamedTarget name) = name target (Register reg) = reg -target (FrameVar (offset, size, _)) = choosePtr size ++ " [ebp-" ++ (show $ bytes (offset + size)) ++ "]" +target (FrameVar (offset, size, _)) = choosePtr size ++ " [bp-" ++ (show $ bytes (offset + size)) ++ "]" target (ConstantTarget const) = show const instr2arg :: String -> Target -> Target -> String @@ -31,7 +31,7 @@ size (Root) = 0 size (Fluent _) = 0 size (StackFrame _ x) = bytes $ frameSize x -frame f = ["push ebp", "mov ebp, esp", "sub esp, " ++ (show . size $ f)] +frame f = ["push bp", "mov bp, sp", "sub sp, " ++ (show . size $ f)] instruction :: Instructions -> [String] instruction (PureAsm str) = [str] @@ -47,7 +47,7 @@ instruction (Jump lbl (Just Equals)) = ["je " ++ lbl] instruction (Jump lbl (Just NotEquals)) = ["jne " ++ lbl] instruction (Jump lbl (Just Greater)) = ["jg " ++ lbl] instruction (Jump lbl (Just Less)) = ["jl " ++ lbl] -instruction (Call lbl args size) = (fmap push . reverse $ args) ++ ["call " ++ lbl, "add esp, " ++ show (bytes size)] +instruction (Call lbl args size) = (fmap push . reverse $ args) ++ ["call " ++ lbl, "add sp, " ++ show (bytes size)] where push x = "push " ++ (target x) join :: String -> [String] -> String diff --git a/src/HLasm/Types.hs b/src/HLasm/Types.hs index 4752ecb..5d282f8 100644 --- a/src/HLasm/Types.hs +++ b/src/HLasm/Types.hs @@ -13,13 +13,18 @@ typeSuit :: Type -> Type -> Bool typeSuit (Type lname _) (Type rname _) | (lname /= rname) = False typeSuit (Type _ l) (Type _ r) = (fromMaybe maxBound l) >= (fromMaybe maxBound r) +sysregs = ["ip", "sp", "bp", "si", "di", "cs", "ds", "ss", "es", "fs"] + registerSize :: RegisterName -> Int -registerSize (n:"l") | elem n "abcd" = 8 -registerSize (n:"h") | elem n "abcd" = 8 -registerSize (n:"x") | elem n "abcd" = 16 -registerSize ('e':n:"x") | elem n "abcd" = 32 -registerSize ('r':n:"x") | elem n "abcd" = 64 -registerSize _ = 0 +registerSize (n:"l") | elem n "abcd" = 8 +registerSize (n:"h") | elem n "abcd" = 8 +registerSize (n:"x") | elem n "abcd" = 16 +registerSize ('e':n:"x") | elem n "abcd" = 32 +registerSize ('r':n:"x") | elem n "abcd" = 64 +registerSize (x) | elem x sysregs = 16 +registerSize ('e':x) | elem x sysregs = 32 +registerSize ('r':x) | elem x sysregs = 64 +registerSize _ = 0 getType :: HLElement -> Type getType (VariableDeclaration (Variable (_, t))) = t From 07c15ea715bd61e4967f948db6cbd8270ea90df8 Mon Sep 17 00:00:00 2001 From: Vorotynsky Maxim Date: Sun, 31 May 2020 15:55:24 +0300 Subject: [PATCH 3/4] feat!: global variables - Global variables support - Added sections (var - data, const - rodata) - HLValuable merged to ast (HLELement) as Register, Variable, Global, Const Declarations. BC: AST merge BC: valueSize renamed to stackVarSize --- src/HLasm/Ast.hs | 28 ++++++++++++++++++---------- src/HLasm/Backend/Nasm.hs | 37 +++++++++++++++++++++++++++++-------- src/HLasm/Error.hs | 6 ++++-- src/HLasm/Frame.hs | 31 +++++++++++++++++-------------- src/HLasm/Instructions.hs | 39 ++++++++++++++++++++++++++++++--------- src/HLasm/Parser.hs | 11 +++++++---- src/HLasm/Scope.hs | 35 +++++++++++++++++++---------------- src/HLasm/Types.hs | 6 ++++-- 8 files changed, 128 insertions(+), 65 deletions(-) diff --git a/src/HLasm/Ast.hs b/src/HLasm/Ast.hs index 43173d3..1e946b0 100644 --- a/src/HLasm/Ast.hs +++ b/src/HLasm/Ast.hs @@ -3,6 +3,7 @@ module HLasm.Ast where import Data.Tree +import Data.Maybe data Type = Type { typeName :: String @@ -20,15 +21,6 @@ data CompareType = | Less deriving (Show, Eq) -data HLValuable = - Variable (VariableName, Type) - | Register (VariableName, RegisterName) - deriving (Show, Eq) - -valuableName :: HLValuable -> VariableName -valuableName (Variable (name, _)) = name -valuableName (Register (name, _)) = name - data HLValue = NameValue VariableName | IntegerValue Int @@ -46,7 +38,10 @@ data Condition = Condition (HLValue, CompareType, HLValue) data HLElement = Program | InstructionSet - | VariableDeclaration HLValuable + | RegisterDeclaration VariableName RegisterName + | VariableDeclaration VariableName Type + | GlobalVarDeclaration VariableName Type HLValue + | ConstVarDeclaration VariableName Type HLValue | Frame (Maybe Label) | If Label | IfBranch (Maybe Condition) @@ -58,6 +53,19 @@ data HLElement = | AssemblyCall String deriving (Show, Eq) +getValuableName :: HLElement -> Maybe VariableName +getValuableName (VariableDeclaration name _ ) = Just name +getValuableName (RegisterDeclaration name _ ) = Just name +getValuableName (GlobalVarDeclaration name _ _) = Just name +getValuableName (ConstVarDeclaration name _ _) = Just name +getValuableName _ = Nothing + +isVariable :: HLElement -> Bool +isVariable = isJust . getValuableName + +variableName :: HLElement -> VariableName +variableName = fromJust . getValuableName + usedVariables :: HLElement -> [VariableName] usedVariables (IfBranch (Just (Condition(left, _, right)))) = name left ++ name right where name (NameValue name) = [name] diff --git a/src/HLasm/Backend/Nasm.hs b/src/HLasm/Backend/Nasm.hs index 1010746..1bb7976 100644 --- a/src/HLasm/Backend/Nasm.hs +++ b/src/HLasm/Backend/Nasm.hs @@ -2,7 +2,9 @@ module HLasm.Backend.Nasm (nasm) where -import HLasm.Ast (CompareType (..)) +import Data.Char + +import HLasm.Ast (CompareType (..), Type(..)) import HLasm.Error import HLasm.Frame import HLasm.Instructions hiding (program) @@ -10,17 +12,29 @@ import HLasm.Instructions hiding (program) bytes :: Int -> Int bytes x = ceiling ((toEnum x) / 8) -choosePtr :: Int -> String -choosePtr = f . bytes - where f 1 = "BYTE" - f 2 = "WORD" - f 4 = "DWORD" +data DataType = Byte | Word | Dword + deriving (Show, Eq) + +uname = fmap toUpper . show + +dname Byte = "DB" +dname Word = "DW" +dname Dword = "DD" + +datatype :: Int -> DataType +datatype = f . bytes + where f 1 = Byte + f 2 = Word + f 4 = Dword f n = error ("undefined data size: " ++ show n) +toDatatype :: Type -> DataType +toDatatype = let size (Type _ (Just s)) = s in datatype . size + target :: Target -> String target (NamedTarget name) = name target (Register reg) = reg -target (FrameVar (offset, size, _)) = choosePtr size ++ " [bp-" ++ (show $ bytes (offset + size)) ++ "]" +target (FrameVar (offset, size, _)) = (uname . datatype) size ++ " [bp-" ++ (show $ bytes (offset + size)) ++ "]" target (ConstantTarget const) = show const instr2arg :: String -> Target -> Target -> String @@ -50,13 +64,20 @@ instruction (Jump lbl (Just Less)) = ["jl " ++ lbl] instruction (Call lbl args size) = (fmap push . reverse $ args) ++ ["call " ++ lbl, "add sp, " ++ show (bytes size)] where push x = "push " ++ (target x) +variable :: Variable -> String +variable (Variable n t v)= n ++ ": " ++ (dname . toDatatype) t ++ " " ++ show v + join :: String -> [String] -> String join s [] = "" join s [x] = x join s (x:xs) = x ++ s ++ join s xs +sectionHeader header = Right . join "\n" . ((:) ("section ." ++ header)) + section :: Section -> Result String -section (Text x) = Right . join "\n" . ((:) "section .text\n") . concat $ fmap instruction x +section (Text x) = sectionHeader "text\n" . concat $ fmap instruction x +section (Data x) = sectionHeader "data" $ fmap variable x +section (Constants x) = sectionHeader "rodata" $ fmap variable x program :: ObjProgram -> Result String program (ObjProgram sections) = fmap (join "\n\n") . traverse section $ sections diff --git a/src/HLasm/Error.hs b/src/HLasm/Error.hs index 4f193e5..c01214d 100644 --- a/src/HLasm/Error.hs +++ b/src/HLasm/Error.hs @@ -11,14 +11,16 @@ data Error = | VariableNotFound VariableName | LabelNotFound Label | IncompatibleTypes (HLValue, HLValue) + | GlobalVariableInFrame VariableName deriving (Eq) type Result a = Either Error a instance Show Error where show (StringError msg) = "error: " ++ msg ++ ".\n" - show (VariableNotFound name) = "scope error: variable \'" ++ name ++ "\' not found.\n" - show (LabelNotFound label) = "scope error: label \'" ++ label ++ "\' not found.\n" + show (VariableNotFound name) = "scope error: a variable \'" ++ name ++ "\' not found.\n" + show (LabelNotFound label) = "scope error: a label \'" ++ label ++ "\' not found.\n" show (IncompatibleTypes (left, right)) = "type error: incompatible types between \'" ++ show left ++ "\' and \'" ++ show right ++ "\'.\n" show (ParseError err) = "parser error, " ++ show err + show (GlobalVariableInFrame name) = "error: the global variable \'" ++ name ++ "\' isn't in the global scope.\n" diff --git a/src/HLasm/Frame.hs b/src/HLasm/Frame.hs index 46b68d7..babb0d5 100644 --- a/src/HLasm/Frame.hs +++ b/src/HLasm/Frame.hs @@ -2,7 +2,7 @@ module HLasm.Frame ( VarFrame(..) -, valueSize +, stackVarSize , frameSize , buildFrame , buildFrameTree @@ -16,29 +16,32 @@ import Data.Tree import HLasm.Ast import HLasm.Scope hiding (Scope(Root)) -valueSize :: HLValuable -> Int -valueSize (Variable (_, t)) = size t - where size (Type _ (Just s)) = s - {- TODO: add support or refactor in future (on adding errors to compiler) -} - size (Type _ Nothing) = error "Unsupported types without specified size" -valueSize (Register (_, r)) = undefined +size (Type _ (Just s)) = s +{- TODO: add support or refactor in future (on adding errors to compiler) -} +size (Type _ Nothing) = error "Unsupported types without specified size" -newtype VarFrame = VarFrame [(HLValuable, Int, Int)] +stackVarSize :: HLElement -> Int +stackVarSize (VariableDeclaration _ t ) = size t +stackVarSize (GlobalVarDeclaration _ t _) = size t +stackVarSize (ConstVarDeclaration _ t _) = size t +stackVarSize (RegisterDeclaration _ r ) = 0 + +newtype VarFrame = VarFrame [(HLElement, Int, Int)] deriving (Show, Eq) empty :: VarFrame empty = VarFrame [] frameSize :: VarFrame -> Int -frameSize = foldr (+) 0 . fmap valueSize . (\(VarFrame xs) -> fmap (\(x,_,_) -> x) xs) +frameSize = foldr (+) 0 . fmap stackVarSize . (\(VarFrame xs) -> fmap (\(x,_,_) -> x) xs) -buildFrame :: [HLValuable] -> VarFrame -buildFrame xs = VarFrame $ zipWith (\v o -> (v, o, valueSize v)) xs (fmap (foldl (+) 0) . inits . fmap valueSize $ xs) +buildFrame :: [HLElement] -> VarFrame +buildFrame xs = VarFrame $ zipWith (\v o -> (v, o, stackVarSize v)) xs (fmap (foldl (+) 0) . inits . fmap stackVarSize $ xs) -frameVars :: SyntaxTree -> [HLValuable] +frameVars :: SyntaxTree -> [HLElement] frameVars (Node el@(Frame _) []) = [] frameVars (Node el@(Frame _) (x:_)) = frameVars x - where frameVars (Node (VariableDeclaration val@(Variable _)) xs) = [val] ++ (concatMap frameVars xs) + where frameVars (Node val xs) | isVariable val = [val] ++ (concatMap frameVars xs) frameVars (Node el@(Frame _) _) = [] frameVars (Node _ xs) = concatMap frameVars xs @@ -66,5 +69,5 @@ findOffset (StackFrame parent vars) name | (any predicate list) = fmap (\(_, o, _) -> o) . find predicate $ list | otherwise = fmap (+ frameSize vars) $ findOffset parent name -- -> change last commit where list = (\(VarFrame xs) -> xs) vars - predicate ((Variable (n, _)), _, _) | n == name = True + predicate (el, _, _) | isVariable el && (variableName el) == name = True predicate _ = False diff --git a/src/HLasm/Instructions.hs b/src/HLasm/Instructions.hs index fb6b601..38ebc99 100644 --- a/src/HLasm/Instructions.hs +++ b/src/HLasm/Instructions.hs @@ -2,9 +2,8 @@ module HLasm.Instructions ( Offset(..), Target(..), InstructionSet(..) -, Instructions(..) -, Section(..) -, ObjProgram(..) +, Instructions(..), Variable(..) +, Section(..), ObjProgram(..) , BackEnd(..) , runBackend , program @@ -42,8 +41,12 @@ data Instructions = type InstructionSet = [Instructions] +data Variable = Variable VariableName Type HLValue + data Section = Text InstructionSet + | Data [Variable] + | Constants [Variable] newtype ObjProgram = ObjProgram [Section] @@ -52,11 +55,10 @@ runBackend (BackEnd f) x = f x target :: StackFrame -> VariableData -> Target -target _ (VariableData (_, VariableDeclaration (HLasm.Ast.Register(_, reg)))) = HLasm.Instructions.Register reg +target _ (VariableData (_, (RegisterDeclaration _ reg))) = HLasm.Instructions.Register reg target frame (VariableData (name, e)) = case findOffset frame name of - Just x -> FrameVar (x, size e, name) + Just x -> FrameVar (x, stackVarSize e, name) Nothing -> NamedTarget name - where size (VariableDeclaration v) = valueSize v findTarget :: StackFrame -> [VariableData] -> VariableName -> Target -- was a lot of checks, target garanteed be here. findTarget frame xs name = target frame . fromJust . find (\(VariableData (n, _)) -> n == name) $ xs @@ -71,7 +73,6 @@ loop lbl i = let begin = lbl ++ "begin" in fmap (\x -> [Label begin] ++ x ++ [Ju instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet) instructions (Node ((InstructionSet ), _, _, _) xs) = concatMapM instructions xs -instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Right [] instructions (Node ((While lbl ), _, _, _) xs) = loop lbl (concatMapM instructions xs) instructions (Node ((DoWhile lbl ), _, _, _) xs) = loop lbl (concatMapM instructions xs) instructions (Node ((Break lbl ), _, _, _) _ ) = Right [Jump (lbl ++ "end") Nothing] @@ -79,12 +80,17 @@ instructions (Node ((AssemblyCall str ), _, _, _) _ ) = Right [PureAsm str instructions (Node ((Frame lbl ), _, _, f) xs) = (\body -> [BeginFrame f lbl] ++ body ++ [EndFrame f lbl]) <$> concatMapM instructions xs +instructions (Node ((VariableDeclaration _ _ ), _, _, _) _ ) = Right [] +instructions (Node ((RegisterDeclaration _ _ ), _, _, _) _ ) = Right [] +instructions (Node ((GlobalVarDeclaration n _ _), _, _, _) _ ) = Left (GlobalVariableInFrame n) +instructions (Node ((ConstVarDeclaration n _ _), _, _, _) _ ) = Left (GlobalVariableInFrame n) + instructions (Node ((Assignment name (NameValue val)), d, _, f) _) = Right [Move (findTarget f d name) (findTarget f d val)] instructions (Node ((Assignment name (IntegerValue val)), d, _, f) _) = Right [Move (findTarget f d name) (ConstantTarget val)] instructions (Node ((HLasm.Ast.Call lbl ns ), d, _, f) _ ) = Right [HLasm.Instructions.Call lbl (fmap (findTarget f d) ns) size] - where size = foldl (+) 0 . fmap (\(VariableData (_, (VariableDeclaration d))) -> valueSize d) $ d + where size = foldl (+) 0 . fmap (\(VariableData (_, d)) -> stackVarSize d) $ d instructions (Node ((If lbl), _, _, _) []) = Right [] instructions (Node ((If lbl), _, _, _) xs) = @@ -98,6 +104,21 @@ instructions (Node ((If lbl), _, _, _) xs) = branch i (Node ((IfBranch Nothing), _, _, _) xs) = ([Jump (lbl ++ show i) Nothing], wrapif i xs) +dataFilter (Node ((GlobalVarDeclaration n t v), _, _, _) _) = Just $ Variable n t v +dataFilter _ = Nothing +constFilter (Node ((ConstVarDeclaration n t v), _, _, _) _) = Just $ Variable n t v +constFilter _ = Nothing + +varSection ctor f xs = Right . ctor . fmap fromJust . filter isJust . fmap f $ xs + +filterF :: [(a -> Maybe b)] -> (a -> Bool) +filterF fs = foldl or (const True) . fmap ((.) (not . isJust)) $ fs + where or f g x = f x && g x + program :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result ObjProgram -program (Node ((Program), _, _, _) xs) = fmap (\i -> ObjProgram [Text i]) $ concatMapM instructions xs +program (Node ((Program), _, _, _) xs) = + do text <- concatMapM instructions . filter (filterF [dataFilter, constFilter]) $ xs + dat <- varSection Data dataFilter xs + const <- varSection Constants constFilter xs + Right $ ObjProgram [(Text text), dat, const] program _ = undefined diff --git a/src/HLasm/Parser.hs b/src/HLasm/Parser.hs index b9e4cd1..4bcb70d 100644 --- a/src/HLasm/Parser.hs +++ b/src/HLasm/Parser.hs @@ -43,9 +43,9 @@ break = leafP Break (keyword "break" *> parens name) asmCall = leafP AssemblyCall (spaces *> char '!' *> many1 (noneOf ";") <* char ';' <* spaces) call = leafP id (Call <$> (keyword "call" *> angles name) <*> parens (name `sepBy` achar ',')) -register = leafP id . aparse $ curry (VariableDeclaration . Register) <$> (keyword "reg" *> name) <*> (achar ':' *> name ) -variable = leafP id . aparse $ curry (VariableDeclaration . Variable) <$> (keyword "var" *> name) <*> (achar ':' *> vtype) - where vtype = Type <$> name <*> (Just <$> parens nat) +vtype = Type <$> name <*> (Just <$> parens nat) +register = leafP id . aparse $ RegisterDeclaration <$> (keyword "reg" *> name) <*> (achar ':' *> name ) +variable = leafP id . aparse $ VariableDeclaration <$> (keyword "var" *> name) <*> (achar ':' *> vtype) value = (IntegerValue <$> aparse nat) <|> (NameValue <$> aparse name) @@ -86,8 +86,11 @@ hlasm = reduce [ asmCall, call, HLasm.Parser.break, assignment ] where reduce (x:xs) = foldl (<|>) x xs +globalVariable word f = leafP id . aparse $ f <$> (keyword word *> name) <*> (achar ':' *> vtype) <*> (achar '=' *> value) +constant = globalVariable "const" ConstVarDeclaration +globvar = globalVariable "var" GlobalVarDeclaration -globals = frame hlasm <|> asmCallas +globals = frame hlasm <|> asmCall <|> constant <|> globvar program = (\a -> Node Program a) <$> (keyword "program" *> braces (many globals)) parse :: String -> Result SyntaxTree diff --git a/src/HLasm/Scope.hs b/src/HLasm/Scope.hs index 5272a8d..c78a68e 100644 --- a/src/HLasm/Scope.hs +++ b/src/HLasm/Scope.hs @@ -18,26 +18,29 @@ import HLasm.Ast import HLasm.Error data ScopeData = FluentScope - | IntroduceVariable HLValuable + | IntroduceVariable VariableName | IntroduceLabel Label deriving (Show, Eq) type ScopeTree = Tree ScopeData elementToScope :: HLElement -> ScopeData -elementToScope (Program) = FluentScope -elementToScope (InstructionSet) = FluentScope -elementToScope (VariableDeclaration value) = IntroduceVariable value -elementToScope (Frame (Just label)) = IntroduceLabel label -elementToScope (Frame Nothing) = FluentScope -elementToScope (If label) = IntroduceLabel label -elementToScope (IfBranch _) = FluentScope -elementToScope (While label) = IntroduceLabel label -elementToScope (DoWhile label) = IntroduceLabel label -elementToScope (Break _) = FluentScope -elementToScope (Call _ _) = FluentScope -elementToScope (Assignment _ _) = FluentScope -elementToScope (AssemblyCall _) = FluentScope +elementToScope (Program) = FluentScope +elementToScope (InstructionSet) = FluentScope +elementToScope (VariableDeclaration var _) = IntroduceVariable var +elementToScope (RegisterDeclaration var _) = IntroduceVariable var +elementToScope (GlobalVarDeclaration var _ _) = IntroduceVariable var +elementToScope (ConstVarDeclaration var _ _) = IntroduceVariable var +elementToScope (Frame (Just label)) = IntroduceLabel label +elementToScope (Frame Nothing) = FluentScope +elementToScope (If label) = IntroduceLabel label +elementToScope (IfBranch _) = FluentScope +elementToScope (While label) = IntroduceLabel label +elementToScope (DoWhile label) = IntroduceLabel label +elementToScope (Break _) = FluentScope +elementToScope (Call _ _) = FluentScope +elementToScope (Assignment _ _) = FluentScope +elementToScope (AssemblyCall _) = FluentScope data Scope = Root @@ -75,8 +78,8 @@ newtype LabelData = LabelData (Label, HLElement) deriving (Show) findVar :: Scope -> VariableName -> Either VariableName VariableData findVar Root name = Left name -findVar (Scope {scopeData = (IntroduceVariable var), scopeElement = el}) name | valuableName var == name = - Right $ VariableData (name, el) +findVar (Scope {scopeData = (IntroduceVariable var), scopeElement = el}) name | var == name = + Right $ VariableData (var, el) findVar (Scope {scopeParent = p}) name = findVar p name findLabel :: Scope -> Label -> Either Label LabelData diff --git a/src/HLasm/Types.hs b/src/HLasm/Types.hs index 5d282f8..936e8b8 100644 --- a/src/HLasm/Types.hs +++ b/src/HLasm/Types.hs @@ -27,8 +27,10 @@ registerSize ('r':x) | elem x sysregs = 64 registerSize _ = 0 getType :: HLElement -> Type -getType (VariableDeclaration (Variable (_, t))) = t -getType (VariableDeclaration (Register (_, r))) = Type "int" (Just (registerSize r)) +getType (VariableDeclaration _ t) = t +getType (ConstVarDeclaration _ t _) = t +getType (GlobalVarDeclaration _ t _) = t +getType (RegisterDeclaration _ r) = Type "int" (Just (registerSize r)) lookupType :: VariableName -> [VariableData] -> Maybe Type lookupType name = fmap getType . lookup name . fmap (\(VariableData x) -> x) From d9db6a9281752a3525e04dcbb4bee2c30f24b905 Mon Sep 17 00:00:00 2001 From: Vorotynsky Maxim Date: Sat, 6 Jun 2020 16:23:32 +0300 Subject: [PATCH 4/4] feat: fake global objects Created fake labels and fake vars. They are created to trick the scope checker, add an object into the scope and no objects to assembly. Added `any` type. This type is compatible with all other types. fix: `do` is a keyword. --- src/HLasm/Ast.hs | 2 ++ src/HLasm/Instructions.hs | 10 ++++++++-- src/HLasm/Parser.hs | 9 +++++++-- src/HLasm/Scope.hs | 2 ++ src/HLasm/Types.hs | 3 +++ 5 files changed, 22 insertions(+), 4 deletions(-) diff --git a/src/HLasm/Ast.hs b/src/HLasm/Ast.hs index 1e946b0..43a3ed8 100644 --- a/src/HLasm/Ast.hs +++ b/src/HLasm/Ast.hs @@ -42,6 +42,8 @@ data HLElement = | VariableDeclaration VariableName Type | GlobalVarDeclaration VariableName Type HLValue | ConstVarDeclaration VariableName Type HLValue + | FakeVariable VariableName + | FakeFrame Label | Frame (Maybe Label) | If Label | IfBranch (Maybe Condition) diff --git a/src/HLasm/Instructions.hs b/src/HLasm/Instructions.hs index 38ebc99..dd71337 100644 --- a/src/HLasm/Instructions.hs +++ b/src/HLasm/Instructions.hs @@ -70,8 +70,16 @@ valuableTarget (sf, vd) (NameValue name) = findTarget sf vd name loop :: Label -> Result (InstructionSet) -> Result (InstructionSet) loop lbl i = let begin = lbl ++ "begin" in fmap (\x -> [Label begin] ++ x ++ [Jump begin Nothing, Label (lbl ++ "end")]) $ i +isEmptyInstruction :: HLElement -> Bool +isEmptyInstruction (FakeVariable _) = True +isEmptyInstruction (FakeFrame _) = True +isEmptyInstruction (VariableDeclaration _ _) = True +isEmptyInstruction (RegisterDeclaration _ _) = True +isEmptyInstruction _ = False + instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet) +instructions (Node (el, _, _, _) _) | isEmptyInstruction el = Right [] instructions (Node ((InstructionSet ), _, _, _) xs) = concatMapM instructions xs instructions (Node ((While lbl ), _, _, _) xs) = loop lbl (concatMapM instructions xs) instructions (Node ((DoWhile lbl ), _, _, _) xs) = loop lbl (concatMapM instructions xs) @@ -80,8 +88,6 @@ instructions (Node ((AssemblyCall str ), _, _, _) _ ) = Right [PureAsm str instructions (Node ((Frame lbl ), _, _, f) xs) = (\body -> [BeginFrame f lbl] ++ body ++ [EndFrame f lbl]) <$> concatMapM instructions xs -instructions (Node ((VariableDeclaration _ _ ), _, _, _) _ ) = Right [] -instructions (Node ((RegisterDeclaration _ _ ), _, _, _) _ ) = Right [] instructions (Node ((GlobalVarDeclaration n _ _), _, _, _) _ ) = Left (GlobalVariableInFrame n) instructions (Node ((ConstVarDeclaration n _ _), _, _, _) _ ) = Left (GlobalVariableInFrame n) diff --git a/src/HLasm/Parser.hs b/src/HLasm/Parser.hs index 4bcb70d..415c237 100644 --- a/src/HLasm/Parser.hs +++ b/src/HLasm/Parser.hs @@ -78,7 +78,7 @@ ifstatment p = whileHead = keyword "while" *> parens name while p = (\l b -> Node (While l) [b]) <$> whileHead <*> (block p) -dowhile p = (\b l -> Node (DoWhile l) [b]) <$> (spaces *> string "do" *> block p) <*> whileHead +dowhile p = (\b l -> Node (DoWhile l) [b]) <$> (spaces *> keyword "do" *> block p) <*> whileHead hlasm = reduce [ asmCall, call, HLasm.Parser.break, register, variable, frame hlasm, @@ -90,7 +90,12 @@ globalVariable word f = leafP id . aparse $ f <$> (keyword word *> name) <*> (ac constant = globalVariable "const" ConstVarDeclaration globvar = globalVariable "var" GlobalVarDeclaration -globals = frame hlasm <|> asmCall <|> constant <|> globvar +declare = keyword "fake" *> (var <|> label) + where var = leafP FakeVariable (keyword "var" *> angles name <* spaces) + label = leafP FakeFrame (keyword "frame" *> angles name <* spaces) + + +globals = frame hlasm <|> asmCall <|> constant <|> globvar <|> declare program = (\a -> Node Program a) <$> (keyword "program" *> braces (many globals)) parse :: String -> Result SyntaxTree diff --git a/src/HLasm/Scope.hs b/src/HLasm/Scope.hs index c78a68e..664f592 100644 --- a/src/HLasm/Scope.hs +++ b/src/HLasm/Scope.hs @@ -31,6 +31,8 @@ elementToScope (VariableDeclaration var _) = IntroduceVariable var elementToScope (RegisterDeclaration var _) = IntroduceVariable var elementToScope (GlobalVarDeclaration var _ _) = IntroduceVariable var elementToScope (ConstVarDeclaration var _ _) = IntroduceVariable var +elementToScope (FakeVariable name) = IntroduceVariable name +elementToScope (FakeFrame name) = IntroduceLabel name elementToScope (Frame (Just label)) = IntroduceLabel label elementToScope (Frame Nothing) = FluentScope elementToScope (If label) = IntroduceLabel label diff --git a/src/HLasm/Types.hs b/src/HLasm/Types.hs index 936e8b8..962a526 100644 --- a/src/HLasm/Types.hs +++ b/src/HLasm/Types.hs @@ -10,6 +10,8 @@ import HLasm.Scope import HLasm.Error typeSuit :: Type -> Type -> Bool +typeSuit (Type "any" _) _ = True +typeSuit _ (Type "any" _) = True typeSuit (Type lname _) (Type rname _) | (lname /= rname) = False typeSuit (Type _ l) (Type _ r) = (fromMaybe maxBound l) >= (fromMaybe maxBound r) @@ -31,6 +33,7 @@ getType (VariableDeclaration _ t) = t getType (ConstVarDeclaration _ t _) = t getType (GlobalVarDeclaration _ t _) = t getType (RegisterDeclaration _ r) = Type "int" (Just (registerSize r)) +getType (FakeVariable _) = Type "any" Nothing lookupType :: VariableName -> [VariableData] -> Maybe Type lookupType name = fmap getType . lookup name . fmap (\(VariableData x) -> x)